From: John Darrington Date: Wed, 10 Dec 2003 23:27:28 +0000 (+0000) Subject: checkin of 0.3.0 X-Git-Tag: v0.4.0~487 X-Git-Url: https://pintos-os.org/cgi-bin/gitweb.cgi?p=pspp-builds.git;a=commitdiff_plain;h=4944c86a9318bc5b5578ab145a95c116ffd2c9fd checkin of 0.3.0 --- 4944c86a9318bc5b5578ab145a95c116ffd2c9fd diff --git a/AUTHORS b/AUTHORS new file mode 100644 index 00000000..0262209b --- /dev/null +++ b/AUTHORS @@ -0,0 +1,7 @@ + PSPP Authors + + * Ben Pfaff wrote most of the program and the manual. + * John Williams wrote the T-TEST procedure. + * Jim Van Zandt translated the `julcal' date calculation package + into C from code written by Michael Covington, which was based on + formulae by Jean Meeus. diff --git a/COPYING b/COPYING new file mode 100644 index 00000000..e77696ae --- /dev/null +++ b/COPYING @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 675 Mass Ave, Cambridge, MA 02139, USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19yy name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Library General +Public License instead of this License. diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 00000000..7ee9ca18 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,1751 @@ +Sun Jan 2 21:24:32 2000 Ben Pfaff + + * Makefile.am: Require Automake 1.4 or later. It's been out for + almost a year now, so why haven't you installed it? :-) + + * TODO: Updated. + + * configure.in: Updated version number. Check for libgmp. Check + of fenv.h. Check for feholdexpect(). + + * pref.h.orig: Don't include debug-print.h by default. Don't + disable __attribute ((unused))__ for gcc 2.7.2. Remove LOAD_2, + STORE_2. Comment fixes. + + * Updated copyright notices in all files. + +Fri Mar 12 12:38:55 1999 Ben Pfaff + + * Forked 0.3.0. + +Tue Mar 9 12:46:31 1999 Ben Pfaff + + * Released 0.2.3. + + * TODO: Updated. + +Tue Jan 5 15:18:07 1999 Ben Pfaff + + * Released 0.2.2. + + * TODO: Update from Zvi Grauer . + +Thu Nov 19 12:34:55 1998 Ben Pfaff + + * Released 0.2.1. + +Sun Aug 9 11:11:32 1998 Ben Pfaff + + * LANGUAGE: Updated. + +Sat Aug 8 00:19:08 1998 Ben Pfaff + + * LANGUAGE: Updated. + + * examples/: New directory. + + * Made patchlevel 95. + +Tue Aug 4 23:47:31 1998 Ben Pfaff + + * Bump version to 0.1.22 (0.2.0 release candidate). + + * configure.in: Remove --enable-Werror, new option + --enable-debugging. New gcc option -Wpointer-arith. + + * pref.h.orig: Don't enable debugging by default (now a configure + option). Use __inline__ instead of inline with gcc (partial -ansi + -pedantic support). + (macro local_strdup) Removed. + + * Made patchlevel 94. + +Wed Jul 29 22:03:11 1998 Ben Pfaff + + * Bump version to 0.1.21 (0.2.0 release candidate). + + * debian/: Removed. + + * Makefile.am: Don't copy debian/ into distribution. + + * pref.h.orig: Only enable `unused' attribute if gcc 2.8.0 or + later is used. + +Sun Jul 5 14:20:04 1998 Ben Pfaff + + * configure.in: Bump version to 0.1.20 (0.2.0 release candidate). + + * Made patchlevel 93. + +Sun Jul 5 00:13:58 1998 Ben Pfaff + + * README: Updated. + + * TODO: Updated. + + * configure.in: Remove -Wno-unused from default gcc flags. + + * pref.h.orig: Add new #define, `unused', which under gcc expands + to an explanation to the compiler that a function argument is + unused, and expands to the null string under other compilers. + +Mon Jun 1 14:33:02 1998 Ben Pfaff + + * LANGUAGE: Updated. + + * configure.in: Bump version to 0.1.19. + + * Made patchlevel 92. + +Sun May 31 00:55:13 1998 Ben Pfaff + + * TODO: Updated. + + * configure.in: Generate Makefiles for lib/gmp/{,mpn,mpf}/. + + * Made patchlevel 91. + +Fri May 29 21:43:09 1998 Ben Pfaff + + * TODO: Updated. + + * LANGUAGE: Updated. + + * unconfigure: Remove TeX cruft from doc/. + + * Made patchlevel 90. + +Mon May 25 12:41:54 1998 Ben Pfaff + + * BUGS: Updated. + + * LANGUAGE: Updated. + + * TODO: Updated. + + * configure.in: Bumped version number up to 0.1.18. + + * Made patchlevel 89. + +Sun May 24 22:39:55 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 88. + +Sat May 23 23:21:43 1998 Ben Pfaff + + * TODO: Updated. + + * configure.in: Remove gamma from replaceable functions. + + * Made patchlevel 87. + +Fri May 22 00:02:33 1998 Ben Pfaff + + * configure.in: Add gamma to list of functions with replacements. + + * Made patchlevel 86. + +Wed May 20 00:00:12 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 85. + +Sat May 16 19:38:49 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 84. + +Tue May 12 16:13:48 1998 Ben Pfaff + + * TODO: Updated. + + * unconfigure: Don't delete Makefile.in under intl/. + + * Made patchlevel 83. + +Thu May 7 23:16:26 1998 Ben Pfaff + + * unconfigure: Add some more files to reap. + + * Made patchlevel 82. + +Tue May 5 13:17:59 1998 Ben Pfaff + + * acconfig.h: Add HAVE_GOOD_RANDOM definition. + + * acinclude.m4: New macro BLP_RANDOM. + + * configure.in: Use new BLP_RANDOM macro. + + * unconfigure: New file. + + * Made patchlevel 81. + +Fri Apr 24 12:42:14 1998 Ben Pfaff + + * Makefile.am: Remove bad comment. + + * AUTHORS: Removed Brad Appleton. + + * TODO: Updated. + + * configure.in: Remove `satisfy automake' bit. Don't generate + avllib Makefile, since we don't use avllib anymore. + + * pref.h.orig: Define PSPP. + + * Made patchlevel 80. + +Wed Apr 15 12:59:39 1998 Ben Pfaff + + * AUTHORS, BUGS, LANGUAGE, README, THANKS: No longer generated + from HTML. This caused a lot of deletions from the Makefile.am. + + * TODO: Updated. + + * Made patchlevel 79. + +Tue Apr 14 00:48:00 1998 Ben Pfaff + + * TODO: Updated. + + * configure.in: Check for unistd.h. Fix AC_LN_S (should have been + AC_PROG_LN_S). + + * Made patchlevel 78. Must have missed 77 in there somewhere :-) + +Mon Mar 9 15:40:40 1998 Ben Pfaff + + * Made patchlevel 76. + + * configure.in: Bumped version up to 0.1.16. + +1998-03-05 Ben Pfaff + + * configure.in: Bumped version up to 0.1.15. + +1998-02-23 Ben Pfaff + + * acinclude.m4: Add BLP_INT_DIGITS and BLP_IS_SPRINTF_GOOD macros. + + * configure.in: Those macros came from here. Better modularity + this way. Bump version up to 0.1.14. + + * pref.h.orig: (macros CONFIG_PATH, INCLUDE_PATH, GROFF_FONT_PATH) + Removed. + + * Made patchlevel 75. + +1998-02-23 Ben Pfaff + + * acconfig.h: Hard-code PACKAGE and GNU_PACKAGE as "PSPP" and "GNU + PSPP" respectively. + + * configure.in: Call the package pspp instead of PSPP. Don't + define PACKAGE and GNU_PACKAGE symbols. Add replacement function + for strtok_r. + + * TODO: Updated. + + * Made patchlevel 74. + +1998-02-16 Ben Pfaff + + * Makefile.am: Remove a few now-useless targets. + + * TODO: Updated. + + * configure.in: Bump version up to 0.1.13. + + * reconfigure: Don't assume . is in PATH. + + * Made patchlevel 73. + +Fri Feb 13 15:35:03 1998 Ben Pfaff + + * configure.in: Bump version up to 0.1.12. + + * TODO: Updated. + + * pref.h.orig: Make __unix equivalent to unix and __unix__; don't + require any of these to be defined to 1, just defined. Invert + sense of some tests from testing for unix to testing for not being + msdog. + + * Made patchlevel 72. + +Thu Feb 5 00:22:58 1998 Ben Pfaff + + * Made patchlevel 71. + + * configure.in: Bump version up to 0.1.11. + +Tue Feb 3 16:12:34 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 70. + + * configure.in: Bump version up to 0.1.10. + +Fri Jan 23 00:17:18 1998 Ben Pfaff + + * Made patchlevel 69. + +Thu Jan 22 00:35:52 1998 Ben Pfaff + + * Made patchlevel 68. + +Sun Jan 18 00:30:18 1998 Ben Pfaff + + * configure.in: Add ieeefp.h to list of headers to check for. + + * Made patchlevel 67. + +Tue Jan 13 23:44:16 1998 Ben Pfaff + + * configure.in: Add sys/wait.h to list of headers to check for. + + * Made patchlevel 66. + +Sun Jan 11 21:30:09 1998 Ben Pfaff + + * configure.in: Bump version up to 0.1.9. + + * pref.h.orig (STORE_2): Fix parentheses. From Alexandre + Oliva . + + * Made patchlevel 65. + +Sat Jan 10 23:59:06 1998 Ben Pfaff + + * Made patchlevel 64. + +Sat Jan 10 02:10:15 1998 Ben Pfaff + + * TODO: Updated. + + * pref.h.orig: Comment fixes. + (macro second_lowest_flt64) New. + + * Made patchlevel 63. + +Thu Jan 8 22:27:03 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 62. + +Mon Jan 5 11:18:37 1998 Ben Pfaff + + * Made patchlevel 61. + +Sun Jan 4 18:10:29 1998 Ben Pfaff + + * TODO: Updated. + + * pref.h.orig: (local_strdup) [HAVE_ALLOCA && PAGED_STACK && + __GNUC__] Rewritten for space and time efficiency and to evaluate + its argument only once. + + * Made patchlevel 60. + +Sat Jan 3 16:51:20 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 59. + +Fri Jan 2 01:38:37 1998 Ben Pfaff + + * TODO: Updated. + + * config.sub: Got tired of `i686-unknown-linux: Unknown system', + so I made 686 equivalent to 586. + + * pref.h.orig: (macros ASCII_*, HTML_*, PS_*) Removed. + + * Made patchlevel 58. + +Thu Jan 1 11:50:47 1998 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 57. + +Fri Dec 26 15:43:17 1997 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 56. + +Wed Dec 24 22:34:55 1997 Ben Pfaff + + * reconfigure: regularized option syntax. + + * configure.in: Bumped version to 0.1.8. Changed name from pspp + to PSPP. Added lib/dcdflib/Makefile to list of output files. + + * Made patchlevel 55. + +Sun Dec 21 15:58:52 1997 Ben Pfaff + + * TODO: Updated. + + * acconfig.h: Reformat. + + * configure.in: Bumped version to 0.1.7. + + * Made patchlevel 54. + +Fri Dec 5 23:38:12 1997 Ben Pfaff + + * Replaced prep.ai.mit.edu with ftp.gnu.org and .gnu.ai.mit.edu + with .gnu.org, everywhere. + +Fri Dec 5 23:02:40 1997 Ben Pfaff + + * Replaced remaining instances of Fiasco with PSPP. + + * Made patchlevel 53. + +Fri Dec 5 22:51:18 1997 Ben Pfaff + + * Every instance of the name Fiasco, throughout every file, + replaced in-place with PSPP, with the exceptions of a few files + that had `fiasco' in their names; these were renamed. + + * Made patchlevel 52. + +Fri Dec 5 21:50:52 1997 Ben Pfaff + + * pref.h.orig: (macros NO_HTML, HTML_DEFAULT_OUTPUT_FILE) New + macros. + + * TODO: Updated. + + * Made patchlevel 51. + +Tue Dec 2 14:35:12 1997 Ben Pfaff + + * TODO: Updated. + + * configure.in: Bumped version to 0.1.6. + + * Made patchlevel 50. + +Sat Nov 22 01:20:32 1997 Ben Pfaff + + * Made patchlevel 49. + +Fri Nov 21 00:11:41 1997 Ben Pfaff + + * Made patchlevel 48. + +Sun Nov 16 01:31:38 1997 Ben Pfaff + + * Made patchlevel 47. + +Fri Nov 14 00:17:48 1997 Ben Pfaff + + * Made patchlevel 46. + + * configure.in: Bumped version to 0.1.5. + +Tue Oct 28 16:07:17 1997 Ben Pfaff + + * configure.in: Bumped version to 0.1.4. + + * TODO: Updated. + + * Made patchlevel 45. + +Wed Oct 8 15:55:50 1997 Ben Pfaff + + * intl: Upgraded from sources to gettext-0.10.32. + + * configure.in: Bumped version to 0.1.3. + + * Made patchlevel 44. + +Tue Oct 7 20:21:53 1997 Ben Pfaff + + * Makefile.am: (dist-hook) Use $(top_srcdir). + + * pref.h.orig: (MAX_WORKSPACE) Enlarge to 4 MB (from 1 MB). + + * Made patchlevel 43. + +Sun Oct 5 15:52:37 1997 Ben Pfaff + + * configure.in: Bumped version to 0.1.2. + (strerror) Replace instead of check. From Alexandre Oliva + . + + * pref.h.orig: Include `debug-print' instead of + `src/debug-print.h'. + + * Made patchlevel 42. + +Sat Oct 4 16:19:44 1997 Ben Pfaff + + * pref.h.orig: Comment fixes. + (local_strdup) [HAVE_ALLOCA && PAGED_STACK && + __GNUC__] Use local_alloc() instead of alloca(), as local_alloc() + isn't simply an alias for alloca(). + + * configure.in: Bumped version to 0.1.1. + + * Made patchlevel 41. + +Sat Oct 4 02:13:00 1997 Ben Pfaff + + * Made patchlevel 40. + +Sun Sep 21 00:07:09 1997 Ben Pfaff + + * Made patchlevel 39. + +Thu Sep 18 21:42:27 1997 Ben Pfaff + + * pref.h.orig: (CONFIG_PATH) [unix] Add /usr/local/etc/fiasco, + /usr/etc/fiasco to search path. + + * Made patchlevel 38. + +Wed Aug 20 14:20:06 1997 Ben Pfaff + + * Makefile.am: (noinst_DATA) Removed ANNOUNCE, HELP-WANTED. + (EXTRA_DIST) Removed ANNOUNCE, FAQ, HELP-WANTED, mk-web-dist. + (MAINTAINERCLEANFILES) Removed ANNOUNCE, FAQ, HELP-WANTED. + + * Made patchlevel 37. + +Wed Aug 20 12:48:25 1997 Ben Pfaff + + * Makefile.am: (doc/ANNOUNCE.html, ANNOUNCE, FAQ, doc/FAQ.html, + HELP-WANTED) Removed. + (docfiles) Removed ANNOUNCE, FAQ, HELP-WANTED. + + * mk-web-dist: Removed. + + * Made patchlevel 36. + +Mon Aug 18 18:06:12 1997 Ben Pfaff + + * TODO: Updated. + + * pref.h.orig: (macro DEFAULT_COMPAT) Removed. + + * Made patchlevel 35. + +Sun Aug 17 22:48:36 1997 Ben Pfaff + + * Made patchlevel 34. + +Sat Aug 16 10:48:29 1997 Ben Pfaff + + * In many files, in this directory and others, messages were + rephrased to eliminate or reduce usage of certain deprecated terms + at suggestion of rms. + + * Makefile.am: (EXTRA_DIST) Removed unix2dos.pl. + (MAINTAINERCLEANFILES) Removed doc/ANNOUNCE.html, doc/README.html. + (docfiles-recursive) Removed. + + * TODO: Updated. + + * mk-web-dist: Doesn't produce any distributions at all, just a + webpage. Doesn't configure the distribution. Changed list of + files installed. + + * pref.h.orig: s/VER_PCP40/VER_PC/; s/VER_WIN61/VER_WND/; + s/VER_X40/VER_X/; All references changed. + + * Made patchlevel 33. + +Thu Aug 14 22:02:08 1997 Ben Pfaff + + * Makefile.am: Comment fixes. Uses $(VERSION) instead of contents + of VERSION file. + (EXTRA_DIST) Remove fiasco.ide, mk-bc5-dist. + (docfiles-recursive) Works if doc/Makefile doesn't exist. + (DIST_BC5_ROOT) Renamed DISTBC5_DISTROOT. + (DISTBC5_BC5ROOT) New var. + (dist-bc5) Passes $(DISTBC5_BC5ROOT). + + * TODO: Update. + + * acinclude.m4: Remove blp_VERSION_CHEAT kluge. + + * configure.in: Don't use blp_VERSION_CHEAT kluge. + + * mk-web-dist, reconfigure: Extract version number from + configure.in. + + * pref.h.orig: (CONFIG_PATH, INCLUDE_PATH, GROFF_FONT_PATH) + [__MSDOS__] Fixed bad use of backslashes. + + * reconfigure: Pass $VERSION to Makefile. + + * Made patchlevel 32. + +Thu Aug 14 11:49:35 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST, docfiles) Add ONEWS. + (docfiles) Depends on docfiles-recursive. + (docfiles-recursive) New target, call make for `docfiles' target + in doc directory. + (dist-bc5) Adds `foo' second arg to mk-bc5-dist. + (.PHONY) Add docfiles. + + * mk-bc5-dist: Checks that it is passed a second arg of `foo'. + + * reconfigure: Changed == operators to = as arguments to `test'. + No longer uses bash -v switch. + + * mk-distribution: Renamed mk-web-dist, all references changed. + Now takes several options, added help. No longer uses -uv + options. + + * Made patchlevel 31. + +Tue Aug 5 13:56:39 1997 Ben Pfaff + + * Makefile.am: (MAINTAINERCLEANFILES) Add HELP-WANTED. + (EXTRA_DIST) Add ONEWS. + + * Made patchlevel 30. + +Sun Aug 3 11:30:17 1997 Ben Pfaff + + * Makefile.am: (noinst_data, docfiles) Added HELP-WANTED. + (EXTRA_DIST) Added configure, mk-bc5-dist, unix2dos.pl, + HELP-WANTED. + (HELP-WANTED) Generated from doc/HELP-WANTED.html. + (dist-bc5) New target. + + * TODO: Updated. + + * mk-distribution: Fixed bugs, added HELP-WANTED. + + * reconfigure: When invoking Makefile.am, pass + top_srcdir=. explicitly. + + * unix2dos.pl: New file. + + * Made patchlevel 29. + +Thu Jul 17 21:49:13 1997 Ben Pfaff + + * Made patchlevel 28. + +Thu Jul 17 01:43:25 1997 Ben Pfaff + + * Makefile.am: Remove inactive .html suffix rule. + New rules to generate doc/ANNOUNCE.html and doc/README.html from + corresponding .in files. + (EXTRA_DIST) Add VERSION, fiasco.ide, mk-distribution. + (MAINTAINERCLEANFILES) Add doc/ANNOUNCE.html, doc/README.html. + + * acinclude.m4: (blp_VERSION_CHEAT) New macro. + + * configure.in: Forces _GNU_SOURCES not only to be defined, but to + a value of 1. Substitutes VERSION from the new file VERSION. + Removed DEBIAN reference. Checks for sys/mman.h header. + + * pref.h.orig: (macro gettext) Don't put parentheses in the + expansion. + (macro N_) Same. + + * reconfigure: Sets -ev in shell. Doesn't try to pass + --include-deps to configure (it's an automake flag!). Moved `make + docfiles'. + + * sysdeps/borlandc4.0/README, sysdeps/borlandc4.0/_read.c, + sysdeps/borlandc4.0/_write.c, sysdeps/borlandc4.0: Removed. + + * VERSION: New file. + + * fiasco.ide: New file. + + * mk-distribution: New file. + + * Made patchlevel 27. + +Fri Jul 11 23:00:53 1997 Ben Pfaff + + * TODO: Updates. + + * Made patchlevel 26. + +Fri Jul 11 14:08:21 1997 Ben Pfaff + + * pref.h.orig: __CYGWIN32__ is a form of __unix__. + + * reconfigure: Add -k for make maintainer-clean. + + * Made patchlevel 25. + +Thu Jul 10 22:13:07 1997 Ben Pfaff + + * configure.in: Add "-D_GNU_SOURCE" to CPPFLAGS to force GNU + glibc extensions to be detected. + + * Made patchlevel 24. + +Sun Jul 6 19:13:07 1997 Ben Pfaff + + * pref.h.orig: Include "src/debug-print.h" instead of + "debug-print.h". + (macros local_alloc, local_free) More robust under Checker: put + their allocations in namespace different from malloc()/free(). + + * Made patchlevel 23. + +Sat Jul 5 23:42:14 1997 Ben Pfaff + + * TODO: Updates. + + * Made patchlevel 22. + +Fri Jul 4 13:20:47 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Removed orphaned-rules. + (docfiles) Removed ChangeLog, COPYING. + (html, maintainer-clean-hook, install-data-hook) Removed. + + * reconfigure: Added --help option. Calls configure again even if + --no-include-deps. + + * Made patchlevel 21. + +Wed Jun 25 22:47:17 1997 Ben Pfaff + + * Makefile.am: Require Automake 1.2. + (dist-hook) Don't copy config dir. + (EXTRA_DIST, MAINTAINERCLEANFILES) Add FAQ. + (docfiles) Made a variable as well as a target; added ChangeLog, + COPYING, FAQ, INSTALL, TODO. + (html, maintainer-clean-hook, install-data-hook, debian, + debian-clean, debian-clean-full) New targets. + + * orphaned-rules: Removed. + + * configure.in: Bumped up to version 0.1.0. + + * reconfigure: New options --enable-nls, --no-include-deps. + Comment fixes. + + * Made patchlevel 20. + +Sun Jun 22 22:10:27 1997 Ben Pfaff + + * Made patchlevel 19. + +Sun Jun 15 16:44:14 1997 Ben Pfaff + + * pref.h.orig: Comment fixes. Includes debug-print.h. + (DEMAND_PAGE, ALWAYS_PAGE, NEVER_PAGE) Removed. + + * Made patchlevel 18. + +Sun Jun 8 01:25:40 1997 Ben Pfaff + + * Made patchlevel 17. + +Fri Jun 6 22:41:08 1997 Ben Pfaff + + * TODO: Updates. + + * pref.h.orig: Reformatted macros. + [!ENABLE_NLS] Defines gettext() as a trivial substitution to allow + gcc to give warnings on printf(). + + * Made patchlevel 16. + +Thu Jun 5 23:01:49 1997 Ben Pfaff + + * Made patchlevel 15. + +Tue Jun 3 23:24:08 1997 Ben Pfaff + + * Makefile.am: AUTOMAKE_OPTIONS changed from `foreign 1.1l' to + `gnits 1.1p'. SUBDIRS reordered. New target `docfiles'. + + * TODO: Updates. + + * configure.in: Removed AM_MAINTAINER_MODE. Added + --enable-Werror, which is implied by --with-checker. + + * reconfigure: Moved `aclocal' from beginning to just before + cleaning `autoheader'. Removed --enable-maintainer-mode. Added + --disable-nls. Added `make docfiles' to placate autoheader. + Added `aclocal' before first real `autoheader'. Uses `make + mostlyclean' instead of `make depend'. + + * Made patchlevel 14. + +Mon Jun 2 14:21:54 1997 Ben Pfaff + + * configure.in: Removed comment that screwed things up. + + * reconfigure: Added `aclocal' at beginning. + + * Made patchlevel 13. + +Sun Jun 1 23:25:39 1997 Ben Pfaff + + * Makefile.am: Add intl, po to SUBDIRS. Add aclocal.m4, + config.h.in to MAINTAINERCLEANFILES. + + * acconfig.h: Add HAVE_LC_MESSAGES, ENABLE_NLS, HAVE_CATGETS, + HAVE_GETTEXT, HAVE_STPCPY. + + * configure.in: Reordered to placate autoheader. Added + AC_ISC_POSIX, AM_PROG_CC_STDC. Added internationalization: + ALL_LINGUAS="", AM_GNU_GETTEXT, AC_LINK_FILES(...). Added + po/Makefile.in, intl/Makefile to generated files list. Generates + po/Makefile from po/Makefile.in. Comment fix. + + * pref.h.orig: Uncommented i18n support. + + * acinclude.m4: New file. + + * ABOUT-NLS: New file. + + * intl/: New directory, taken from gettext-0.10.27. + + * missing: New file, taken from automake-1.1p. + + * po/: New directory. + + * Made patchlevel 12. + +Sun Jun 1 17:28:27 1997 Ben Pfaff + + * Made patchlevel 11. + +Sun Jun 1 11:58:43 1997 Ben Pfaff + + * pref.h.orig: Removed DEFAULT_VER_PCP40, DEFAULT_VER_WIN61, + DEFAULT_VER_X40. Added a macro DEFAULT_COMPAT that takes one of + the VER_* enums as a value. + (HISTORY_FILE) Changed the definition to "~/.fiasco_history". + + * Made patchlevel 10. + +Fri May 30 19:40:22 1997 Ben Pfaff + + * pref.h.orig: [__MSDOS__] Reordered INCLUDE_PATH. + + * Made patchlevel 9. + +Sun May 25 22:32:57 1997 Ben Pfaff + + * acconfig.h: For support of glibc 2, define _GNU_SOURCE. + + * Made patchlevel 8. + +Mon May 5 21:58:22 1997 Ben Pfaff + + * Made patchlevel 7. + +Fri May 2 22:27:36 1997 Ben Pfaff + + * Made patchlevel 6. + +Thu May 1 15:34:01 1997 Ben Pfaff + + * All files: Changed copyright from `Ben Pfaff' to `Free Software + Foundation, Inc'. + + * Made patchlevel 5. + +Thu May 1 15:00:51 1997 Ben Pfaff + + * Made patchlevel 4. + +Sat Apr 26 11:34:05 1997 Ben Pfaff + + * ChangeLog: Split into one ChangeLog per directory. + + * Made patchlevel 3. + +Wed Apr 23 21:33:48 1997 Ben Pfaff + + * TODO: Update. + + * Made patchlevel 2. + +Fri Apr 18 16:48:41 1997 Ben Pfaff + + * Makefile.am: Removed `include', `util' from SUBDIRS; added + `config'. Includes `config' directory in distributions. Added + `private-install', `private-uninstall' targets. + + * configure.in: AC_INIT tests for src/q2c.c now. Removed + redundant AC_PROG_MAKE_SET call. Removed include/Makefile, + util/Makefile from generated files list; added config/Makefile. + + * include/approx.h, include/arena.h, include/common.h, + include/dfm.h, include/do-ifP.h, include/error.h, include/expr.h, + include/exprP.h, include/file-handle.h, include/filename.h, + include/font.h, include/getline.h, include/getopt.h, + include/hash.h, include/heap.h, include/log.h, include/misc.h, + include/output.h, include/settings.h, include/sfm.h, + include/sfmP.h, include/som.h, include/somP.h, include/stat.h, + include/stats.h, include/str.h, include/tokens.h, include/var.h, + include/version.h, include/vfmP.h: Moved into src/ directory. + + * include/Makefile.am, include/: Removed. + + * util/Makefile.am: Removed. + + * util/q2c.c: Moved to src/. + + * util/reconfigure: Moved to source root. + + * util/: Removed. + + * Made patchlevel 1. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-cleans generated documentation and + Makefile.in. + + * include/Makefile.am, util/Makefile.am: Maintainer-cleans + Makefile.in. + + * include/somP.h: (static struct var som) Removed passed_t member. + + * TODO: Updated. + + * configure.in: Fixed source directory for copying pref.h; always + updates pref.h or at least touch'es it. + + * pref.h.orig: Made a rather pejorative comment a lot milder so it + wouldn't be misinterpreted. + + * Made interim release x3. + +Thu Mar 27 01:11:29 1997 Ben Pfaff + + * All directories now contain new `Makefile.am's, in some cases + produced from bits and pieces of the single monolithic old one. + + * PATCHLEVEL: Removed. + + * acconfig.h: Added GNU_PACKAGE, PACKAGE, PROTOTYPES, VERSION; + removed inclusion of conf.h. + + * confh.in: Removed. + * confh.tmp.in: Removed. + + * configure.in: Deepened. Updated for use with Automake 1.1l. + Removed PATCHLEVEL hacks. Fixed lots of functions in + AC_CHECK_FUNCS, AC_REPLACE_FUNCS, and similar. Only passes + `-Werror' to gcc in maintainer mode. Doesn't output conf.h. + Touches pref.h even if it wasn't changed. + + * aclocal.m4: New file. + + * config.h.in: Renamed from configh.in. + + * pref.h.orig: Renamed from prefh.orig. + + * Made interim release x2. + +Thu Mar 27 01:07:02 1997 Ben Pfaff + + Changed the distribution from flat to deep. New configuration: + + ANNOUNCE Makefile.in config.h.in mkinstalldirs + AUTHORS NEWS config.sub orphaned-rules + BUGS README configure pref.h + COPYING THANKS configure.in pref.h.orig + ChangeLog TODO debian src + ChangeLog~ acconfig.h doc stamp-h.in + INSTALL aclocal.m4 include sysdeps + LANGUAGE config install-sh tests + Makefile.am config.guess lib util + + config: + devices environment papersize ps-fontmap ps-prologue + + debian: + changelog control postinst rules + conffiles copyright postrm + + doc: + ANNOUNCE.html Makefile.in fiasco.info-2 stamp-vti + AUTHORS.html README.html fiasco.info-3 texinfo.tex + BUGS.html THANKS.html fiasco.info-4 version.texi + LANGUAGE.html fiasco.info fiasco.texi + Makefile.am fiasco.info-1 mdate-sh + + include: + approx.h file-handle.h misc.h stats.h + arena.h filename.h output.h str.h + common.h font.h settings.h tokens.h + dfm.h getline.h sfm.h var.h + do-ifP.h getopt.h sfmP.h version.h + error.h hash.h som.h vfmP.h + expr.h heap.h somP.h + exprP.h log.h stat.h + + lib: + Makefile.am Makefile.in avllib julcal misc + + lib/avllib: + AVLLIB.COPYING Makefile.in avl.h + Makefile.am avl.c + + lib/julcal: + Makefile.am Makefile.in julcal.c julcal.h + + lib/misc: + Makefile.am getopt1.c memset.c strstr.c + Makefile.in memchr.c qsort.c strtol.c + alloca.c memcmp.c stpcpy.c strtoul.c + getdelim.c memcpy.c strcasecmp.c + getline.c memmem.c strncasecmp.c + getopt.c memmove.c strpbrk.c + + src: + Makefile.am error.c lexer.c sfm-write.c + Makefile.in expr-evl.c list.c show.c + arena.c expr-opt.c list.q som-frnt.c + ascii.c expr-prs.c log.c som-high.c + autorecode.c file-handle.c loop.c som-low.c + cases.c file-handle.q main.c sort.c + cmdline.c file-type.c mis-val.c split-file.c + command.c filename.c misc.c stats.c + common.c formats.c modify-vars.c str.c + compute.c freq.c numeric.c sysfile-info.c + count.c frequencies.c output.c temporary.c + crosstabs.c frequencies.g postscript.c title.c + crosstabs.q frequencies.q print.c val-labs.c + data-in.c get.c recode.c var-labs.c + data-list.c getline.c rename-vars.c vars-atr.c + data-out.c glob.c repeat.c vars-prs.c + descript.c groff-font.c sample.c vector.c + descript.q hash.c sel-if.c version.c + dfm.c heap.c set.c vfm.c + display.c include.c set.q weight.c + do-if.c inpt-pgm.c sfm-read.c + + sysdeps: + BorlndC4.0 DJGPP2.0 Windows + + sysdeps/BorlndC4.0: + Makefile _write.c conf.h + _read.c compile.bat config.h + + sysdeps/DJGPP2.0: + Makefile compile.bat conf.h config.h + + sysdeps/Windows: + con32s.c + + tests: + Makefile.am expression.stat reread.data + Makefile.in fall92.data reread.stat + autorecode.stat fall92.stat sample.stat + begin-data.stat file-label.stat show-check-msg + bignum.data file-type.stat sort.data + bignum.stat filter.stat sort.stat + bug.stat gengarbage.c split-file.stat + compute.stat input-program.stat sysfile-info.stat + count.stat list.data temporary.stat + data-formats.stat list.stat time-date.stat + data-list.data loop.stat vector.stat + data-list.stat modify-vars.stat weighting.data + descript.stat print.stat weighting.stat + do-if.stat process-if.stat + do-repeat.stat recode.stat + + util: + Makefile.am Makefile.in q2c.c reconfigure + + Old configuration: + + ANNOUNCE.html count.c hash.h sample.c + AUTHORS.html crosstabs.q heap.c sel-if.c + AVLLIB.COPYING data-in.c heap.h set.q + BUGS.html data-list.c include.c settings.h + COPYING data-out.c inpt-pgm.c sfm-read.c + ChangeLog debian install-sh sfm-write.c + INSTALL descript.q julcal.c sfm.h + LANGUAGE.html devices julcal.h sfmP.h + Makefile.am dfm.c lexer.c show.c + NEWS dfm.h list.q som-frnt.c + PATCHLEVEL display.c log.c som-high.c + README.html do-if.c log.h som-low.c + THANKS.html do-ifP.h loop.c som.h + TODO environment main.c somP.h + _read.c error.c makeb40.bat sort.c + _write.c error.h makedj2.bat split-file.c + acconfig.h expr-evl.c makefile.b40 stamp-h.in + alloca.c expr-opt.c makefile.dj2 stats.c + approx.h expr-prs.c mdate-sh stats.h + arena.c expr.h memcmp.c stpcpy.c + arena.h exprP.h mis-val.c str.c + ascii.c fiasco.texi misc.c str.h + autorecode.c file-handle.h misc.h sysfile-info.c + avl.c file-handle.q mkinstalldirs temporary.c + avl.h file-type.c modify-vars.c test + cases.c filename.c numeric.c texinfo.tex + cmdline.c filename.h output.c title.c + command.c font.h output.h tokens.h + common.c formats.c papersize val-labs.c + common.h freq.c postscript.c var-labs.c + compute.c frequencies.g prefh.orig var.h + con32s.c frequencies.q print.c vars-atr.c + confh.b40 get.c ps-fontmap vars-prs.c + confh.dj2 getline.c ps-prologue vector.c + confh.in getline.h q2c.c version.c + confh.tmp.in getopt.c qsort.c version.h + config.guess getopt.h recode.c vfm.c + config.sub getopt1.c reconfigure vfmP.h + configh.b40 glob.c reject weight.c + configh.dj2 groff-font.c rename-vars.c + configure.in hash.c repeat.c + + debian: + changelog control postinst rules + conffiles copyright postrm + + test: + autorecode.stat fall92.data recode.stat + begin-data.stat fall92.stat reread.data + bignum.data file-label.stat reread.stat + bignum.stat file-type.stat sample.stat + bug.stat filter.stat sort.stat + compute.stat gengarbage.c split-file.stat + count.stat gengarbage.pl sysfile-info.stat + data-formats.stat input-program.stat temporary.stat + data-list.data list.data time-date.stat + data-list.stat list.stat vector.stat + descript.stat loop.stat weighting.data + do-if.stat modify-vars.stat weighting.stat + do-repeat.stat print.stat + expression.stat process-if.stat + +Mon Mar 24 21:47:31 1997 Ben Pfaff + + * Makefile.am: @ALLOCA@ is on list of source files instead of + alloca.c. Added $(srcdir)/ to version.c reference. Changed to + pkgdatadir (/usr/share) for pkgsysconfdir, from pkglibdir + (/usr/lib). Removed some of extra distfiles. Added bogus `check' + target. + + * Made transition release x1. + +Sun Mar 2 20:51:28 1997 Ben Pfaff + + No longer uses debmake: + + * Makefile.am: Installs documentation according to Debian policy + manual. New targets `private-uninstall', `install-data-hook' to + help implement this. `debian' target also revised. + + * configure.in: Sets up for Debian installation depending on + DEBIAN environment variable. Also, improved & fixed (hopefully) + the scheme for detecting patchlevel. + + * Made patchlevel 193. + +Wed Feb 19 21:30:31 1997 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 192. + +Sun Feb 16 20:57:20 1997 Ben Pfaff + + * Made patchlevel 191. + +Sat Feb 15 21:26:53 1997 Ben Pfaff + + * Makefile.am: Removed `descript.g' from sources. + + * Made patchlevel 190. + +Fri Feb 14 23:32:58 1997 Ben Pfaff + + * TODO: Updated. + + * configure.in: Fixed test for max number of digits in an `int' to + use char[] rather than int[]. + + * Made patchlevel 189. + +Tue Feb 4 15:15:50 1997 Ben Pfaff + + * configure.in: Fixed some problems with `--with-checker' flag and + with detection of available libraries; no longer any lines longer + than 79 characters. + + * Made patchlevel 188. + +Wed Jan 22 21:54:00 1997 Ben Pfaff + + * Makefile.am: Add sysfile-info.c to sources. + + * TODO: Moved some notes to different files where they are more + appropriate. + + * prefh.orig: (macros STORE_2 and LOAD_2) Always load/store as + little-endian. + + * Made patchlevel 187. + +Sun Jan 19 14:22:11 1997 Ben Pfaff + + * Makefile.am: Added rename-vars.c to sources. Added to distclean + files. + + * TODO: Updates. + + * Made patchlevel 186. + +Thu Jan 16 13:08:57 1997 Ben Pfaff + + * Most files have updated copyright notices for 1997. + + * Makefile.am: Added modify-vars.c to source files. Also changed + `lynx' to $(HTML_FORMATTER), etc. Changed messages. + + * TODO: Updates. + + * Made patchlevel 185. + +Sat Jan 11 15:44:15 1997 Ben Pfaff + + * Makefile.am: By default, now installs config files in pkglibdir, + generally /usr/local/lib/fiasco. + + * TODO: Updated. + + * prefh.orig: Added `/etc/fiasco' to config paths. Removed + $ARCH/$VER dirs from include paths. + + * Made patchlevel 184. + +Fri Jan 10 20:22:08 1997 Ben Pfaff + + * debian/changelog, debian/control, debian/copyright, debian/dirs, + debian/info, debian/menu, debian/rules: Added Debian GNU/Linux + control files. + + * Makefile.am: Added sfmP.h to source files. Added several files + to the list of distfiles. dist-hook now copies debian control + files. New targets `debian', `debian-clean', `debian-clean-full'. + + * confh.in: Defines PATCHLEVEL. + + * configure.in: Adds the current patchlevel to the version + number. Versions are now of the form `1.2.3pl456'. Determines + the patchlevel based on directory name and contents of file + PATCHLEVEL. + + * reconfigure: Passes automake `--strictness=foreign'. + + * Made patchlevel 183. + +Thu Jan 2 19:08:23 1997 Ben Pfaff + + * Made patchlevel 182. + +Wed Jan 1 22:08:10 1997 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 181. + +Wed Jan 1 17:00:59 1997 Ben Pfaff + + * Makefile.am: New target for test/sort.data. + + * Made patchlevel 180. + +Sun Dec 29 21:36:48 1996 Ben Pfaff + + * Made patchlevel 179. + +Tue Dec 24 20:42:32 1996 Ben Pfaff + + * Made patchlevel 178. + +Sun Dec 22 23:10:39 1996 Ben Pfaff + + * Makefile.am: Added heap.c, heap.h to source files. Added + new html files to distfiles & maintainer-clean files. + + * configure.in: Tests for presence of getpid(), sys/types.h. + + * prefh.orig: #defines mkdir() for MS-DOS compatibility. + + * Made patchlevel 177. + +Sat Dec 21 21:51:04 1996 Ben Pfaff + + * Makefile.am: Added README.html, LANGUAGE.html to list of + distfiles. Added README, LANGUAGE to list of maintainer-clean + files. Added .html to suffixes. Added .html implicit rule that + calls `lynx -dump -nolist'. + + * Made patchlevel 176. + +Tue Dec 17 18:57:59 1996 Ben Pfaff + + * Made patchlevel 175. + +Sun Dec 15 15:32:16 1996 Ben Pfaff + + * Makefile.am: Added vfmP.c, qsort, sort.c to list of source + files. + + * prefh.orig: Subtle changes to MAX_WORKSPACE, ALWAYS_PAGE, + NEVER_PAGE, DEMAND_PAGE macro meanings. + + * Made patchlevel 174. + +Sat Dec 14 10:35:30 1996 Ben Pfaff + + * Made patchlevel 173. + +Fri Dec 13 21:30:53 1996 Ben Pfaff + + * Makefile.am: Added autorecode.c to source files. + + * prefh.orig: Fixed path GROFF_FONT_PATH. + + * Made patchlevel 172. + +Fri Dec 6 23:53:47 1996 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 171. + +Wed Dec 4 21:34:17 1996 Ben Pfaff + + * Made patchlevel 170. + +Sun Dec 1 17:19:00 1996 Ben Pfaff + + * Made patchlevel 169. + +Thu Nov 28 23:14:07 1996 Ben Pfaff + + * Makefile.am: Added `set.q' to list of source files. + + * Made patchlevel 168. + +Thu Nov 28 19:46:10 1996 Ben Pfaff + + * Made patchlevel 167. + +Wed Nov 27 23:18:35 1996 Ben Pfaff + + * Makefile.am: Added `sfm-write.c' to list of source files. + + * confh.in: New #defines RELEASE_NO, SUB_RELEASE_NO, and + SPEC_RELEASE_NO for each part of a version number of form 1.2.3. + + * configure.in: Computes RELEASE_NO, etc., by breaking apart + VERSION. + + * prefh.orig: (defn of int32, flt64) Formatting fixes. + (FLT64_MAX) New define. + + * Made patchlevel 166. + +Sun Nov 24 14:53:53 1996 Ben Pfaff + + * Wow, it's been almost two weeks since the last update, hard to + believe. + + * All source files: Updated e-mail address. + + * prefh.orig: local_alloc() calls xmalloc() under Checker because + Checker can keep track of heap blocks much more accurately. + + * Made patchlevel 165. + +Mon Nov 11 15:34:09 1996 Ben Pfaff + + * Made patchlevel 164. + +Thu Nov 7 20:52:28 1996 Ben Pfaff + + * Made patchlevel 163. + +Thu Nov 7 17:29:16 1996 Ben Pfaff + + * Made patchlevel 162. + +Thu Nov 7 15:48:52 1996 Ben Pfaff + + * Made patchlevel 161. + +Tue Nov 5 18:34:59 1996 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 160. + +Mon Nov 4 22:03:28 1996 Ben Pfaff + + * Makefile.am: Added get.c. + + * TODO: Updated. + + * Made patchlevel 159. + +Sun Nov 3 12:24:36 1996 Ben Pfaff + + * Makefile.am: Added sfm.h, sfm-read.c to source files. + + * Made patchlevel 158. + +Wed Oct 30 17:13:08 1996 Ben Pfaff + + * Makefile.am: Added dist-zip target to AUTOMAKE_OPTIONS. + + * acconfig.h: Added FPREP_* defines. + + * configure.in: Added checks for the sizes of floating-point + types. Added a test for the internal floating-point + representation of the host architecture. + + * prefh.orig: Renamed `ATTRIBUTION' macro as `__attribute__'. All + references changed. Defines `flt64' 64-bit floating-point for use + with system files. + [FPREP==FPREP_IEEE754 && __GNUC__ && (ENDIAN==BIG || + ENDIAN==LITTLE] Defines SECOND_LOWEST_VALUE macro. + + * Made patchlevel 157. + +Sat Oct 26 23:06:06 1996 Ben Pfaff + + * configure.in: Checks sizes of short, int, long, long long. + + * prefh.orig: Defines new type int32 for use with system + files. + + * Made patchlevel 156. + +Sat Oct 26 20:46:31 1996 Ben Pfaff + + * Made patchlevel 155. + +Sat Oct 26 10:39:25 1996 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 154. + +Thu Oct 24 20:13:42 1996 Ben Pfaff + + * Makefile.am: Added back in these files: recode.c, sample.c, + sel-if.c. Also added files somP.h, hash.c that should've been + there anyway. + + * TODO: Updated. + + * configure.in: Checks for strncasecmp in place of strcasecmp. + + * Made patchlevel 153. + +Thu Oct 24 17:47:14 1996 Ben Pfaff + + * TODO: Updated. + + * Made patchlevel 152. + +Wed Oct 23 21:53:43 1996 Ben Pfaff + + * TODO: Organized. + + * Made patchlevel 151. + +Tue Oct 22 17:27:04 1996 Ben Pfaff + + * TODO: Culled old notes. + + * Made patchlevel 150. + +Mon Oct 21 20:39:59 1996 Ben Pfaff + + * Made patchlevel 149. + +Sun Oct 20 13:45:28 1996 Ben Pfaff + + * Makefile.am: Added back in `numeric.c', `print.c', `title.c'. + Defined ETAGS_ARGS. + + * Made patchlevel 148. + +Sun Oct 20 09:04:15 1996 Ben Pfaff + + * Made patchlevel 147. + +Fri Oct 18 19:46:49 1996 Ben Pfaff + + * Made patchlevel 146. + +Sun Sep 29 19:37:03 1996 Ben Pfaff + + * Made patchlevel 145. + +Sat Sep 28 21:28:07 1996 Ben Pfaff + + * Makefile.am: Added to DISTCLEANFILES. + + * Made patchlevel 144. + +Fri Sep 27 20:08:39 1996 Ben Pfaff + + * Made patchlevel 143. + +Thu Sep 26 22:20:26 1996 Ben Pfaff + + * Makefile.am: Added list.c back into the list of source files. + + * Made patchlevel 142. + +Wed Sep 25 19:36:11 1996 Ben Pfaff + + * Makefile.am: Updated for new files. + + * Made patchlevel 141. + +Tue Sep 24 18:39:09 1996 Ben Pfaff + + * Made patchlevel 140. + +Sat Sep 21 23:16:31 1996 Ben Pfaff + + * Made patchlevel 139. + +Fri Sep 20 22:52:28 1996 Ben Pfaff + + * Made patchlevel 138. + +Thu Sep 12 18:40:33 1996 Ben Pfaff + + * Made patchlevel 137. + +Wed Sep 11 22:01:41 1996 Ben Pfaff + + * TODO: Added timestamp. + + * prefh.orig: Removed `/usr/local/share/fiasco' and + `/usr/share/fiasco' from CONFIG_PATH as per the Linux FSSTND, + which specifies that programs should never give an explicit + `/usr(/local)/share' path. + + * Made patchlevel 136. + +Tue Sep 10 21:39:00 1996 Ben Pfaff + + * Makefile.am: Added `display.c' back in. + + * TODO: Addition. + + * Made patchlevel 135. + +Mon Sep 9 21:43:13 1996 Ben Pfaff + + * Makefile.am: Added `split-file.c' back into the project. + + * Made patchlevel 134. + +Sat Sep 7 22:35:12 1996 Ben Pfaff + + * TODO: Updated. + + * prefh.orig: (local_strdup) Moved to misc.h. + + * Made patchlevel 133. + +Thu Sep 5 22:05:56 1996 Ben Pfaff + + * Makefile.am: Changed `prologue.ps' references to `ps-prologue'. + + * Made patchlevel 132. + +Wed Sep 4 21:45:35 1996 Ben Pfaff + + * prefh.orig: New i18n defines. + + * This patchlevel doesn't even compile. + + * Made patchlevel 131. + +Sat Aug 31 23:52:38 1996 Ben Pfaff + + * TODO: Addition. + + * Made patchlevel 130. + +Thu Aug 29 21:36:41 1996 Ben Pfaff + + * Made patchlevel 129. + +Sat Aug 24 23:26:00 1996 Ben Pfaff + + * Makefile.am: New target "private-install" to install config files + to $HOME/.fiasco. + + * configure.in: Now that I have made a less-bogus Checker + distribution, removed `-b i486-linuxaout -V 2.6.3' from + AC_ARG_WITH(checker, ...). + + * Made patchlevel 127 somewhere in there. + + * Made patchlevel 128. + +Sun Aug 11 21:31:22 1996 Ben Pfaff + + * Makefile.am: Changed DISTCLEANFILES. + + * Does not compile. + + * Made patchlevel 126. + +Sat Aug 10 23:28:17 1996 Ben Pfaff + + * reconfigure: Calls `autoheader' twice: once at the beginning, + once after make maintainer-clean. + + * Made patchlevel 125. + +Thu Aug 8 22:31:11 1996 Ben Pfaff + + * reconfigure: `autoheader' now first operation performed. + + * Made patchlevel 124. + +Sat Aug 3 20:50:35 1996 Ben Pfaff + + * Makefile.am: Added postscript.c to list of source files. + + * configh.in: Removed since autoheader can regenerate it. + + * configure.in: Improved tests for (ncurses or termcap) and + (history and/or readline) libraries and associated headers. Added + check for strcasecmp(). Changed default gcc CFLAGS. + + * prefh.orig: Removed `.' from GROFF_FONT_PATH. + (local_alloc, local_free) New functions. + + * reconfigure: Added call to autoheader. + + * Made patchlevel 123. + +Sat Jul 27 22:32:38 1996 Ben Pfaff + + * There were some problems with the patchfiles so I had to merge + what was previously patchlevels 121 and 122; now everything from + what was previously 122 is called 121. Oh well, just don't let it + happen often. + + * This patchlevel does not compile. + + * configure: No longer included in patches to save lotsa space + when configure.in changes. + + * configure.in: Changed the technique for detecting libraries. + + * prefh.orig: Style changes; handles changed configure.in. + + * Made patchlevel 122 (second edition). + +Tue Jul 23 21:48:36 1996 Ben Pfaff + + * Made patchlevel 121. + +Wed Jul 17 21:23:36 1996 Ben Pfaff + + * Made patchlevel 120. + +Tue Jul 16 22:10:04 1996 Ben Pfaff + + * Made patchlevel 119. + +Sun Jul 14 15:45:31 1996 Ben Pfaff + + * Made patchlevel 118. + +Fri Jul 12 22:03:36 1996 Ben Pfaff + + * Makefile.am: Added list.c to sources. + + * Made patchlevel 117. + +Sat Jul 6 22:22:25 1996 Ben Pfaff + + * configure.in: Removed reference to `malloc.h'. + + * Made patchlevel 116. + +Fri Jul 5 20:16:19 1996 Ben Pfaff + + * Made patchlevel 115. + +Thu Jul 4 20:20:24 1996 Ben Pfaff + + * prefh.orig: Changes to CONFIG_PATH, INCLUDE_PATH, + GROFF_FONT_PATH. + + * Makefile.am: pkgdata_DATA file `output' changed to `devices'. + +Thu Jul 4 00:35:59 1996 Ben Pfaff + + * TODO: doc fix. + + * Made patchlevel 114. + +Tue Jul 2 22:13:23 1996 Ben Pfaff + + * reconfigure: (new file) Runs all the programs necessary to + create a Makefile that includes dependencies. + + * Made patchlevel 113. + +Mon Jul 1 22:13:39 1996 Ben Pfaff + + * Made patchlevel 112. + +Mon Jul 1 13:00:00 1996 Ben Pfaff + + * Most files: Changed references from `stat' (the original, rather + dull old name for this project) to `Fiasco' (the creative, rather + funny new name for this project). + + * Made patchlevel 111. + +Sat Jun 29 17:40:47 1996 Ben Pfaff + + * prefh.orig: changed default file search paths + + * Made patchlevel 110. + +Fri Jun 28 11:59:48 1996 Ben Pfaff + + * Added automake support; removed GNUmakefile and GNUmakefile.in. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/INSTALL b/INSTALL new file mode 100644 index 00000000..3b50ea95 --- /dev/null +++ b/INSTALL @@ -0,0 +1,176 @@ +Basic Installation +================== + + These are generic installation instructions. + + The `configure' shell script attempts to guess correct values for +various system-dependent variables used during compilation. It uses +those values to create a `Makefile' in each directory of the package. +It may also create one or more `.h' files containing system-dependent +definitions. Finally, it creates a shell script `config.status' that +you can run in the future to recreate the current configuration, a file +`config.cache' that saves the results of its tests to speed up +reconfiguring, and a file `config.log' containing compiler output +(useful mainly for debugging `configure'). + + If you need to do unusual things to compile the package, please try +to figure out how `configure' could check whether to do them, and mail +diffs or instructions to the address given in the `README' so they can +be considered for the next release. If at some point `config.cache' +contains results you don't want to keep, you may remove or edit it. + + The file `configure.in' is used to create `configure' by a program +called `autoconf'. You only need `configure.in' if you want to change +it or regenerate `configure' using a newer version of `autoconf'. + +The simplest way to compile this package is: + + 1. `cd' to the directory containing the package's source code and type + `./configure' to configure the package for your system. If you're + using `csh' on an old version of System V, you might need to type + `sh ./configure' instead to prevent `csh' from trying to execute + `configure' itself. + + Running `configure' takes a while. While running, it prints some + messages telling which features it is checking for. + + 2. Type `make' to compile the package. + + 3. Optionally, type `make check' to run any self-tests that come with + the package. + + 4. Type `make install' to install the programs and any data files and + documentation. + + 5. You can remove the program binaries and object files from the + source code directory by typing `make clean'. To also remove the + files that `configure' created (so you can compile the package for + a different kind of computer), type `make distclean'. There is + also a `make maintainer-clean' target, but that is intended mainly + for the package's developers. If you use it, you may have to get + all sorts of other programs in order to regenerate files that came + with the distribution. + +Compilers and Options +===================== + + Some systems require unusual options for compilation or linking that +the `configure' script does not know about. You can give `configure' +initial values for variables by setting them in the environment. Using +a Bourne-compatible shell, you can do that on the command line like +this: + CC=c89 CFLAGS=-O2 LIBS=-lposix ./configure + +Or on systems that have the `env' program, you can do it like this: + env CPPFLAGS=-I/usr/local/include LDFLAGS=-s ./configure + +Compiling For Multiple Architectures +==================================== + + You can compile the package for more than one kind of computer at the +same time, by placing the object files for each architecture in their +own directory. To do this, you must use a version of `make' that +supports the `VPATH' variable, such as GNU `make'. `cd' to the +directory where you want the object files and executables to go and run +the `configure' script. `configure' automatically checks for the +source code in the directory that `configure' is in and in `..'. + + If you have to use a `make' that does not supports the `VPATH' +variable, you have to compile the package for one architecture at a time +in the source code directory. After you have installed the package for +one architecture, use `make distclean' before reconfiguring for another +architecture. + +Installation Names +================== + + By default, `make install' will install the package's files in +`/usr/local/bin', `/usr/local/man', etc. You can specify an +installation prefix other than `/usr/local' by giving `configure' the +option `--prefix=PATH'. + + You can specify separate installation prefixes for +architecture-specific files and architecture-independent files. If you +give `configure' the option `--exec-prefix=PATH', the package will use +PATH as the prefix for installing programs and libraries. +Documentation and other data files will still use the regular prefix. + + If the package supports it, you can cause programs to be installed +with an extra prefix or suffix on their names by giving `configure' the +option `--program-prefix=PREFIX' or `--program-suffix=SUFFIX'. + +Optional Features +================= + + Some packages pay attention to `--enable-FEATURE' options to +`configure', where FEATURE indicates an optional part of the package. +They may also pay attention to `--with-PACKAGE' options, where PACKAGE +is something like `gnu-as' or `x' (for the X Window System). The +`README' should mention any `--enable-' and `--with-' options that the +package recognizes. + + For packages that use the X Window System, `configure' can usually +find the X include and library files automatically, but if it doesn't, +you can use the `configure' options `--x-includes=DIR' and +`--x-libraries=DIR' to specify their locations. + +Specifying the System Type +========================== + + There may be some features `configure' can not figure out +automatically, but needs to determine by the type of host the package +will run on. Usually `configure' can figure that out, but if it prints +a message saying it can not guess the host type, give it the +`--host=TYPE' option. TYPE can either be a short name for the system +type, such as `sun4', or a canonical name with three fields: + CPU-COMPANY-SYSTEM + +See the file `config.sub' for the possible values of each field. If +`config.sub' isn't included in this package, then this package doesn't +need to know the host type. + + If you are building compiler tools for cross-compiling, you can also +use the `--target=TYPE' option to select the type of system they will +produce code for and the `--build=TYPE' option to select the type of +system on which you are compiling the package. + +Sharing Defaults +================ + + If you want to set default values for `configure' scripts to share, +you can create a site shell script called `config.site' that gives +default values for variables like `CC', `cache_file', and `prefix'. +`configure' looks for `PREFIX/share/config.site' if it exists, then +`PREFIX/etc/config.site' if it exists. Or, you can set the +`CONFIG_SITE' environment variable to the location of the site script. +A warning: not all `configure' scripts look for a site script. + +Operation Controls +================== + + `configure' recognizes the following options to control how it +operates. + +`--cache-file=FILE' + Use and save the results of the tests in FILE instead of + `./config.cache'. Set FILE to `/dev/null' to disable caching, for + debugging `configure'. + +`--help' + Print a summary of the options to `configure', and exit. + +`--quiet' +`--silent' +`-q' + Do not print messages saying which checks are being made. + +`--srcdir=DIR' + Look for the package's source code in directory DIR. Usually + `configure' can determine that directory automatically. + +`--version' + Print the version of Autoconf used to generate the `configure' + script, and exit. + +`configure' also accepts some other, not widely useful, options. + diff --git a/Makefile.am b/Makefile.am new file mode 100644 index 00000000..b945ea95 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,29 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +AUTOMAKE_OPTIONS = gnits 1.4 + +SUBDIRS = doc intl po lib src config tests + +pkgdocdir = $(prefix)/doc/@PACKAGE@ +pkgdoc_DATA = NEWS README TODO +noinst_DATA = AUTHORS THANKS + +DISTCLEANFILES = pref.h + +dist-hook: + cp -rp $(top_srcdir)/sysdeps $(distdir) + cp -rp $(top_srcdir)/examples $(distdir) + +# A `private installation' in my terms is just having the appropriate +# configuration files in ~/.pspp instead of a global configuration +# location. So I let those files be installed automatically. + +private-install: + $(MAKE) private-install -C config +private-uninstall: + $(MAKE) private-uninstall -C config + +EXTRA_DIST = NEWS ONEWS TODO pref.h.orig reconfigure configure + +MAINTAINERCLEANFILES = Makefile.in configure aclocal.m4 config.h.in + diff --git a/NEWS b/NEWS new file mode 100644 index 00000000..58d47725 --- /dev/null +++ b/NEWS @@ -0,0 +1,260 @@ +PSPP NEWS -- history of user-visible changes. +Time-stamp: <2000-01-07 20:50:17 blp> +Copyright (C) 1996-9, 2000 Free Software Foundation, Inc. +See the end for copying conditions. + +Please send PSPP bug reports to bug-gnu-pspp@gnu.org. + +Version 0.3.0 changes since 0.2.3: + + Bugs fixed: + + * Using alphanumeric variables in functions under AGGREGATE + segfaulted. Fixed. + + * Under certain circumstances, the final case would be omitted + from the results of an AGGREGATE operation. Fixed. + + * Undefined behavior was invoked by referencing a freed pointer + under certain circumstances. Fixed. + + * A wrong record size was displayed when paging the active file to + disk. Fixed. + + * Not having enough temporary space for sorting caused a core + dump. Fixed. + + * Syntax errors in function descriptions on AGGREGATE caused core + dumps. Fixed. + + * A null pointer was dereferenced, causing a core dump, when + PERCENTILES was specified on FREQUENCIES. This fixes the + problem, but PSPP still doesn't calculate percentiles. + + * SORT always sorted in ascending order. Fixed. + + * Some minor memory leaks in the expression parser were removed. + + * Many assertions fixed for strict ANSI C compliance. + + New features: + + * SET ECHO ON now implemented, but turned off by default. + + * PRINT specifier supported on END REPEAT. + + Other: + + * System libgmp2 library is used if installed instead of + unconditionally using the included libgmp2 subset. + + * Extensive code cleanup, which continues. + + * Added CORRELATIONS command parser, but not implemented. + +Version 0.2.3 changes since 0.2.2: + + Bugs fixed: + + * SPLIT FILE with a string variable caused a core dump. Fixed. + + * Nested INCLUDEs didn't work. Fixed. + + * The MATCH FILES procedure set the values of variables not present + to 0. It should have been SYSMIS. This is now fixed. + + * The REMARK command was too aggressive about skipping lines. It + didn't like being the last command in a file. + + * Comment parsing wasn't consistent with the rest of the code in its + idea of where one command ends and another starts. This meant + that sometimes commands would be mysteriously ignored. Thanks to + Dr. Dirk Melcher for reporting this bug. + + * The TABLE subcommand on MATCH FILES worked only erratically at + best. This fixes it. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * VARIABLE LABELS rejected a slash before the first variable + specification, contradicting the documentation. Thanks to Walter + M. Gray for reporting this bug. + + * Because of an incorrect optimization in memory allocation, + CROSSTABS sometimes segfaulted when asked to output multiple + tables. Thanks to Walter M. Gray for + reporting this bug. + + * CROSSTABS didn't display value labels for column and row + variables. Thanks to Walter M. Gray for + reporting this bug. + + * WRITE didn't write line ends. Fixed. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * The TABLE subcommand on MATCH FILES worked only erratically at + best. This fixes it. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * VARIABLE LABELS rejected a slash before the first variable + specification, contradicting the documentation. Thanks to Walter + M. Gray for reporting this bug. + + * Because of an incorrect optimization in memory allocation, + CROSSTABS sometimes segfaulted when asked to output multiple + tables. Thanks to Walter M. Gray for + reporting this bug. + + * CROSSTABS didn't display value labels for column and row + variables. Thanks to Walter M. Gray for + reporting this bug. + + * WRITE didn't write line ends. Fixed. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * MATCH FILES corrupted memory and dumped core on some syntax + errors. Fixed. + + * MATCH FILES should set numeric values not available to the + system-missing value, not to 0. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * KEEP didn't work properly on the SAVE procedure. Fixed. Thanks + to Ralf Geschke for reporting this bug. + + * Memory leak fix. + + * Some systems didn't like the way open_file was coded. Thanks to + Hankin for pointing this out. + + * The SAVE procedure didn't save long string variables properly. + Fixed by this patch. Thanks to Hankin + for this patch. + + * Minor documentation fixes for MATCH FILES. + +Version 0.2.2 changes since 0.2.1: + + Bugs fixed: + + * Fix behavior of PRINT SPACE for negative arguments. + + * Fix reading some unusual system files. + + * Fix LIST problems with very long variables. Thanks to Hankin + for this bug report. + + * Fix problems with some string format specifiers. + + * Fix use of $CASENUM in expressions. Thanks to Dirk Melcher + for reporting this bug. + + * Additional DATA LIST FREE and DATA LIST LIST fixes. Thanks to + Hankin again on this one. + + * Sometimes you may encounter a PSPP script that has to be + interpreted in interactive mode. Now you can use the -i flag to + do this. + + * Warnings for egcs 1.1.1 cleaned up. (However you'll get lots of + `unused variable' warnings under gcc 2.7.2.3, fixing this will + take more effort.) + + * Tests fixed. + + * The files in gmp need the internationalization directory in + their include path. Thanks to OKUJI Yoshinori + for pointing this out. + +Version 0.2.1 changes since 0.2.0: + + Bugs fixed: + + * Remember to include examples/ directory in distribution :-) + + * Fixed gmp compile problems for some non-i386 architectures. + Thanks to Hans Olav Eggestad and others + for reporting this. + + * DATA LIST FREE and DATA LIST LIST parsing of input files is now + matches the documented behavior exactly, and error messages are + more helpful. Thanks to Mark H. Wood . + +Version 0.2.0 changes since 0.1.0: + + Procedures now implemented: + * CROSSTABS. Please see documentation for caveats. + + Transformations and utilities now implemented: + * AGGREGATE + * APPLY DICTIONARY + * CLEAR TRANSFORMATIONS + * DISPLAY (all subcommands). + * ERASE + * FLIP + * EXPORT + * HOST + * IMPORT + * MATCH FILES + * MATRIX DATA + * NEW FILE + * REPEATING DATA + + Support for input and output through pipes: "|command" and + "command|" filenames; support for special filenames "-", "stdin", + "stdout", "stderr". + + New command-line features: + * New option --testing-mode: Invoke heuristics to assist testing. + * New option --safer, -s: Don't allow certain unsafe operations. + * New option --command=CMD, -c CMD: Perform literal command CMD. + * rc file ~/.pspp/rc is executed before any other files. + * Now multiple syntax files can be specified. + + Operator LAG is now implemented. + + Added missing FILE subcommand to REREAD. + + Table output manager completely rewritten. + + Device configuration file syntax changed. You will need to + reinstall your `devices' file. + + New output driver for HTML. + + PostScript driver and prologue simplified. + + Many bugs fixed. General source-code cleanup. + + Added Texinfo documentation for: + * PSPP system file format + * PSPP portable file format + * How to write input for q2c parser generator + * HTML driver + + PSPP language is now fully documented. Please report any + inaccuracies or omissions in the documentation. + +Changes for version 0.1.0: + + First public release. For changes from unreleased development + versions, please see ONEWS. + +---------------------------------------------------------------------- +Copyright information: + +Copyright (C) 1996-9, 2000 Free Software Foundation, Inc. + + Permission is granted to anyone to make or distribute verbatim + copies of this document as received, in any medium, provided that + the copyright notice and this permission notice are preserved, thus + giving the recipient permission to redistribute in turn. + + Permission is granted to distribute modified versions of this + document, or of portions of it, under the above conditions, + provided also that they carry prominent notices stating who last + changed them. + +Local variables: +version-control: never +mode: indented-text +end: diff --git a/ONEWS b/ONEWS new file mode 100644 index 00000000..ec1ff99c --- /dev/null +++ b/ONEWS @@ -0,0 +1,540 @@ +PSPP NEWS -- history of user-visible changes. +Time-stamp: <1998-08-14 10:45:12 blp> +Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc. +See the end for copying conditions. + +Please send PSPP bug reports to bug-gnu-pspp@gnu.org. + +* Changes for patchlevel 37: + +** Bugfixes. + +* Changes for patchlevel 36: + +** Documentation fixes. + +* Changes for patchlevel 35: + +** DO REPEAT works. + +** Removed PC+ emulation; merged X and Wnd emulations. + +** Many smaller bugfixes. + +* Changes for patchlevel 34: + +** More DO REPEAT work. Does not compile. + +* Changes for patchlevel 33: + +** Excised politically incorrect words. + +* Changes for patchlevel 32: + +** Worked on fixing DO REPEAT problems. + +* Changes for patchlevel 31: + +** Fixed packaging problems. + +* Changes for patchlevel 30: + +** Looks for include files and data file relative to the syntax file +directory, not the current working directory. + +* Changes for patchlevel 29: + +** Add capability for PSPP syntax files to invoked as programs with +`#!' notation. + +* Changes for patchlevels 20, 21, 22, 23, 24, 25, 26, 27, 28: + +** Bugfixes. + +* Changes for version 0.1.0: + +** Debian package support. + +* Changes for patchlevel 19: + +** Bugfixes. + +** Began PSPP FAQ list. + +* Changes for patchlevel 18: + +** Scratch variables are fully implemented. They are deleted after +every procedure. + +** The virtual file manager has been completely rewritten. Although +all known bugs have been fixed, the new object-oriented structure to +vfm is so different that there are likely some that are +as-yet-undiscovered. + +* Changes for patchlevel 14, 15, 16, 17: + +** Bugfixes. + +* Changes for patchlevels 12, 13: + +** Internationalization! + +* Changes for patchlevels 7, 8, 9, 10, 11: + +** Bugfixes. + +* Changes for patchlevel 6: + +** Removed the need for a `ps-fontmap' in the PostScript driver. +This changes the options for the PostScript driver slightly. + +* Changes for new patchlevels 1, 2, 3, 4, 5: + +** Bugfixes. + +* Changes for interim releases x1, x2, x3: + +** Package changed from `flat' to `deep' format. + +* Changes for patchlevel 193: + +** No user-visible changes. + +* Changes for patchlevel 192: + +** Bugfixes. + +* Changes for patchlevel 191: + +** Reimplemented FREQUENCIES method of calculation--it should now be +* acceptable to numerical analysts. + +* Changes for patchlevel 190: + +** Implemented PROCESS IF to be compatible with PC+. + +** Reimplemented DESCRIPTIVES method of calculation--it should now +be acceptable to numerical analysts. + +** DESCRIPTIVES is now correct and complete--please report any bugs +immediately. + +** Implemented SYSFILE INFO, although it is limited in the way it +displays value labels. + +** SAVE now records the number of cases in the system file. + +* Changes for patchlevels 189, 188, 187: + +** Bugfixes. + +* Changes for patchlevel 186: + +** Bazillions of bugfixes, and more to come. This version ought to be +much more usable than any previous. + +** Added RENAME VARIABLES command and tested it. + +* Changes for patchlevel 185: + +** Added MODIFY VARS command; poorly tested. + +** Bugfixes. + +* Changes for patchlevel 184: + +** Debianized and fixed a few packaging problems. + +** First ALPHA release. + +** Miscellaneous bugfixes. + +* Changes for patchlevel 182: + +* Added FILE LABEL, DOCUMENT, and DROP DOCUMENTS commands; not tested. + +* Changes for patchlevel 181: + +* Added FILTER command. + +* Changes for patchlevel 180: + +* SORT CASES bugfixes. + +* Changes for patchlevel 179: + +* SORT CASES implemented. + +* Changes for patchlevels 178, 177, 176, 175: + +* No user-visible changes; might not even compile. + +* Changes for patchlevel 174: + +** AUTORECODE has been newly implemented. + +* Changes for patchlevel 173: + +** Bugfixes. + +* Changes for patchlevel 172: + +** SET has been reintroduced. It is somewhat incomplete. + +** Bugfixes. + +* Changes for patchlevel 171: + +** Several bugfixes. + +** Minor language improvements. + +* Changes for patchlevel 170: + +** Input/output formats DOT, PCT, EDATE, SDATE are now supported but +not tested. + +* Changes for patchlevel 169: + +** Several bugfixes. + +** Implemented custom currency formats (CCA ... CCE); not tested. + +* Changes for patchlevel 168: + +** No user-visible changes. + +* Changes for patchlevel 167: + +** Compression is now available on SAVE and XSAVE. + +* Changes for patchlevel 166: + +** SAVE and XSAVE are implemented. Compression is not yet available. + +* Changes for patchlevel 165: + +** GET is now fully implemented for both compressed and uncompressed +system files. + +* Changes for patchlevel 164: + +** GET now works on system files (uncompressed only). + +* Changes for patchlevels 163, 162, 161, 160, 159, 158: + +** No user-visible changes. + +** Supports keywords LOWEST and HIGHEST on MISSING VALUES. + +* Changes for patchlevel 157: + +** Fixed longtime bug with cross-compilation. + +* Changes for patchlevel 156: + +** Fixed the (known) bugs introduced in patchlevel 155. + +** Fixed a longtime bug in RECODE that might have affected other +transformations as well. + +* Changes for patchlevel 155: + +** A few bugs fixed, probably several introduced. + +* Changes for patchlevel 154: + +** FILE HANDLE now supports most of the SPSS/Wnd compatible features. + +* Changes for patchlevel 153: + +** PRINT now supports OUTFILE. + +** WRITE is now distinct from PRINT. + +** RECODE, SAMPLE, SELECT IF are re-enabled. + +* Changes for patchlevel 152: + +** Bugfixes for times & dates. + +** Misc. bugfixes. + +** System variables supported on expressions. + +* Changes for patchlevel 151: + +** Newly implemented input/output formats: + +Time/date output formats. +Preliminary testing has been done on times & dates. + +* Changes for patchlevel 150: + +** Newly implemented input/output formats + +Zoned decimal input/output format. +Time/date input formats, but not output formats. +All of these are untested. + +* Changes for patchlevel 149: + +** Bugfixes. + +* Changes for patchlevel 148: + +** Many bugfixes. + +** Re-enabled the following transformations: + +LEAVE, NUMERIC, PRINT, PRINT EJECT, PRINT FORMATS, PRINT SPACE, +STRING, TITLE, WRITE. + +* Changes for patchlevel 147: + +** Crushed partial tables are much better. + +* Changes for patchlevel 146: + +** Bugfixes. + +** Crushed tables are working better! + +** Still pretty broken. + +* Changes for patchlevel 145: + +** Bugfixes. + +** Broken stuff. + +* Changes for patchlevels 144, 143: + +** Bugfixes. + +* Changes for patchlevel 142: + +** LIST procedure is back, but not well-implemented. + +* Changes for patchlevel 141: + +** No user-visible changes. + +* Changes for patchlevels 140, 139, 138: + +** Worked on manual. + +** Minor bugfixes. + +* Changes for patchlevel 136: + +** Began revisions to manual. + +** Changed default path for configuration files. + +* Changes for patchlevel 135: + +** PostScript driver bugfixes. + +** Many memory leaks eliminated. + +** Miscellaneous Bugfixes. + +* Changes for patchlevel 134: + +** SPLIT FILE works again. + +** Documentation changes in README. + +** New documentation in LANGUAGE, BUGS. + +* Changes for patchlevel 133: + +** PostScript driver supports encodings. + +It also works now, as opposed to the brokenness of the last +patchlevel. + +* Changes for patchlevel 132: + +** PostScript driver supports font changes! + +Not well tested. + +* Changes for patchlevel 131: + +** Does not compile. + +* Changes for patchlevel 130: + +** Generated PostScript code is smaller in size. + +This is because, as long as the PostScript option `optimize-line-size' +is at least 1, individual contiguous short lines are consolidated into +longer monster lines. + +* Changes for patchlevel 129: + +** PostScript output much improved. + +Mirror no longer necessary. + +* Changes for patchlevel 128: + +** Try out the PostScript driver, if you've got a mirror handy. + +* Changes for patchlevel 126: + +** Does not compile. + +* Changes for patchlevel 125: + +** No user-visible changes. + +* Changes for patchlevel 124: + +** PostScript driver. Don't use it yet. + +** Bugfixes. + +* Changes for patchlevel 123: + +** No user-visible changes. + +* Changes for patchlevel 122: + +** FREQUENCIES procedure is more complete. + +It can now print out sorted frequency tables as well as all statistics +except median. No percentiles. Full syntax. No integer mode. + +* Changes for patchlevel 121: + +** Compiles again! + +** FREQUENCIES procedure works but it is incomplete. + +* Changes for patchlevels 120, 119: + +** Does not compile. + +* Changes for patchlevel 118: + +** Does not compile. + +** Bugfix regarding titles on LIST procedure. + +* Changes for patchlevel 117: + +** LIST procedure implemented. + +** Bugfix regarding unsupported REMARK utility. + +* Changes for patchlevel 116: + +** Does not compile. + +* Changes for patchlevel 115: + +** New output driver initialization interface. + +*** Changed option syntax. + +`-o driver' is the new syntax. The default driver is named `default'. + +*** The initialization file `output' has been renamed `devices'. + +*** Driver names actually specify categories. + +Each driver name specified can actually result in 0, 1, 2, or any +greater number of actual drivers being used, depending solely on the +contents of the `devices' output initialization file. + +*** The driver initialization file is read in a `termcap'-like manner. + +That is, it determines whether to use a driver based on the parameters +passed to it, rather than mainly on the contents of the `devices' file +plus some goofy hacks with command-line options. + +*** Macros defined in the `devices' file can be overridden. + +Do it by specifying a definition on the command line of form +`KEY=VALUE'. See `devices' for details. + +** Short form of option `--verbose' changed to `-V'. + +** New option `-v' or `--verbose'. + +`-v' causes PSPP to display more info about what it's doing. +Multiple `-v's display even more. + +** Support for small 25-line screens. + +The ASCII driver minimum for page length is now 15 lines instead of +29. + +* Changes for patchlevel 114: + +** Rich text now supported in the ascii driver. + +The style changes are done with overstriking or with defined +sequences. + +** New ascii output driver option `carriage-return-style'. + +This can be set to `cr' or to `bs', depending on whether returning to +the left margin should be done with an ASCII CR or with multiple +backspaces. + +* Changes for patchlevel 113: + +** Table titles are more complete. + +Now they include a description of the table contents. + +* Changes for patchlevel 112: + +** Tables now are preceded by a descriptive `title'. + +This line shows what procedure emitted it, etc. + +** Some tables are now divided into multiple columns. + +These columns are displayed across the page in order to save vertical +space. + +* Changes for patchlevel 111: + +** Bugfixes. + +* Changes for patchlevel 110: + +** `stat' has now been renamed `PSPP', for `PSPP Implements Accurate +Statistical COmputations'! Let's all celebrate the clever acronym! + +** Bugfixes. + +* Changes for patchlevel 109: + +** Bugfixes. + +---------------------------------------------------------------------- +Copyright information: + +Copyright (C) 1996, 1997, 1998 Free Software Foundation, Inc. + + Permission is granted to anyone to make or distribute verbatim + copies of this document as received, in any medium, provided that + the copyright notice and this permission notice are preserved, thus + giving the recipient permission to redistribute in turn. + + Permission is granted to distribute modified versions of this + document, or of portions of it, under the above conditions, + provided also that they carry prominent notices stating who last + changed them. + +Local variables: +version-control: never +mode: text +mode: outline-minor +end: diff --git a/README b/README new file mode 100644 index 00000000..51fb8eae --- /dev/null +++ b/README @@ -0,0 +1,18 @@ +PSPP is a program for statistical analysis of sampled data. It +interprets commands in the SPSS language and produces tabular output +in ASCII or PostScript format. + +PSPP development is ongoing. It already supports a large subset of +SPSS's transformation language. Its statistical procedure support is +currently limited, but growing. + +Source code for the latest development release of PSPP is available at +ftp://alpha.gnu.org/gnu/pspp and ftp://pspp.stat.wisc.edu/pub/PSPP. + +For information on differences from previous versions, please see file +NEWS. Full documentation on PSPP's language and information on known +bugs can in the doc/ directory. + +Questions and comments regarding PSPP can be sent to Ben Pfaff +. PSPP bug reports should be sent to +bug-gnu-pspp@gnu.org. diff --git a/THANKS b/THANKS new file mode 100644 index 00000000..914eadf2 --- /dev/null +++ b/THANKS @@ -0,0 +1,12 @@ +Thanks to... + + * David MacKenzie for writing Autoconf, the automatic configuration + tool. + * David MacKenzie and Tom Tromey for writing Automake, the tool for + generating `Makefile's. + * Ulrich Drepper et al for writing gettext, the GNU + internationalization package. + * François Pinard for advice on proceeding with development. + * Jim Van Zandt for Debian packaging and suggestions. + * Torbj"orn Granlund and TMG Datakonsult for GNU gmp2 used in the + portable file routines. diff --git a/TODO b/TODO new file mode 100644 index 00000000..7486135d --- /dev/null +++ b/TODO @@ -0,0 +1,334 @@ +Time-stamp: <1999-12-30 22:58:42 blp> + +TODO +---- + +The way that data-in.c and data-out.c deal with strings is wrong. Instead of +the way it's done now, we should make it dynamically allocate a buffer and +return a pointer to it. This is a much safer interface. + +Add libplot output driver. Suggested by Robert S. Maier +: "it produces output in idraw-editable PS format, PCL5 +format, xfig-editable format, Illustrator format,..., and can draw vector +graphics on X11 displays also". + +Storage of value labels on disk is inefficient. Invent new data structure. + +Add an output flag which would cause a page break if a table segment could fit +vertically on a page but it just happens to be positioned such that it won't. + +Fix spanned joint cells, i.e., EDLEVEL on crosstabs.stat. + +Cell footnotes. + +PostScript driver should emit thin lines, then thick lines, to optimize time +and space. + +New functions? var_name_or_label(), tab_value_or_label() + +Should be able to bottom-justify cells. It'll be expensive, though, by +requiring an extra metrics call. + +Perhaps instead of the current lines we should define the following line types: +null, thin, thick, double. It might look pretty classy. + +Perhaps thick table borders that are cut off by a page break should decay to +thin borders. (i.e., on a thick bordered table that's longer than one page, +but narrow, the bottom border would be thin on the first page, and the top and +bottom borders on middle pages.) + +Support multi-line titles on tables. (For the first page only, presumably.) + +Rewrite the convert_F() function in data-out.c to be nicer code. + +In addition to searching the source directory, we should search the current +directory (for data files). (Yuck!) + +Fix line-too-long problems in PostScript code, instead of covering them up. +setlinecap is *not* a proper solution. + +Need a better way than MAX_WORKSPACE to detect low-memory conditions. + +When malloc() returns 0, page to disk and free() unnecessary data. + +Remove ccase * argument from procfunc argument to procedure(). + +See if process_active_file() has wider applicability. + +Looks like there's a potential problem with value labels--we use free_val_lab +from avl_destroy(), but free_val_lab doesn't decrement the reference count, it +just frees the label. Check into this sometime soon. + +Eliminate private data in struct variable through use of pointers. + +Fix som_columns(). + +There needs to be another layer onto the lexer, which should probably be +entirely rewritten anyway. The lexer needs to read entire *commands* at a +time, not just a *line* at a time. This would vastly simplify the +(yet-to-be-implemented) logging mechanism and other stuff as well. + +Has glob.c been pared down enough? + +Improve interactivity of output by allowing a `commit' function for a page. +This will also allow for infinite-length pages. + +All the tests need to be looked over. Some of the SET calls don't make sense +any more. + +Implement thin single lines, should be pretty easy now. + +SELECT IF should be moved before other transformations whenever possible. It +should only be impossible when one of the variables referred to in SELECT IF is +created or modified by a previous transformation. + +The manual: add text, add index entries, add examples. + +The inline file should be improved: There should be *real* detection of whether +it is used (in dfm.c:cmd_begin_data), not after-the-fact detection. + +Figure out a stylesheet for messages displayed by PSPP: i.e., what quotation +marks around filenames, etc. + +Data input and data output are currently arranged in reciprocal pairs: input is +done directly, with write_record() or whatever; output is done on a callback +event-driven basis. It would definitely be easier if both could be done on a +direct basis, with read_record() and write_record() routines, with a coroutine +implementation (see Knuth). But I'm not sure that coroutines can be +implemented in ANSI C. This will require some thought. Perhaps 0.4.0 can do +this. + +New SET subcommand: OUTPUT. i.e., SET OUTPUT="filename" to send output to that +file; SET OUTPUT="filename"(APPEND) to append to that file; SET OUTPUT=DEFAULT +to reset everything. There might be a better approach, though--think about it. + +HDF export capabilities (http://hdf.ncsa.uiuc.edu). Suggested by Marcus +G. Daniels . + +From Zvi Grauer and : + + 1. design of experiments software, specifically Factorial, response surface + methodology and mixrture design. + + These would be EXTREMELY USEFUL for chemists, engineeris, and anyone + involved in the production of chemicals or formulations. + + 2. Multidimensional Scaling analysis (for market analysis) - + + 3. Preference mapping software for market analysis + + 4. Hierarchical clustering (as well as partition clustering) + + 5. Conjoint analysis + + 6. Categorical data analsys ? + +IDEAS +----- + +In addition to an "infinite journal", we should keep a number of +individual-session journals, pspp.jnl-1 through pspp.jnl-X, renaming and +deleting as needed. All of the journals should have date/time comments. + +Qualifiers for variables giving type--categorical, ordinal, ... + +Analysis Wizard + +Consider consequences of xmalloc(), fail(), hcf() in interactive +use: +a. Can we safely just use setjmp()/longjmp()? +b. Will that leak memory? +i. I don't think so: all procedure-created memory is either +garbage-collected or globally-accessible. +ii. But you never know... esp. w/o Checker. +c. Is this too early to worry? too late? + +Need to implement a shared buffer for funny functions that require relatively +large permanent transient buffers (1024 bytes or so), that is, buffers that are +permanent in the sense that they probably shouldn't be deallocated but are only +used from time to time, buffers that can't be allocated on the stack because +they are of variable and unpredictable but usually relatively small (usually +line buffers). There are too many of these lurking around; can save a sizeable +amount of space at very little overhead and with very little effort by merging +them. + +Clever multiplatform GUI idea (due partly to John Williams): write a GUI in +Java where each statistical procedure dialog box could be downloaded from the +server independently. The statistical procedures would run on (the/a) server +and results would be reported through HTML tables viewed with the user's choice +of web browsers. Help could be implemented through the browser as well. + +Design a plotting API, with scatterplots, line plots, pie charts, barcharts, +Pareto plots, etc., as subclasses of the plot superclass. + +HOWTOs +------ + +1. How to add an operator for use in PSPP expressions: + +a. Add the operator to the enumerated type at the top of expr.h. If the +operator has arguments (i.e., it's not a terminal) then add it *before* +OP_TERMINAL; otherwise, add it *after* OP_TERMINAL. All these begin with OP_. + +b. If the operator's a terminal then you'll want to design a structure to hold +its content. Add the structure to the union any_node. (You can also reuse one +of the prefab structures, of course.) + +c. Now switch to expr-prs.c--the module for expression parsing. Insert the +operator somewhere in the precedence hierarchy. + +(1) If you're adding a operator that is a function (like ACOS, ABS, etc.) then +add the function to functab in `void init_functab(void)'. Order is not +important here. The first element is the function name, like "ACOS". The +second is the operator enumerator you added in expr.h, like OP_ARCOS. The +third element is the C function to parse the PSPP function. The predefined +functions will probably suit your needs, but if not, you can write your own. +The fourth element is an argument to the parsing function; it's only used +currently by generic_str_func(), which handles a rather general syntax for +functions that return strings; see the comment at the beginning of its code for +details. + +(2) If you're adding an actual operator you'll have to put a function in +between two of the operators there already in functions `exprtype +parse_*(any_node **n)'. Each of these stores the tree for its result into *n, +and returns the result type, or EX_ERROR on error. Be sure to delete all the +allocated memory on error before returning. + +d. Add the operator to the table `op_desc ops[OP_SENTINEL+1]' in expr-prs.c, +which has an entry for every operator. These entries *must* be in the same +order as they are in expr.h. The entries have the form `op(A,B,C,D)'. A is +the name of the operator as it should be printed in a postfix output format. +For example, the addition operator is printed as `plus'. B is a bitmapped set +of flags: + +* Set the 001 bit (OP_VAR_ARGS) if the operator takes a variable number of +arguments. If a function can take, say, two args or three args, but no other +numbers of args, this is a poor way to do it--instead implement the operator as +two separate operators, one with two args, the other with three. (The main +effect of this bit is to cause the number of arguments to be output to the +postfix form so that the expression evaluator can know how many args the +operator takes. It also causes the expression optimizer to calculate the +needed stack height differently, without referencing C.) + +* Set the 002 bit (OP_MIN_ARGS) if the operator can take an optional `dotted +argument' that specified the minimum number of non-SYSMIS arguments in order to +have a non-SYSMIS result. For instance, MIN.3(e1,e2,e3,e4,e5) returns a +non-SYSMIS result only if at least 3 out of 5 of the expressions e1 to e5 are +not missing. + +Minargs are passed in the nonterm_node structure in `arg[]''s elements past +`n'--search expr-prs.c for the words `terrible crock' for an example of this. + +Minargs are output to the postfix form. A default value is output if none was +specified by the user. + +You can use minargs for anything you want--they're not limited to actually +describing a minimum number of valid arguments; that's just what they're most +*commonly* used for. + +* Set the 004 bit (OP_FMT_SPEC) if the operator has an argument that is a +format specifier. (This causes the format specifier to be output to the +postfix representation.) + +Format specs are passed in the nonterm_node structure in the same way as +minargs, except that there are three args, in this order: type, width, # of +decimals--search expr-prs.c for the words `is a crock' for an example of this. + +* Set the 010 bit (OP_ABSORB_MISS) if the operator can *ever* have a result of +other than SYSMIS when given one or more arguments of SYSMIS. Operators +lacking this bit and known to have a SYSMIS argument are short-circuited to +SYSMIS by the expression optimizer. + +* If your operator doesn't fit easily into the existing categories, +congratulations, you get to write lots of code to adjust everything to cope +with this new operator. Are you really sure you want to do that? + +C is the effect the operator has on stack height. Set this to `varies' if the +operator has a variable number of arguments. Otherwise this 1, minus the +number of arguments the operator has. (Since terminals have no arguments, they +have a value of +1 for this; other operators have a value of 0 or less.) + +D is the number of items output to the postfix form after the operator proper. +This is 0, plus 1 if the operator has varargs, plus 1 if the operator has +minargs, plus 3 if the operator has a format spec. Note that minargs/varargs +can't coexist with a format spec on the same operator as currently coded. Some +terminals also have a nonzero value for this but don't fit into the above +categories. + +e. Switch to expr-opt.c. Add code to evaluate_tree() to evaluate the +expression when all arguments are known to be constants. Pseudo-random +functions can't be evaluated even if their arguments are constants. If the +function can be optimized even if its arguments aren't all known constants, add +code to optimize_tree() to do it. + +f. Switch to expr-evl.c. Add code to evaluate_expression() to evaluate the +expression. You must be absolutely certain that the code in evaluate_tree(), +optimize_tree(), and evaluate_expression() will always return the same results, +otherwise users will get inconsistent results, a Bad Thing. You must be +certain that even on boundary conditions users will get identical results, for +instance for the values 0, 1, -1, SYSMIS, or, for string functions, the null +string, 1-char strings, and 255-char strings. + +g. Test the code. Write some test syntax files. Examine the output carefully. + +NOTES ON SEARCH ALGORITHMS +-------------------------- + +1. Trees are nicer when you want a sorted table. However, you can always +sort a hash table after you're done adding values. + +2. Brent's variation of Algorithm D is best when the table is fixed: it's +memory-efficient, having small, fixed overhead. It's easier to use +when you know in advance how many entries the table will contain. + +3. Algorithm L is rather slow for a hash algorithm, however it's easy. + +4. Chaining is best in terms of speed; ordered/self-ordering is even +better. + +5. Rehashing is slow. + +6. Might want to decide on an algorithm empirically since there are no +clear mathematical winners in some cases. + +7. gprof? Hey, it works! + +MORE NOTES/IDEAS/BUGS +--------------------- + +The behavior of converting a floating point to an integer when the value of the +float is out of range of the integer type is UNDEFINED! See ANSI 6.2.1.3. + +What should we do for *negative* times in expressions? + +Sometimes very wide (or very tall) columns can occur in tables. What is a good +way to truncate them? It doesn't seem to cause problems for the ascii or +postscript drivers, but it's not good in the general case. Should they be +split somehow? (One way that wide columns can occur is through user request, +for instance through a wide PRINT request--try time-date.stat with a narrow +ascii page or with the postscript driver on letter size paper.) + +NULs in input files break the products we're replacing: although it will input +them properly and display them properly as AHEX format, it truncates them in A +format. Also, string-manipulation functions such as CONCAT truncate their +results after the first NUL. This should simplify the result of PSPP design. +Perhaps those ugly a_string, b_string, ..., can all be eliminated. + +From Moshe Braner : An idea regarding MATCH +FILES, again getting BEYOND the state of SPSS: it always bothered me that if I +have a large data file and I want to match it to a small lookup table, via +MATCH FILES FILE= /TABLE= /BY key, I need to SORT the large file on key, do the +match, then (usually) re-sort back into the order I really want it. There is +no reason to do this, when the lookup table is small. Even a dumb sequential +search through the table, for every case in the big file, is better, in some +cases, than the sort. So here's my idea: first look at the /TABLE file, if it +is "small enough", read it into memory, and create an index (or hash table, +whatever) for it. Then read the /FILE and use the index to match to each case. +OTOH, if the /TABLE is too large, then do it the old way, complaining if either +file is not sorted on key. + +------------------------------------------------------------------------------- +Local Variables: +mode: text +fill-column: 79 +End: diff --git a/acconfig.h b/acconfig.h new file mode 100644 index 00000000..4c06d672 --- /dev/null +++ b/acconfig.h @@ -0,0 +1,84 @@ +/* Special definitions, to process by autoheader. + Copyright (C) 1997-9, 2000 Free Software Foundation. */ + +/* Definitions for byte order, according to significance of bytes, from low + addresses to high addresses. The value is what you get by putting '4' + in the most significant byte, '3' in the second most significant byte, + '2' in the second least significant byte, and '1' in the least + significant byte. These definitions never need to be modified. */ +#define BIG 4321 /* 68k */ +#define LITTLE 1234 /* i[3456]86 */ +#define UNKNOWN 0000 /* Endianness must be determined at runtime. */ + +/* Definitions for floating-point representation. */ +#define FPREP_IEEE754 754 /* The usual IEEE-754 format. */ +#define FPREP_UNKNOWN 666 /* Triggers an error at compile time. */ + +/* We want prototypes for all the GNU extensions. */ +#define _GNU_SOURCE 1 + +/* Name of the distribution. */ +#define PACKAGE "PSPP" + +/* Version of the distribution. */ +#undef VERSION + +/* The concatenation of the strings "GNU ", and PACKAGE. */ +#define GNU_PACKAGE "GNU PSPP" + +/* Define to 1 if ANSI function prototypes are usable. */ +#undef PROTOTYPES + + +@TOP@ + +/* Define if sprintf() returns the number of characters written to + the destination string, excluding the null terminator. */ +#undef HAVE_GOOD_SPRINTF + +/* Define if rand() and company work according to ANSI. */ +#undef HAVE_GOOD_RANDOM + +/* Define endianness of computer here as BIG or LITTLE, if known. + If not known, define as UNKNOWN. */ +#define ENDIAN BIG + +/* Define as floating-point representation of this computer. For + i386, m68k, and other common chips, this is FPREP_IEEE754. */ +#define FPREP FPREP_IEEE754 + +/* Number of digits in longest `long' value, including sign. This is + usually 11, for 32-bit `long's, or 19, for 64-bit `long's. */ +#define INT_DIGITS 19 + +/* Define if you have the history library (-lhistory). */ +#undef HAVE_LIBHISTORY + +/* Define if you have the termcap library (-ltermcap). */ +#undef HAVE_LIBTERMCAP + +/* Stolen from Ulrich Drepper, gettext-0.10, + 1995. */ + +/* Define if your locale.h file contains LC_MESSAGES. */ +#undef HAVE_LC_MESSAGES + +/* Define to 1 if NLS is requested. */ +#undef ENABLE_NLS + +/* Define as 1 if you have catgets and don't want to use GNU gettext. */ +#undef HAVE_CATGETS + +/* Define as 1 if you have gettext and don't want to use GNU gettext. */ +#undef HAVE_GETTEXT + +/* Define as 1 if you have the stpcpy function. */ +#undef HAVE_STPCPY + +@BOTTOM@ + +#include + +/* Local Variables: */ +/* mode:c */ +/* End: */ diff --git a/acinclude.m4 b/acinclude.m4 new file mode 100644 index 00000000..5f811319 --- /dev/null +++ b/acinclude.m4 @@ -0,0 +1,433 @@ +dnl --------------------------------------------------------- ## +dnl The following definitions are from gettext-0.10.27. ## +dnl --------------------------------------------------------- ## + +# Macro to add for using GNU gettext. +# Ulrich Drepper , 1995. + +# serial 2 + +AC_DEFUN(AM_WITH_NLS, + [AC_MSG_CHECKING([whether NLS is requested]) + dnl Default is enabled NLS + AC_ARG_ENABLE(nls, + [ --disable-nls do not use Native Language Support], + USE_NLS=$enableval, USE_NLS=yes) + AC_MSG_RESULT($USE_NLS) + AC_SUBST(USE_NLS) + + USE_INCLUDED_LIBINTL=no + + dnl If we use NLS figure out what method + if test "$USE_NLS" = "yes"; then + AC_DEFINE(ENABLE_NLS) + AC_MSG_CHECKING([whether included gettext is requested]) + AC_ARG_WITH(included-gettext, + [ --with-included-gettext use the GNU gettext library included here], + nls_cv_force_use_gnu_gettext=$withval, + nls_cv_force_use_gnu_gettext=no) + AC_MSG_RESULT($nls_cv_force_use_gnu_gettext) + + nls_cv_use_gnu_gettext="$nls_cv_force_use_gnu_gettext" + if test "$nls_cv_force_use_gnu_gettext" != "yes"; then + dnl User does not insist on using GNU NLS library. Figure out what + dnl to use. If gettext or catgets are available (in this order) we + dnl use this. Else we have to fall back to GNU NLS library. + dnl catgets is only used if permitted by option --with-catgets. + nls_cv_header_intl= + nls_cv_header_libgt= + CATOBJEXT=NONE + + AC_CHECK_HEADER(libintl.h, + [AC_CACHE_CHECK([for gettext in libc], gt_cv_func_gettext_libc, + [AC_TRY_LINK([#include ], [return (int) gettext ("")], + gt_cv_func_gettext_libc=yes, gt_cv_func_gettext_libc=no)]) + + if test "$gt_cv_func_gettext_libc" != "yes"; then + AC_CHECK_LIB(intl, bindtextdomain, + [AC_CACHE_CHECK([for gettext in libintl], + gt_cv_func_gettext_libintl, + [AC_TRY_LINK([], [return (int) gettext ("")], + gt_cv_func_gettext_libintl=yes, + gt_cv_func_gettext_libintl=no)])]) + fi + + if test "$gt_cv_func_gettext_libc" = "yes" \ + || test "$gt_cv_func_gettext_libintl" = "yes"; then + AC_DEFINE(HAVE_GETTEXT) + AM_PATH_PROG_WITH_TEST(MSGFMT, msgfmt, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep 'dv '`"], no)dnl + if test "$MSGFMT" != "no"; then + AC_CHECK_FUNCS(dcgettext) + AC_PATH_PROG(GMSGFMT, gmsgfmt, $MSGFMT) + AM_PATH_PROG_WITH_TEST(XGETTEXT, xgettext, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep '(HELP)'`"], :) + AC_TRY_LINK(, [extern int _nl_msg_cat_cntr; + return _nl_msg_cat_cntr], + [CATOBJEXT=.gmo + DATADIRNAME=share], + [CATOBJEXT=.mo + DATADIRNAME=lib]) + INSTOBJEXT=.mo + fi + fi + ]) + + if test "$CATOBJEXT" = "NONE"; then + AC_MSG_CHECKING([whether catgets can be used]) + AC_ARG_WITH(catgets, + [ --with-catgets use catgets functions if available], + nls_cv_use_catgets=$withval, nls_cv_use_catgets=no) + AC_MSG_RESULT($nls_cv_use_catgets) + + if test "$nls_cv_use_catgets" = "yes"; then + dnl No gettext in C library. Try catgets next. + AC_CHECK_LIB(i, main) + AC_CHECK_FUNC(catgets, + [AC_DEFINE(HAVE_CATGETS) + INTLOBJS="\$(CATOBJS)" + AC_PATH_PROG(GENCAT, gencat, no)dnl + if test "$GENCAT" != "no"; then + AC_PATH_PROG(GMSGFMT, gmsgfmt, no) + if test "$GMSGFMT" = "no"; then + AM_PATH_PROG_WITH_TEST(GMSGFMT, msgfmt, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep 'dv '`"], no) + fi + AM_PATH_PROG_WITH_TEST(XGETTEXT, xgettext, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep '(HELP)'`"], :) + USE_INCLUDED_LIBINTL=yes + CATOBJEXT=.cat + INSTOBJEXT=.cat + DATADIRNAME=lib + INTLDEPS="../intl/libintl.a" + INTLLIBS=$INTLDEPS + LIBS=`echo $LIBS | sed -e 's/-lintl//'` + nls_cv_header_intl=intl/libintl.h + nls_cv_header_libgt=intl/libgettext.h + fi]) + fi + fi + + if test "$CATOBJEXT" = "NONE"; then + dnl Neither gettext nor catgets in included in the C library. + dnl Fall back on GNU gettext library. + nls_cv_use_gnu_gettext=yes + fi + fi + + if test "$nls_cv_use_gnu_gettext" = "yes"; then + dnl Mark actions used to generate GNU NLS library. + INTLOBJS="\$(GETTOBJS)" + AM_PATH_PROG_WITH_TEST(MSGFMT, msgfmt, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep 'dv '`"], msgfmt) + AC_PATH_PROG(GMSGFMT, gmsgfmt, $MSGFMT) + AM_PATH_PROG_WITH_TEST(XGETTEXT, xgettext, + [test -z "`$ac_dir/$ac_word -h 2>&1 | grep '(HELP)'`"], :) + AC_SUBST(MSGFMT) + USE_INCLUDED_LIBINTL=yes + CATOBJEXT=.gmo + INSTOBJEXT=.mo + DATADIRNAME=share + INTLDEPS="../intl/libintl.a" + INTLLIBS=$INTLDEPS + LIBS=`echo $LIBS | sed -e 's/-lintl//'` + nls_cv_header_intl=intl/libintl.h + nls_cv_header_libgt=intl/libgettext.h + fi + + dnl Test whether we really found GNU xgettext. + if test "$XGETTEXT" != ":"; then + dnl If it is no GNU xgettext we define it as : so that the + dnl Makefiles still can work. + if $XGETTEXT --omit-header /dev/null 2> /dev/null; then + : ; + else + AC_MSG_RESULT( + [found xgettext programs is not GNU xgettext; ignore it]) + XGETTEXT=":" + fi + fi + + # We need to process the po/ directory. + POSUB=po + else + DATADIRNAME=share + nls_cv_header_intl=intl/libintl.h + nls_cv_header_libgt=intl/libgettext.h + fi + + # If this is used in GNU gettext we have to set USE_NLS to `yes' + # because some of the sources are only built for this goal. + if test "$PACKAGE" = gettext; then + USE_NLS=yes + USE_INCLUDED_LIBINTL=yes + fi + + dnl These rules are solely for the distribution goal. While doing this + dnl we only have to keep exactly one list of the available catalogs + dnl in configure.in. + for lang in $ALL_LINGUAS; do + GMOFILES="$GMOFILES $lang.gmo" + POFILES="$POFILES $lang.po" + done + + dnl Make all variables we use known to autoconf. + AC_SUBST(USE_INCLUDED_LIBINTL) + AC_SUBST(CATALOGS) + AC_SUBST(CATOBJEXT) + AC_SUBST(DATADIRNAME) + AC_SUBST(GMOFILES) + AC_SUBST(INSTOBJEXT) + AC_SUBST(INTLDEPS) + AC_SUBST(INTLLIBS) + AC_SUBST(INTLOBJS) + AC_SUBST(POFILES) + AC_SUBST(POSUB) + ]) + +AC_DEFUN(AM_GNU_GETTEXT, + [AC_REQUIRE([AC_PROG_MAKE_SET])dnl + AC_REQUIRE([AC_PROG_CC])dnl + AC_REQUIRE([AC_ISC_POSIX])dnl + AC_REQUIRE([AC_HEADER_STDC])dnl + AC_REQUIRE([AC_C_CONST])dnl + AC_REQUIRE([AC_C_INLINE])dnl + AC_REQUIRE([AC_TYPE_OFF_T])dnl + AC_REQUIRE([AC_TYPE_SIZE_T])dnl + AC_REQUIRE([AC_FUNC_ALLOCA])dnl + AC_REQUIRE([AC_FUNC_MMAP])dnl + + AC_CHECK_HEADERS([argz.h limits.h locale.h nl_types.h malloc.h string.h \ +unistd.h values.h]) + AC_CHECK_FUNCS([getcwd munmap putenv setenv setlocale strchr strcasecmp \ +__argz_count __argz_stringify __argz_next]) + + if test "${ac_cv_func_stpcpy+set}" != "set"; then + AC_CHECK_FUNCS(stpcpy) + fi + if test "${ac_cv_func_stpcpy}" = "yes"; then + AC_DEFINE(HAVE_STPCPY) + fi + + AM_LC_MESSAGES + AM_WITH_NLS + + if test "x$CATOBJEXT" != "x"; then + if test "x$ALL_LINGUAS" = "x"; then + LINGUAS= + else + AC_MSG_CHECKING(for catalogs to be installed) + NEW_LINGUAS= + for lang in ${LINGUAS=$ALL_LINGUAS}; do + case "$ALL_LINGUAS" in + *$lang*) NEW_LINGUAS="$NEW_LINGUAS $lang" ;; + esac + done + LINGUAS=$NEW_LINGUAS + AC_MSG_RESULT($LINGUAS) + fi + + dnl Construct list of names of catalog files to be constructed. + if test -n "$LINGUAS"; then + for lang in $LINGUAS; do CATALOGS="$CATALOGS $lang$CATOBJEXT"; done + fi + fi + + dnl Determine which catalog format we have (if any is needed) + dnl For now we know about two different formats: + dnl Linux libc-5 and the normal X/Open format + test -d intl || mkdir intl + if test "$CATOBJEXT" = ".cat"; then + AC_CHECK_HEADER(linux/version.h, msgformat=linux, msgformat=xopen) + + dnl Transform the SED scripts while copying because some dumb SEDs + dnl cannot handle comments. + sed -e '/^#/d' $srcdir/intl/$msgformat-msg.sed > intl/po2msg.sed + fi + dnl po2tbl.sed is always needed. + sed -e '/^#.*[^\\]$/d' -e '/^#$/d' \ + $srcdir/intl/po2tbl.sed.in > intl/po2tbl.sed + + dnl In the intl/Makefile.in we have a special dependency which makes + dnl only sense for gettext. We comment this out for non-gettext + dnl packages. + if test "$PACKAGE" = "gettext"; then + GT_NO="#NO#" + GT_YES= + else + GT_NO= + GT_YES="#YES#" + fi + AC_SUBST(GT_NO) + AC_SUBST(GT_YES) + + dnl If the AC_CONFIG_AUX_DIR macro for autoconf is used we possibly + dnl find the mkinstalldirs script in another subdir but ($top_srcdir). + dnl Try to locate is. + MKINSTALLDIRS= + if test $ac_aux_dir; then + MKINSTALLDIRS="$ac_aux_dir/mkinstalldirs" + fi + if test -z $MKINSTALLDIRS; then + MKINSTALLDIRS="\$(top_srcdir)/mkinstalldirs" + fi + AC_SUBST(MKINSTALLDIRS) + + dnl Configure the intl/Makefile for shared libs. + if test "${enable_shared+set}" = set; then + l=l + else + l= + fi + AC_SUBST(l) + + dnl Generate list of files to be processed by xgettext which will + dnl be included in po/Makefile. + test -d po || mkdir po + if test "x$srcdir" != "x."; then + if test "x`echo $srcdir | sed 's@/.*@@'`" = "x"; then + posrcprefix="$srcdir/" + else + posrcprefix="../$srcdir/" + fi + else + posrcprefix="../" + fi + sed -e "/^#/d" -e "/^\$/d" -e "s,.*, $posrcprefix& \\\\," -e "\$s/\(.*\) \\\\/\1/" \ + < $srcdir/po/POTFILES.in > po/POTFILES + ]) + +# Search path for a program which passes the given test. +# Ulrich Drepper , 1996. + +# serial 1 + +dnl AM_PATH_PROG_WITH_TEST(VARIABLE, PROG-TO-CHECK-FOR, +dnl TEST-PERFORMED-ON-FOUND_PROGRAM [, VALUE-IF-NOT-FOUND [, PATH]]) +AC_DEFUN(AM_PATH_PROG_WITH_TEST, +[# Extract the first word of "$2", so it can be a program name with args. +set dummy $2; ac_word=[$]2 +AC_MSG_CHECKING([for $ac_word]) +AC_CACHE_VAL(ac_cv_path_$1, +[case "[$]$1" in + /*) + ac_cv_path_$1="[$]$1" # Let the user override the test with a path. + ;; + *) + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in ifelse([$5], , $PATH, [$5]); do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + if [$3]; then + ac_cv_path_$1="$ac_dir/$ac_word" + break + fi + fi + done + IFS="$ac_save_ifs" +dnl If no 4th arg is given, leave the cache variable unset, +dnl so AC_PATH_PROGS will keep looking. +ifelse([$4], , , [ test -z "[$]ac_cv_path_$1" && ac_cv_path_$1="$4" +])dnl + ;; +esac])dnl +$1="$ac_cv_path_$1" +if test -n "[$]$1"; then + AC_MSG_RESULT([$]$1) +else + AC_MSG_RESULT(no) +fi +AC_SUBST($1)dnl +]) + +# Check whether LC_MESSAGES is available in . +# Ulrich Drepper , 1995. + +# serial 1 + +AC_DEFUN(AM_LC_MESSAGES, + [if test $ac_cv_header_locale_h = yes; then + AC_CACHE_CHECK([for LC_MESSAGES], am_cv_val_LC_MESSAGES, + [AC_TRY_LINK([#include ], [return LC_MESSAGES], + am_cv_val_LC_MESSAGES=yes, am_cv_val_LC_MESSAGES=no)]) + if test $am_cv_val_LC_MESSAGES = yes; then + AC_DEFINE(HAVE_LC_MESSAGES) + fi + fi]) + +dnl Check longest integer in digits. + +AC_DEFUN([BLP_INT_DIGITS], +[ +AC_MSG_CHECKING(number of digits in LONG_MIN (incl. sign)) +AC_CACHE_VAL(blp_int_digits, + [AC_TRY_RUN([#include + #include + int + main() + { + int len; + char s[80]; + sprintf(s, "%ld", LONG_MAX); + len = strlen(s); + sprintf(s, "%ld", LONG_MIN); + if(strlen(s)>len) len=strlen(s); + sprintf(s, "%lu", ULONG_MAX); + if(strlen(s)>len) len=strlen(s); + exit(len); + } + ], + eval "blp_int_digits=19", + eval "blp_int_digits=$?" + if test "$blp_int_digits" -lt 11; then + blp_int_digits=11 + fi, + eval "blp_int_digits=19") + ]) +AC_DEFINE_UNQUOTED(INT_DIGITS, $blp_int_digits) +AC_MSG_RESULT($blp_int_digits) +])dnl + +dnl Check quality of this machine's sprintf implementation. + +AC_DEFUN([BLP_IS_SPRINTF_GOOD], +[ +AC_MSG_CHECKING(if sprintf returns a char count) +AC_CACHE_VAL(blp_is_sprintf_good, + [AC_TRY_RUN([#include + int + main() + { + char s[8]; + exit((int)sprintf(s, "abcdefg")!=7); + } + ], + eval "blp_is_sprintf_good=yes", + eval "blp_is_sprintf_good=no", + eval "blp_is_sprintf_good=no") + ]) +if test "$blp_is_sprintf_good" = yes; then + AC_DEFINE(HAVE_GOOD_SPRINTF) + AC_MSG_RESULT(yes) +else + AC_MSG_RESULT(no) +fi +])dnl + +dnl Check for proper random number generator. + +AC_DEFUN([BLP_RANDOM], +[ +AC_MSG_CHECKING(random number generator) +AC_CACHE_VAL(blp_random_good, + AC_TRY_COMPILE([#include ], [int x=RAND_MAX;], + blp_random_good=yes, blp_random_good=no)) +if test "$blp_random_good" = yes; then + AC_DEFINE(HAVE_GOOD_RANDOM) + AC_MSG_RESULT(good) +else + AC_MSG_RESULT(bad) +fi +])dnl + +dnl aclocal.m4 ends here diff --git a/config/ChangeLog b/config/ChangeLog new file mode 100644 index 00000000..12f1ea87 --- /dev/null +++ b/config/ChangeLog @@ -0,0 +1,158 @@ +Sun May 24 22:40:13 1998 Ben Pfaff + + * ps-prologue: Add %%DocumentMedia: comment. + +Wed May 20 00:02:51 1998 Ben Pfaff + + * ps-prologue: Comment out misleading Bounding-Box comment for + now. SF arguments rearranged. BP removed. + +Wed Apr 15 13:00:46 1998 Ben Pfaff + + * Makefile.am: (private-install) Make it work for separate source + and build directories. + + * ps-prologue: New TL macro for a thick line. New thick-width arg + to BP. + +Sun Jan 4 18:11:11 1998 Ben Pfaff + + * ps-prologue: Minor reorganization. New GB macro to draw a gray + box. + +Wed Dec 24 22:35:13 1997 Ben Pfaff + + * devices: Added devicetype options and documentation for them. + +Fri Dec 5 21:51:08 1997 Ben Pfaff + + * Makefile.am: (pkgsysconf_DATA) Add html-prologue. + (EXTRA_DIST) Add html-prologue. + + * devices: Add `html' device. Add `listing', `screen', and + `printer' flags to devices as appropriate. + + * html-prologue: New file. + + * ps-prologue: Comment fixes. + +Thu Sep 18 21:31:02 1997 Ben Pfaff + + * Makefile.am: (pkgsysconfdir) Changed from $(pkgdatadir) to + $(sysconfdir)/$(PACKAGE). + +Thu Aug 14 22:05:54 1997 Ben Pfaff + + * devices: (tty) Define as null instead of not defining. + +Sun Aug 3 11:33:28 1997 Ben Pfaff + + * devices: tty-ascii has no bold or italic by default. + +Wed Jun 25 22:50:19 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) New target. + +Mon May 5 21:56:54 1997 Ben Pfaff + + * devices, papersize, ps-prologue: Comment fixes. + +Fri May 2 22:05:44 1997 Ben Pfaff + + * Makefile.am: Removed ps-fontmap. + + * ps-fontmap: Removed. + + * ps-prologue: Added comments. Fixed DSC comments. + (BP) Two new arguments; fixed problem with SF argument conflict + with SF function. + +Thu May 1 14:57:52 1997 Ben Pfaff + + * ps-prologue: (BP) New argument, SF or scale factor. + +Fri Apr 18 16:48:41 1997 Ben Pfaff + + * Makefile.am: New file. + + * environment: Comment fix. + +Sat Feb 15 21:26:53 1997 Ben Pfaff + + * devices: Added ml520 and ml520-ul printer devices. + +Sat Jan 11 15:44:15 1997 Ben Pfaff + + * devices: Default listing device is list-ascii, not list-ibmpc. + +Sun Dec 29 21:36:48 1996 Ben Pfaff + + * devices: Changed default devices. + +Sat Sep 7 22:35:12 1996 Ben Pfaff + + * ps-prologue: Added `!encodings' line to cause encodings to be + output. + (T) Fixed. Yes, really this time. + +Thu Sep 5 22:05:56 1996 Ben Pfaff + + * ps-prologue: (T) Now works correctly. + (SF) Parameters changed to: size in psus, target font name, + encoding, PostScript font name. + +Wed Sep 4 21:45:35 1996 Ben Pfaff + + * prologue.ps: Renamed ps-prologue, all references changed. + (T) New definition. + + * ps-encodings: New PostScript configuration file (not present in + distribution). + +Sat Aug 31 23:52:38 1996 Ben Pfaff + + * prologue.ps: One minor comment change. + +Thu Aug 29 21:36:41 1996 Ben Pfaff + + * prologue.ps: Portions other than DSC comments are essentially + completely new. + +Sat Aug 24 23:26:00 1996 Ben Pfaff + + * devices: Added PostScript driver. + +Sun Aug 11 21:31:22 1996 Ben Pfaff + + * prologue.ps: Calls `setlinecap' in setup code. + +Sat Aug 10 23:28:17 1996 Ben Pfaff + + * prologue.ps: DSC comment changes. New call to `setlinewidth' in + setup code. + +Thu Aug 8 22:31:11 1996 Ben Pfaff + + * prologue.ps: Changes to scaling & translating code. + +Sat Aug 3 20:50:35 1996 Ben Pfaff + + * environment: New file. Yet another new time- and memory-hogging + redundant config file; why not? + + * papersize: Comment changes. + + * prologue.ps: Changed vars from $varname$ to ${varname} format. + Miscellaneous changes. + + * ps-fontmap: Comment changes. Fixed ZC family. + +Sat Jul 27 22:32:38 1996 Ben Pfaff + + * ps-fontmap: New configuration file. Added to Makefile.am. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/config/Makefile.am b/config/Makefile.am new file mode 100644 index 00000000..9924e256 --- /dev/null +++ b/config/Makefile.am @@ -0,0 +1,18 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +pkgsysconfdir = $(sysconfdir)/$(PACKAGE) +pkgsysconf_DATA = devices html-prologue papersize ps-prologue +EXTRA_DIST = devices html-prologue papersize ps-prologue + +# A `private installation' in my terms is just having the appropriate +# configuration files in ~/.pspp instead of a global configuration +# location. So I let those files be installed automatically. + +private-install: + $(mkinstalldirs) $$HOME/.pspp + cd $(srcdir); cp $(pkgsysconf_DATA) $$HOME/.pspp +private-uninstall: + -cd $$HOME/.pspp; rm -f $(pkgsysconf_DATA) + -rmdir $$HOME/.pspp + +MAINTAINERCLEANFILES = Makefile.in diff --git a/config/devices b/config/devices new file mode 100644 index 00000000..c1aa6c00 --- /dev/null +++ b/config/devices @@ -0,0 +1,165 @@ +# PSPP's standard output drivers. +# +# An introduction to the use of PSPP output drivers and this file +# follows. However, refer to PSPP's Texinfo documentation for full +# information. +# +# Each output driver specification must be on a single line; however, +# lines may be spliced with a \ at the end of a line. Line splicing +# is performed *before* comments (introduced by `#') are removed. +# +# Format is `DRIVERNAME:CLASSNAME:DEVICETYPE:OPTIONS'. +# +# DRIVERNAME is the name that identifies the driver to the user. It +# is the name used on the -o command-line option. +# +# CLASSNAME is the internal name of the type of driver. Device +# classes can be listed with `pspp -l'. +# +# DEVICETYPE identifies what type or types the devices is. Zero or +# more of the following keywords may be given here: screen, printer, +# or listing. +# +# OPTIONS is a list of key/value pairs to pass to the driver. Use +# spaces to separate pairs, and '=' to separate keys and values. +# Quotes " or ' can be used to delimit values that contain spaces. +# Example: paper-size="Envelope #10" charset=latin1 +# +# Driver categories may be defined with lines of the form: +# +# category=driver1 driver2 driver3 ... driverN +# +# To disable a driver, define a category with nothing on the right +# side. +# +# Macros may be defined with lines of the form: +# +# define macro-name definition +# +# Macros may not be recursive; they may not take arguments. (However, +# `definition' is macro-expanded *at time of definition*.) Macros are +# referenced with $var or ${var} syntax; the latter is preferred. +# Macro definitions on the PSPP command-line take precedence without +# warning. + +# Preferred devices. +default=tty list +tty=#tty-ibmpc +list=list-ascii + +# Output files. +define tty-output-file "/dev/tty" +define list-output-file "pspp.list" + +define no-attributes bold-on="" italic-on="" bold-italic-on="" + +# Generic ASCII devices +tty-ascii:ascii:screen:char-set=ascii output-file=${tty-output-file} \ + ${no-attributes} +list-ascii:ascii:listing:length=66 width=79 char-set=ascii \ + output-file=${list-output-file} ${no-attributes} + +# ASCII devices that support bold & underline via backspacing. +tty-ascii-bi:ascii:screen:char-set=ascii output-file=${tty-output-file} +list-ascii-bi:ascii:listing:length=66 width=79 char-set=ascii \ + output-file=${list-output-file} + +# HTML device. +html:html:: + +# Devices that support the IBM PC line-drawing characters. +define ibmpc-graphics \ + box[0000]='\x20' box[0001]='\xb3' box[0002]='\xba' box[0003]='\xba' \ + box[0010]='\xc4' box[0011]='\xd9' box[0012]='\xbd' box[0013]='\xbd' \ + box[0020]='\xcd' box[0021]='\xbe' box[0022]='\xbc' box[0023]='\xbc' \ + box[0030]='\xf0' box[0031]='\xbe' box[0032]='\xbc' box[0033]='\xbc' \ + box[0100]='\xb3' box[0101]='\xb3' box[0102]='\xc4' box[0103]='\xf0' \ + box[0110]='\xbf' box[0111]='\xb4' box[0112]='\xb6' box[0113]='\xb6' \ + box[0120]='\xb8' box[0121]='\xb5' box[0122]='\xb9' box[0123]='\xb9' \ + box[0130]='\xb8' box[0131]='\xb5' box[0132]='\xb9' box[0133]='\xb9' \ + box[0200]='\xba' box[0201]='\xba' box[0202]='\xba' box[0203]='\xba' \ + box[0210]='\xb7' box[0211]='\xb6' box[0212]='\xb6' box[0213]='\xb6' \ + box[0220]='\xbb' box[0221]='\xb9' box[0222]='\xb9' box[0223]='\xb9' \ + box[0300]='\xb3' box[0301]='\xba' box[0302]='\xba' box[0303]='\xba' \ + box[0310]='\xb7' box[0311]='\xb6' box[0312]='\xb6' box[0313]='\xb6' \ + box[0320]='\xbb' box[0321]='\xb9' box[0322]='\xb9' box[0323]='\xb9' \ + box[0330]='\xbb' box[0331]='\xb9' box[0332]='\xb9' box[0333]='\xb9' \ + box[1000]='\xc4' box[1001]='\xc0' box[1002]='\xd3' box[1003]='\xd3' \ + box[1010]='\xc4' box[1011]='\xc1' box[1012]='\xd0' box[1013]='\xd0' \ + box[1020]='\xcd' box[1021]='\xcf' box[1022]='\xca' box[1023]='\xca' \ + box[1030]='\xf0' box[1031]='\xcf' box[1032]='\xca' box[1033]='\xca' \ + box[1100]='\xda' box[1101]='\xc3' box[1102]='\xc7' box[1103]='\xc7' \ + box[1110]='\xc2' box[1111]='\xc5' box[1112]='\xd7' box[1113]='\xd7' \ + box[1120]='\xd1' box[1121]='\xd8' box[1122]='\xce' box[1123]='\xce' \ + box[1130]='\xd1' box[1131]='\xd8' box[1132]='\xce' box[1133]='\xce' \ + box[1200]='\xd6' box[1201]='\xc7' box[1202]='\xc7' box[1203]='\xc7' \ + box[1210]='\xd2' box[1211]='\xd7' box[1212]='\xd7' box[1213]='\xd7' \ + box[1220]='\xca' box[1221]='\xce' box[1222]='\xce' box[1223]='\xce' \ + box[1230]='\xca' box[1231]='\xce' box[1232]='\xce' box[1233]='\xce' \ + box[1300]='\xd6' box[1301]='\xc7' box[1302]='\xc7' box[1303]='\xc7' \ + box[1310]='\xd2' box[1311]='\xd7' box[1312]='\xd7' box[1313]='\xd7' \ + box[1320]='\xca' box[1321]='\xce' box[1322]='\xce' box[1323]='\xce' \ + box[1330]='\xca' box[1331]='\xce' box[1332]='\xce' box[1333]='\xce' \ + box[2000]='\xcd' box[2001]='\xd4' box[2002]='\xc8' box[2003]='\xc8' \ + box[2010]='\xcd' box[2011]='\xcf' box[2012]='\xca' box[2013]='\xca' \ + box[2020]='\xcd' box[2021]='\xcf' box[2022]='\xca' box[2023]='\xca' \ + box[2030]='\xf0' box[2031]='\xcf' box[2032]='\xca' box[2033]='\xca' \ + box[2100]='\xd5' box[2101]='\xc6' box[2102]='\xcc' box[2103]='\xcc' \ + box[2110]='\xd1' box[2111]='\xd8' box[2112]='\xce' box[2113]='\xce' \ + box[2120]='\xd1' box[2121]='\xd8' box[2122]='\xce' box[2123]='\xce' \ + box[2130]='\xd1' box[2131]='\xd8' box[2132]='\xce' box[2133]='\xce' \ + box[2200]='\xc9' box[2201]='\xcc' box[2202]='\xcc' box[2203]='\xcc' \ + box[2210]='\xcb' box[2211]='\xce' box[2212]='\xce' box[2213]='\xce' \ + box[2220]='\xcb' box[2221]='\xce' box[2222]='\xce' box[2223]='\xce' \ + box[2230]='\xcb' box[2231]='\xce' box[2232]='\xce' box[2233]='\xce' \ + box[2300]='\xc9' box[2301]='\xcc' box[2302]='\xcc' box[2303]='\xce' \ + box[2310]='\xcb' box[2311]='\xce' box[2312]='\xce' box[2313]='\xce' \ + box[2320]='\xcb' box[2321]='\xce' box[2322]='\xce' box[2323]='\xce' \ + box[2330]='\xcb' box[2331]='\xce' box[2332]='\xce' box[2333]='\xce' \ + box[3000]='\xcd' box[3001]='\xd4' box[3002]='\xc8' box[3003]='\xc8' \ + box[3010]='\xcd' box[3011]='\xcf' box[3012]='\xca' box[3013]='\xca' \ + box[3020]='\xcd' box[3021]='\xcf' box[3022]='\xca' box[3023]='\xca' \ + box[3030]='\xcd' box[3031]='\xcf' box[3032]='\xca' box[3033]='\xca' \ + box[3100]='\xd5' box[3101]='\xc6' box[3102]='\xcc' box[3103]='\xcc' \ + box[3110]='\xd1' box[3111]='\xd8' box[3112]='\xce' box[3113]='\xce' \ + box[3120]='\xd1' box[3121]='\xd8' box[3122]='\xce' box[3123]='\xce' \ + box[3130]='\xd1' box[3131]='\xd8' box[3132]='\xce' box[3133]='\xce' \ + box[3200]='\xc9' box[3201]='\xcc' box[3202]='\xcc' box[3203]='\xcc' \ + box[3210]='\xcb' box[3211]='\xce' box[3212]='\xce' box[3213]='\xce' \ + box[3220]='\xcb' box[3221]='\xce' box[3222]='\xce' box[3223]='\xce' \ + box[3230]='\xcb' box[3231]='\xce' box[3232]='\xce' box[3233]='\xce' \ + box[3300]='\xc9' box[3301]='\xcc' box[3302]='\xcc' box[3303]='\xce' \ + box[3310]='\xcb' box[3311]='\xce' box[3312]='\xce' box[3313]='\xce' \ + box[3320]='\xcb' box[3321]='\xce' box[3322]='\xce' box[3323]='\xce' \ + box[3330]='\xcb' box[3331]='\xce' box[3332]='\xce' box[3333]='\xce' + +tty-ibmpc:ascii:screen:length=$viewlength width=$viewwidth ${ibmpc-graphics} \ + output-file=${tty-output-file} +list-ibmpc:ascii:listing:length=66 width=79 output-file=${list-output-file} \ + ${ibmpc-graphics} + +# PostScript device. Tested with HP LaserJet 6MP. +list-ps:postscript:: + +# Okidata Microline 520 (these use the Microline emulation mode). +define ml520-common output-file=${list-output-file} ${ibmpc-graphics} \ + bold-on='\x1b\x54' bold-off='\x1b\x49' init='\x1b\x7b\x21\x1b\x23\x30' +define ml520-italic italic-on='\x1b\x21\x2f' italic-off='\x1b\x21\x2a' \ + bold-italic-on='\x1b\x21\x2f\x1b\x54' bold-italic-off='\x1b\x21\x2a\x1b\x49' +define ml520-ul italic-on='\x1b\x43' italic-off='\x1b\x44' \ + bold-italic-on='\x1b\x43\x1b\x54' bold-italic-off='\x1b\x44\x1b\x49' +ml520=ml520-10cpi +ml520-10cpi:ascii:printer:length=66 width=79 ${ml520-common} ${ml520-italic} +ml520-10cpi-ul:ascii:printer:length=66 width=79 ${ml520-common} ${ml520-ul} +ml520-17cpi:ascii:printer:length=66 width=144 ${ml520-common} ${ml520-italic} \ + cpi=17 init='\x1b\x7b\x21\x1b\x23\x30\x1d' +ml520-17cpi-ul:ascii:printer:length=66 width=144 ${ml520-common} ${ml520-ul} \ + cpi=17 init='\x1b\x7b\x21\x1b\x23\x30\x1d' +ml520-20cpi:ascii:printer:length=66 width=160 ${ml520-common} ${ml520-italic} \ + cpi=17 init='\x1b\x7b\x21\x1b\x23\x30\x1b\x23\x33' +ml520-20cpi-ul:ascii:printer:length=66 width=160 ${ml520-common} ${ml520-ul} \ + cpi=17 init='\x1b\x7b\x21\x1b\x23\x30\x1b\x23\x33' + +# Local Variables: +# fill-prefix: "# " +# End: diff --git a/config/html-prologue b/config/html-prologue new file mode 100644 index 00000000..fa0b57df --- /dev/null +++ b/config/html-prologue @@ -0,0 +1,23 @@ +!!! +!!! This prologue is hereby placed in the public domain. +!!! +!!! PSPP does not place any restrictions on the distribution terms +!!! of its output. You are encouraged to allow your PSPP outputs to +!!! be freely distributed. +!!! + + + + +${title} !title + + + + +

${title}

!title +

${subtitle}

!subtitle +!!! Local Variables: +!!! fill-prefix: "!!! " +!!! End: diff --git a/config/papersize b/config/papersize new file mode 100644 index 00000000..f3866ed9 --- /dev/null +++ b/config/papersize @@ -0,0 +1,60 @@ +# List of standard paper sizes for use with PSPP output drivers. +# +# Valid units include "in"=inches, "cm"=centimeters, "mm"=millimeters. +# Default units are "in" for dimensions less than 50, "mm" otherwise. +# This automagically determines units for all the standard sizes. +# +# Fractional values are allowed: (1) as decimals, or (2) in the form +# "a-b/c", which has the value of a, plus b divided by c. +# +# Also allowed are synonyms: `"B4/JIS"="B4/ISO"'. The left hand size +# is replaced by the right hand size. + +# U.S. +"Letter" 8-1/2 x 11 +"Legal" 8-1/2 x 14 +"Letter Extra" 9-1/2 x 12 +"Legal Extra" 9-1/2 x 15 +"Executive" 7-1/4 x 10-1/2 +"Ledger" 17 x 11 +"Tabloid" 11 x 17 +"Tabloid Extra" 11.69 x 18 +"US Standard Fanfold"="U.S. Standard Fanfold" +"U.S. Standard Fanfold" 14-7/8 x 11 +"Standard Fanfold" 8-1/2 x 12 +"Legal Fanfold" 8-1/2 x 12 + +# Envelopes. +"DL" 8-2/3 x 4-1/3 +"Monarch" 3-7/8 x 7-1/2 +"6 3/4 Envelope"="6-3/4 Envelope" +"6-3/4 Envelope" 3-5/8 x 6-1/2 +"#9" 3-7/8 x 8-7/8 +"#10" 4-1/8 x 9-1/2 +"#11" 4-1/2 x 10-3/8 +"#12" 4-3/4 x 11 +"#14" 5 x 11-1/2 + +# Metric. +"B4"="B4/ISO" +"B5"="B5/ISO" +"A3" 297 x 420 +"A4" 210 x 297 +"B4/ISO" 250 x 353 +"B4/JIS" 257 x 364 +"B5/ISO" 176 x 250 +"B5/JIS" 182 x 257 +"B6" 176 x 125 +"C3" 324 x 458 +"C4" 229 x 324 +"C5" 162 x 229 +"C6" 114 x 162 +"C65" 114 x 229 +"Envelope" 110 x 230 + +# Demonstration of units. +#"Bizarre" 55mm x 10in + +# Local Variables: +# fill-prefix: "# " +# End: diff --git a/config/ps-prologue b/config/ps-prologue new file mode 100644 index 00000000..3c75230c --- /dev/null +++ b/config/ps-prologue @@ -0,0 +1,75 @@ +!!! +!!! This prologue is hereby placed in the public domain. +!!! +!!! PSPP does not place any restrictions on the distribution terms +!!! of its output. You are encouraged to allow your PSPP outputs to +!!! be freely distributed. +!!! +%!PS-Adobe-3.0 EPSF-3.0 !eps +%!PS-Adobe-3.0 !ps +%%Pages: (atend) +%%DocumentNeededResources: (atend) +%%DocumentSuppliedResources: procset PSPP-Prologue 1.0 0 +!!! %%Bounding-Box: ${bounding-box} +%%Copyright: This prologue is public domain. +%%Creator: ${creator} +%%CreationDate: ${date} +%%DocumentData: ${data} +%%DocumentMedia: Plain ${paper-width} ${paper-length} 75 white () +%%Orientation: ${orientation} +%%For: ${user}@${host} +%%Title: ${title} +%FscoSourceFile: ${source-file} +%%EndComments +%%BeginDefaults +%%PageResources: +%%+ ${prop-font} +%%+ ${fixed-font} +%%EndDefaults +%%BeginProlog +%%BeginResource: procset PSPP-Prologue 1.0 0 +/L{moveto lineto stroke}bind def +/TL{TW setlinewidth 0 setlinecap + moveto lineto stroke + LW setlinewidth 2 setlinecap}def +/D{moveto lineto moveto lineto stroke}bind def +/S{moveto show}bind def +/T{currentpoint exch pop moveto show}bind def +/ED{exch def}bind def +!!! SF arguments: +!!! identifier dictionary entry to save font in +!!! font encoding font encoding vector +!!! fontsize thousandths of a point +!!! font name string +!!! Usage example: 12000/F0 E0 (Times-Roman) SF +/SF{ + findfont exch scalefont + dup maxlength 1 index/FontName known not{1 add}if dict begin + { + 1 index/FID ne{def}{pop pop}ifelse + }forall + /Encoding ED + dup/FontName ED + currentdict end 1 index exch definefont dup setfont + [exch/setfont cvx] cvx bind def +}bind def +/F{setfont}bind def +/EP{ + pg restore + showpage +}bind def +/GB{ + /y2 ED/x2 ED/y1 ED/x1 ED + x1 y1 moveto x2 y1 lineto x2 y2 lineto x1 y2 lineto closepath + gsave 0.9 setgray fill grestore stroke +}bind def +%%EndResource +%%EndProlog +%%BeginSetup +%%IncludeResource: ${prop-font} +%%IncludeResource: ${fixed-font} +!encodings +%%EndSetup +!!! Local Variables: +!!! fill-prefix: "!!! " +!!! End: diff --git a/configure.in b/configure.in new file mode 100644 index 00000000..64bbc411 --- /dev/null +++ b/configure.in @@ -0,0 +1,241 @@ +dnl Process this file with autoconf to produce a configure script. +AC_INIT(src/q2c.c) +AC_PREREQ(2.12) +AM_CONFIG_HEADER(config.h) +CPPFLAGS="$CPPFLAGS -D_GNU_SOURCE=1" +AC_ISC_POSIX +AC_PROG_CC +AM_PROG_CC_STDC +AC_CANONICAL_SYSTEM +AM_INIT_AUTOMAKE(pspp, [0.3.0]) + +#AC_DEFINE_UNQUOTED(PACKAGE, "$PACKAGE") +AC_DEFINE_UNQUOTED(VERSION, "$VERSION") + +#GNU_PACKAGE="GNU $PACKAGE" +#AC_DEFINE_UNQUOTED(GNU_PACKAGE, "$GNU_PACKAGE") + +ALL_LINGUAS="" + +AC_ARG_PROGRAM +AC_PROG_INSTALL +AC_PROG_RANLIB + +dnl internationalization macros +AM_GNU_GETTEXT + +AC_LINK_FILES($nls_cv_header_libgt, $nls_cv_header_intl) + +AC_ARG_WITH(checker, + [ --with-checker compile with Checker (for debugging)], + CC="checkergcc" LOCAL_CC="gcc" CC_OPTIONS="-Werror") +AC_ARG_ENABLE(debugging, + [ --enable-debugging turn on debugging options], + CC_OPTIONS="-DDEBUGGING=1") + +# LOCAL_CC runs on the build system, targets the build system. +# CC runs on the build system, targets the host system. +if test -z "$LOCAL_CC"; then + LOCAL_CC="$CC" +fi +AC_SUBST(LOCAL_CC) + +AC_CHECK_LIB(m, sin) +AC_CHECK_LIB(gmp, mpf_get_str, + LIBS="-lgmp $LIBS" GMP_SUBDIRS= GMP_LIBS=, + GMP_SUBDIRS=gmp GMP_LIBS='$(GMP_LIBS)') +AC_SUBST(GMP_SUBDIRS) +AC_SUBST(GMP_LIBS) + +AC_CHECK_LIB(ncurses, tgetent, LIBS="-lncurses $LIBS" termcap=yes, + AC_CHECK_LIB(termcap, tgetent, LIBS="-ltermcap $LIBS" termcap=yes, + termcap=no)) +if test "$termcap" = yes; then + AC_CHECK_HEADERS(termcap.h) + AC_DEFINE(HAVE_LIBTERMCAP) +fi + +AC_CHECK_LIB(readline, readline) +if test "$ac_cv_lib_readline_readline" = yes; then + AC_CHECK_HEADERS(readline/readline.h) + AC_CHECK_LIB(readline, add_history, history=yes, + AC_CHECK_LIB(history, add_history, LIBS="-lhistory" history=yes, + history=no)) + if test "$history" = yes; then + AC_CHECK_HEADERS(readline/history.h) + AC_DEFINE(HAVE_LIBHISTORY) + fi +fi + +AC_CHECK_HEADERS(limits.h memory.h sys/stat.h sys/time.h sys/types.h \ + fpu_control.h sys/mman.h sys/wait.h ieeefp.h fenv.h) +AC_HEADER_STAT +AC_HEADER_STDC +AC_HEADER_TIME + +dnl This test must precede tests of compiler characteristics like +dnl that for the inline keyword, since it may change the degree to +dnl which the compiler supports such features. +AM_C_PROTOTYPES + +AC_C_CONST +AC_C_INLINE +AC_TYPE_SIZE_T +AC_STRUCT_TM + +AC_CHECK_SIZEOF(short, 2) +AC_CHECK_SIZEOF(int, 4) +AC_CHECK_SIZEOF(long, 4) +AC_CHECK_SIZEOF(long long, 0) +AC_CHECK_SIZEOF(float, 0) +AC_CHECK_SIZEOF(double, 8) +AC_CHECK_SIZEOF(long double, 0) + +dnl There used to be a check for floating-point representation here, but +dnl for some reason it didn't work on certain m68k GNU/Linux machines, and +dnl I was unable to determine why. So, since every modern computer uses +dnl ieee754 format anyway, I've hard-coded it to ieee754. Anyone who uses +dnl something else can enumerate the exceptions. + +AC_DEFINE(FPREP, FPREP_IEEE754) + +dnl if test "$cross_compiling" = yes; then +dnl AC_MSG_WARN([Edit config.h to set proper values for SIZEOF_SHORT, \ +dnl SIZEOF_INT,]) +dnl AC_MSG_WARN([SIZEOF_LONG, and SIZEOF_LONG_LONG (if available), if the \ +dnl values]) +dnl AC_MSG_WARN([are not 2, 4, 4, and 8, respectively.]) +dnl AC_MSG_WARN([Also set the floating point representation (IEEE754, etc.).]) +dnl else +dnl AC_CACHE_CHECK( +dnl floating point representation, ac_cv_sys_fprep, +dnl +dnl AC_TRY_RUN( +dnl [changequote(<<, >>)dnl +dnl << +dnl main () { +dnl /* Test for IEEE754 floating point representation. */ +dnl union { unsigned char c[8]; double d; } +dnl l = {{0x1c, 0xbc, 0x6e, 0xf2, 0x54, 0x8b, 0x11, 0x43}}, +dnl b = {{0x43, 0x11, 0x8b, 0x54, 0xf2, 0x6e, 0xbc, 0x1c}}; +dnl return l.d!=1234567891234567.0 && b.d!=1234567891234567.0; +dnl } +dnl >> +dnl changequote([, ])dnl +dnl ], ac_cv_sys_fprep=ieee754, ac_cv_sys_fprep=unknown, +dnl AC_MSG_WARN([This error cannot occur.]))) +dnl if test "$ac_cv_sys_fprep" = ieee754; then +dnl AC_DEFINE(FPREP, FPREP_IEEE754) +dnl else +dnl AC_MSG_WARN([Unknown floating-point representation. This is a serious \ +dnl error.]) +dnl AC_MSG_WARN([Please contact the author for porting information.]) +dnl AC_MSG_WARN([(It should be a fairly simple port, by the way.)]) +dnl AC_DEFINE(FPREP, FPREP_UNKNOWN) +dnl fi +dnl fi + +if test "$cross_compiling" = no; then + dnl This code was taken from acspecific.m4 and modified. + dnl It began life as AC_C_BIGENDIAN. + AC_CACHE_CHECK( + whether byte ordering is bigendian, ac_cv_c_bigendian, + [ac_cv_c_bigendian=unknown + # See if sys/param.h defines the BYTE_ORDER macro. + AC_TRY_COMPILE( + [#include + #include ], + [#if !BYTE_ORDER || !BIG_ENDIAN || !LITTLE_ENDIAN + bogus endian macros + #endif], + [# It does; now see whether it defined to BIG_ENDIAN or not. + AC_TRY_COMPILE( + [#include + #include ], + [#if BYTE_ORDER != BIG_ENDIAN + not big endian + #endif], + ac_cv_c_bigendian=yes, ac_cv_c_bigendian=no)]) + if test $ac_cv_c_bigendian = unknown; then + AC_TRY_RUN( + [main () { + /* Are we little or big endian? From Harbison&Steele. */ + union + { + long l; + char c[sizeof (long)]; + } u; + u.l = 1; + exit (u.c[sizeof (long) - 1] == 1); + }], + ac_cv_c_bigendian=no, ac_cv_c_bigendian=yes, + AC_MSG_ERROR([Internal error determining endianness.])) + fi]) + + if test "$ac_cv_c_bigendian" = yes; then + AC_DEFINE(ENDIAN, BIG) + elif test "$ac_cv_c_bigendian" = no; then + AC_DEFINE(ENDIAN, LITTLE) + else + AC_MSG_ERROR([Machine's endianness is unknown.]) + fi +else + AC_DEFINE(ENDIAN, UNKNOWN) + + AC_MSG_WARN([Optionally set value for endianness for best performance.]) +fi + +BLP_IS_SPRINTF_GOOD +BLP_INT_DIGITS +BLP_RANDOM + +AC_FUNC_ALLOCA +AC_FUNC_MEMCMP +AC_FUNC_VPRINTF +AC_REPLACE_FUNCS(memmove memset stpcpy strpbrk strerror strtol strtoul memchr \ + getline getdelim strcasecmp strncasecmp memmem strtok_r) +AC_CHECK_FUNCS(gethostname strstr strtod __setfpucw isinf isnan finite getpid \ + feholdexcept) + +AC_PROG_LN_S + +dnl This must be after other tests so warnings don't provoke errors above. +if test "$ac_cv_prog_gcc" = yes; then + CFLAGS="-g -Wall -W -Wno-uninitialized -Wwrite-strings \ +-Wstrict-prototypes -Wpointer-arith" + if test "$CC_OPTIONS" != ""; then + CFLAGS="$CFLAGS $CC_OPTIONS" + fi +fi +AC_SUBST(CFLAGS) + +AC_OUTPUT(Makefile \ + intl/Makefile \ + po/Makefile.in \ + lib/Makefile \ + lib/gmp/Makefile \ + lib/gmp/mpn/Makefile \ + lib/gmp/mpf/Makefile \ + lib/julcal/Makefile \ + lib/misc/Makefile \ + lib/dcdflib/Makefile \ + doc/Makefile \ + src/Makefile \ + config/Makefile \ + tests/Makefile, + [sed -e "/POTFILES =/r po/POTFILES" po/Makefile.in > po/Makefile + + # Copy pref.h from pref.h.orig if prudent + if test ! -f pref.h; then + echo "creating pref.h" + cp $ac_given_srcdir/pref.h.orig pref.h + elif test "`ls -t pref.h.orig pref.h 2>/dev/null | sed 1q`" = pref.h.orig; then + echo "replacing pref.h with newer pref.h.orig" + cp $ac_given_srcdir/pref.h.orig pref.h + else + echo "pref.h exists" + fi + if test -f pref.h; then touch pref.h; fi + ]) + +dnl configure.in ends here diff --git a/doc/ChangeLog b/doc/ChangeLog new file mode 100644 index 00000000..15eb0585 --- /dev/null +++ b/doc/ChangeLog @@ -0,0 +1,481 @@ +Sun Jan 2 21:30:53 2000 Ben Pfaff + + * pspp.texi: Updated. + +Tue Mar 9 12:47:20 1999 Ben Pfaff + + * pspp.texi: Updated. + +Mon Jan 18 19:29:21 1999 Ben Pfaff + + * pspp.texi: Updated. + +Tue Jan 5 12:04:09 1999 Ben Pfaff + + * pspp.texi: Updated. + +Thu Nov 19 12:35:01 1998 Ben Pfaff + + * pspp.texi: Revised. + +Sun Aug 9 11:11:43 1998 Ben Pfaff + + * pspp.texi: Revised. + +Sat Aug 8 00:19:22 1998 Ben Pfaff + + * pspp.texi: Revised. + +Sun Jul 5 00:14:24 1998 Ben Pfaff + + * pspp.texi: Updated. + +Fri May 29 21:43:52 1998 Ben Pfaff + + * pspp.texi: Revised. + +Wed May 20 00:03:50 1998 Ben Pfaff + + * pspp.texi: Updated. + +Fri Apr 24 12:51:28 1998 Ben Pfaff + + * pspp.texi: Updated. + +Wed Apr 15 13:01:28 1998 Ben Pfaff + + * AUTHORS.html, BUGS.html, LANGUAGE.html, README.html, + THANKS.html: Removed. + + * Makefile.am: Don't reference the deleted files. + +Mon Mar 9 00:55:59 1998 Ben Pfaff + + * LANGUAGE.html: Updated. + +1998-03-05 Ben Pfaff + + * pspp.texi: Updated. + +1998-02-23 Ben Pfaff + + * pspp.texi: Updated. + +Fri Feb 13 15:35:44 1998 Ben Pfaff + + * LANGUAGE.html: Updated. + +Thu Feb 5 00:18:10 1998 Ben Pfaff + + * LANGUAGE.html: Updated. + + * pspp.texi: Revised. + +Tue Jan 13 23:44:43 1998 Ben Pfaff + + * BUGS.html: Updated. + + * LANGUAGE.html: Updated. + +Thu Jan 8 22:27:29 1998 Ben Pfaff + + * pspp.texi: Updated. + +Sun Jan 4 18:12:11 1998 Ben Pfaff + + * LANGUAGE.html: Updated. + +Wed Dec 24 22:36:09 1997 Ben Pfaff + + * pspp.texi: Updated. + +Sun Dec 21 16:18:18 1997 Ben Pfaff + + * pspp.texi: Updated. + +Fri Dec 5 22:53:35 1997 Ben Pfaff + + * fiasco.man: Renamed pspp.man. + + * fiasco.texi: Renamed pspp.texi. + +Fri Dec 5 21:52:29 1997 Ben Pfaff + + * fiasco.texi: Updated. + +Tue Dec 2 14:35:34 1997 Ben Pfaff + + * BUGS.html: Updated. + +Sat Nov 22 01:20:41 1997 Ben Pfaff + + * fiasco.texi: Revised. + +Fri Nov 21 00:02:36 1997 Ben Pfaff + + * fiasco.man, fiasco.texi: Revised. + +Tue Oct 28 16:08:01 1997 Ben Pfaff + + * fiasco.texi: Revised. + +Tue Oct 7 20:22:14 1997 Ben Pfaff + + * LANGUAGE.html: Updated. + +Sat Oct 4 16:19:27 1997 Ben Pfaff + + * LANGUAGE.html: Updated. + +Thu Sep 18 21:33:44 1997 Ben Pfaff + + * BUGS.html, LANGUAGE.html: Updated. + +Wed Aug 20 14:21:35 1997 Ben Pfaff + + * Makefile.am: (info_TEXINFOS) Remove FAQ.texi. + +Wed Aug 20 12:49:40 1997 Ben Pfaff + + * ANNOUNCE.html.in, FAQ.texi, HELP-WANTED.html: Removed. + + * BUGS.html, LANGUAGE.html, README.html.in: Updated per + suggestions of rms. + + * Makefile.am: (noinst_DATA) Removed ANNOUNCE.html, + HELP-WANTED.html. + (EXTRA_DIST) Removed ANNOUNCE.html, ANNOUNCE.html.in, + HELP-WANTED.html. + (MAINTAINERCLEANFILES, HTML_FORMATTER) Removed. + + * fiasco.texi: Revised. + +Sat Aug 16 10:51:51 1997 Ben Pfaff + + * ANNOUNCE.html.in, HELP-WANTED.html, README.html.in: Updated per + suggestions of rms. + + * AUTHORS.html, BUGS.html, FAQ.texi, LANGUAGE.html, THANKS.html, + fiasco.man, fiasco.texi: Updated. + + * README-i386linux.html, dist.html.in.in, fiasco.lsm.in, + changelogs.html.top, changelogs.html.bot: Removed, all references + removed. + +Thu Aug 14 22:07:02 1997 Ben Pfaff + + * ANNOUNCE.html.in, README.html.in, dist.html.in.in: Updated. + + * Makefile.am: Use $(VERSION) instead of VERSION file. + (EXTRA_DIST) Add README-i386linux. + +Thu Aug 14 11:52:20 1997 Ben Pfaff + + * ANNOUNCE.html.in, AUTHORS.html, BUGS.html, HELP-WANTED.html, + LANGUAGE.html, README-i386linux.html, README.html.in, THANKS.html, + changelogs.html.bot, changelogs.html.top: Revised. + + * Makefile.am: (noinst_DATA) Remove dist.html, add dist.html.in. + (EXTRA_DIST) Add ONEWS, remove dist.html, dist.html.in, add + dist.html.in.in. + (MAINTAINERCLEANFILES) Add dist.html.in. + (dist.html) Removed. + (dist.html.in) New target depending on dist.html.in.in. + (docfiles) New target. + + * dist.html.in: Renamed dist.html.in.in. + +Tue Aug 5 13:57:20 1997 Ben Pfaff + + * FAQ.texi, fiasco.texi: Updated. + +Sun Aug 3 11:34:43 1997 Ben Pfaff + + * ANNOUNCE.html.in, AUTHORS.html, BUGS.html, FAQ.texi, + LANGUAGE.html, README-i386linux.html, README.html.in, THANKS.html, + changelogs.html.bot, dist.html.in, fiasco.texi: Updated. + + * Makefile.am: (noinst_DATA, EXTRA_DIST) Add HELP-WANTED.html, + remove README-i386gnuwin32.html. + (MAINTAINERCLEANFILES) Remove README-i386gnuwin32.html, add + README-i386linux. + (README-i386linux) New target. + + * README-i386gnuwin32.html.in: Removed. + + * HELP-WANTED.html: New file. + +Thu Jul 17 21:40:28 1997 Ben Pfaff + + * Makefile.am: Generates fiasco.lsm from fiasco.lsm.in. + +Thu Jul 17 01:49:06 1997 Ben Pfaff + + * FAQ.texi: Updated. + + * Makefile.am: Completely rewritten. + + * ANNOUNCE.html.in, README-i386gnuwin32.html.in, + README-i386linux.html, README.html.in, dist.html.in, + fiasco.lsm.in: New files. + +Fri Jul 11 23:01:32 1997 Ben Pfaff + + * fiasco.texi: Updated. + +Sun Jul 6 20:46:38 1997 Ben Pfaff + + * ANNOUNCE.html, FAQ.texi, README.html: Updated. + + * Makefile.am: Add all the recent new files to EXTRA_DIST. + +Sat Jul 5 23:43:50 1997 Ben Pfaff + + * ANNOUNCE.html, FAQ.texi, README.html: Updated. + + * changelogs.html.bot: Fix copyright notice. + + * fiasco.man: New file. + +Fri Jul 4 13:23:57 1997 Ben Pfaff + + * changelogs.html.bot, changelogs.html.top: New files. + + * fiasco.lsm: New file. + + * ANNOUNCE.html, FAQ.texi, README.html: Updated. + + * Makefile.am: (EXTRA_DIST) Removed duplicate assignment. + +Wed Jun 25 22:51:39 1997 Ben Pfaff + + * FAQ.texi: Finished. + + * README.html: Updates. + +Sun Jun 22 21:59:07 1997 Ben Pfaff + + * ANNOUNCE.html, BUGS.html, LANGUAGE.html, README.html, + fiasco.texi: Updates. + + * Makefile.am: Add `FAQ.texi' to info_TEXINFOS. + + * FAQ.texi: New file. + +Tue Jun 3 23:25:51 1997 Ben Pfaff + + * AUTHORS.html, BUGS.html, README.html, THANKS.html: Updates. + + * fiasco.texi: Update. + +Sun Jun 1 11:58:27 1997 Ben Pfaff + + * fiasco.texi: Development. + +Fri May 30 19:39:37 1997 Ben Pfaff + + * fiasco.texi: Development. + +Mon May 5 21:57:20 1997 Ben Pfaff + + * fiasco.texi: Development. + +Fri May 2 22:07:26 1997 Ben Pfaff + + * fiasco.texi: Development. + +Thu May 1 14:58:31 1997 Ben Pfaff + + * BUGS.html: Update. + + * fiasco.texi: Development. + +Wed Apr 23 21:33:48 1997 Ben Pfaff + + * THANKS.html: Update. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-clean Makefile.in. + +Thu Mar 27 01:11:29 1997 Ben Pfaff + + * THANKS.html: Added Fran,cois Pinard. + +Mon Mar 24 21:47:31 1997 Ben Pfaff + + * THANKS.html: Spelling fix. + +Sat Feb 15 21:26:53 1997 Ben Pfaff + + * LANGUAGE.html: Updated. + +Fri Feb 14 23:32:58 1997 Ben Pfaff + + * BUGS.html: Updated. + +Wed Jan 22 21:54:00 1997 Ben Pfaff + + * LANGUAGE.html: RENAME VARIABLES is implemented. + +Thu Jan 16 13:08:57 1997 Ben Pfaff + + * LANGUAGE.html: MODIFY VARS now works. + + * README.html: Added `alpha.gnu.ai.mit.edu' to list of sites. + +Sat Jan 11 15:44:15 1997 Ben Pfaff + + * README.html: Commented out sunsite reference and added + ALPHA-release warning. + +Fri Jan 10 20:22:08 1997 Ben Pfaff + + * LANGUAGE.html: Reformatted. + +Thu Jan 2 19:08:23 1997 Ben Pfaff + + * LANGUAGE.html: Updated. + +Wed Jan 1 22:08:10 1997 Ben Pfaff + + * LANGUAGE.html: Updated. + +Sun Dec 29 21:36:48 1996 Ben Pfaff + + * LANGUAGE.html: Updated. + + * fiasco.texi: Updated. + +Tue Dec 24 20:42:32 1996 Ben Pfaff + + * LANGUAGE.html, README.html: Miscellaneous changes. + +Sun Dec 22 23:10:39 1996 Ben Pfaff + + * LANGUAGE.html, README.html: Miscellaneous changes. + + * AUTHORS.html, BUGS.html, THANKS.html: New files derived from + corresponding files without the `.html'. + +Sat Dec 21 21:51:04 1996 Ben Pfaff + + * AUTHORS: Grammar fix. + + * LANGUAGE.html: New file. LANGUAGE is now automatically + generated from this html source through lynx. + + * README.html: Similar situation to LANGUAGE.html. + +Sun Dec 15 15:32:16 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Fri Dec 6 23:53:47 1996 Ben Pfaff + + * AUTHORS, BUGS, LANGUAGE, README: Updated. + + * fiasco.texi: Fixes. + +Wed Dec 4 21:34:17 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Sun Dec 1 17:19:00 1996 Ben Pfaff + + * BUGS, LANGUAGE, NEWS: Misc. changes. + +Sun Nov 24 14:53:53 1996 Ben Pfaff + + * fiasco.texi: Changed many instances of `illegal' to `invalid'. + +Wed Oct 30 17:13:08 1996 Ben Pfaff + + * LANGUAGE: Updated. + + * README: Updated. + +Sat Oct 26 23:06:06 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Sat Oct 26 10:39:25 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Thu Oct 24 20:13:42 1996 Ben Pfaff + + * LANGUAGE: Updated. + + * README: Updated. + + * fiasco.texi: Updated. + +Thu Oct 24 17:47:14 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Wed Oct 23 21:53:43 1996 Ben Pfaff + + * LANGUAGE: Updated. + +Tue Oct 22 17:27:04 1996 Ben Pfaff + + * LANGUAGE: Updated. + + * fiasco.texi: Very minor changes. + +Sun Sep 29 19:37:03 1996 Ben Pfaff + + * fiasco.texi: Continued development. + +Tue Sep 24 18:39:09 1996 Ben Pfaff + + * avl.texi, gpl.texi: Removed. + + * fiasco.texi: Changed copyright notices; deleted references to + avl.texi, gpl.texi. + +Sat Sep 21 23:16:31 1996 Ben Pfaff + + * fiasco.texi: Continued work--added to configuration chapter. + +Fri Sep 20 22:52:28 1996 Ben Pfaff + + * fiasco.texi: Continued work--added to configuration chapter. + +Thu Sep 12 18:40:33 1996 Ben Pfaff + + * fiasco.texi: Continued work--added section on bug reports. + +Wed Sep 11 22:01:41 1996 Ben Pfaff + + * fiasco.texi: Added timestamp. Started some updating. + +Tue Sep 10 21:39:00 1996 Ben Pfaff + + * LANGUAGE: Updated. + + * README: Minor change. + +Mon Sep 9 21:43:13 1996 Ben Pfaff + + * NEWS: Added automagic timestamp. + + * README: Restructured, extended. + + * BUGS, LANGUAGE: New files. + +Sat Jul 6 22:22:25 1996 Ben Pfaff + + * fiasco.texi: Remarked on broken Borland alloca(). + +Mon Jul 1 13:00:00 1996 Ben Pfaff + + * stat.texi: Renamed to `fiasco.texi'. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/doc/Makefile.am b/doc/Makefile.am new file mode 100644 index 00000000..77de9770 --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1,11 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +info_TEXINFOS = pspp.texi + +# FIXME: remove this when the manual is fixed to eliminate dangling +# references. +MAKEINFO = makeinfo --no-validate + +EXTRA_DIST = pspp.man + +MAINTAINERCLEANFILES = Makefile.in README.html diff --git a/doc/mdate-sh b/doc/mdate-sh new file mode 100755 index 00000000..0c7ad12e --- /dev/null +++ b/doc/mdate-sh @@ -0,0 +1,91 @@ +#!/bin/sh +# mdate-sh - get modification time of a file and pretty-print it +# Copyright (C) 1995 Software Foundation, Inc. +# Written by Ulrich Drepper , June 1995 +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +# Prevent date giving response in another language. +LANG=C +export LANG +LC_ALL=C +export LC_ALL +LC_TIME=C +export LC_TIME + +# Get the extended ls output of the file. +if ls -L /dev/null 1>/dev/null 2>&1; then + set - `ls -L -l $1` +else + set - `ls -l $1` +fi +# The month is at least the fourth argument. +# (3 shifts here, the next inside the loop) +shift +shift +shift + +# Find the month. Next argument is day, followed by the year or time. +month= +until test $month +do + shift + case $1 in + Jan) month=January; nummonth=1;; + Feb) month=February; nummonth=2;; + Mar) month=March; nummonth=3;; + Apr) month=April; nummonth=4;; + May) month=May; nummonth=5;; + Jun) month=June; nummonth=6;; + Jul) month=July; nummonth=7;; + Aug) month=August; nummonth=8;; + Sep) month=September; nummonth=9;; + Oct) month=October; nummonth=10;; + Nov) month=November; nummonth=11;; + Dec) month=December; nummonth=12;; + esac +done + +day=$2 + +# Here we have to deal with the problem that the ls output gives either +# the time of day or the year. +case $3 in + *:*) set `date`; eval year=\$$# + case $2 in + Jan) nummonthtod=1;; + Feb) nummonthtod=2;; + Mar) nummonthtod=3;; + Apr) nummonthtod=4;; + May) nummonthtod=5;; + Jun) nummonthtod=6;; + Jul) nummonthtod=7;; + Aug) nummonthtod=8;; + Sep) nummonthtod=9;; + Oct) nummonthtod=10;; + Nov) nummonthtod=11;; + Dec) nummonthtod=12;; + esac + # For the first six month of the year the time notation can also + # be used for files modified in the last year. + if (expr $nummonth \> $nummonthtod) > /dev/null; + then + year=`expr $year - 1` + fi;; + *) year=$3;; +esac + +# The result. +echo $day $month $year diff --git a/doc/pspp.man b/doc/pspp.man new file mode 100644 index 00000000..05792309 --- /dev/null +++ b/doc/pspp.man @@ -0,0 +1,45 @@ +.\" PSPP - computes sample statistics. +.\" Copyright (C) 1997, 1998 Free Software Foundation, Inc. +.\" Written by Ben Pfaff . +.\" +.\" This program is free software; you can redistribute it and/or +.\" modify it under the terms of the GNU General Public License as +.\" published by the Free Software Foundation; either version 2 of the +.\" License, or (at your option) any later version. +.\" +.\" This program is distributed in the hope that it will be useful, but +.\" WITHOUT ANY WARRANTY; without even the implied warranty of +.\" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +.\" General Public License for more details. +.\" +.\" You should have received a copy of the GNU General Public License +.\" along with this program; if not, write to the Free Software +.\" Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA +.\" 02111-1307, USA. +.\" +.TH pspp 1 "4 Jul 1997" "manpage v1.0" "PSPP manual" +.SH NAME +pspp \- a system for statistical analysis +.SH SYNOPSIS +.B pspp +\&.\|.\|. +.SH DESCRIPTION +.B pspp +starts up the PSPP program. PSPP performs statistical analysis on +sampled data. Please see Info document `pspp' for more details on +using PSPP. For other miscellaneous information about PSPP, see +the PSPP FAQ, which should be installed in /usr/doc/pspp. + +These documents and others are available in various formats. On +Debian GNU/Linux systems, full documentation is available in directory +`/usr/doc/pspp', in HTML and ASCII formats, and in `/usr/info', in +Info format. TeX can be used to convert the Texinfo documentation in +the source distribution to nice-looking output for printing. + +Documentation is also at http://www.gnu.org/software/pspp. + +.SH BUGS + +Probably a lot. Known bugs are listed in the documentation files +BUGS, LANGUAGE, and TODO, depending on type. Please see those files +for more details. diff --git a/doc/pspp.texi b/doc/pspp.texi new file mode 100644 index 00000000..86a9be03 --- /dev/null +++ b/doc/pspp.texi @@ -0,0 +1,9832 @@ +\input texinfo @c -*- texinfo -*- +@c %**start of header +@setfilename pspp.info +@settitle PSPP +@set TIMESTAMP Time-stamp: <2000-01-02 22:32:14 blp> +@set EDITION 0.2 +@set VERSION 0.2 +@c For double-sided printing, uncomment: +@c @setchapternewpage odd +@c %**end of header + +@iftex +@finalout +@end iftex + +@ifinfo +@format +START-INFO-DIR-ENTRY +* PSPP: (pspp). Statistical analysis package. +END-INFO-DIR-ENTRY +@end format + +PSPP, for statistical analysis of sampled data, by Ben Pfaff. + +This file documents PSPP, a statistical package for analysis of +sampled data that uses a command language compatible with SPSS. + +Copyright (C) 1996-9, 2000 Free Software Foundation, Inc. + +This version of the PSPP documentation is consistent with version 2 of +``texinfo.tex''. + +Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + +@ignore +Permission is granted to process this file through TeX and print the +results, provided the printed document carries copying permission notice +identical to this one except for the removal of this paragraph (this +paragraph not being relevant to the printed manual). + +@end ignore +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire resulting derived work is distributed under the terms of a +permission notice identical to this one. + +Permission is granted to copy and distribute translations of this +manual into another language, under the above condition for modified +versions, except that this permission notice may be stated in a +translation approved by the Free Software Foundation. +@end ifinfo + +@titlepage +@title PSPP +@subtitle A System for Statistical Analysis +@subtitle Edition @value{EDITION}, for PSPP version @value{VERSION} +@author by Ben Pfaff + +@page +@vskip 0pt plus 1filll + +PSPP Copyright @copyright{} 1997, 1998 Free Software Foundation, Inc. + +Permission is granted to make and distribute verbatim copies of this +manual provided the copyright notice and this permission notice are +preserved on all copies. + +Permission is granted to copy and distribute modified versions of this +manual under the conditions for verbatim copying, provided that the +entire derived work is distributed under the terms of a permission +notice identical to this one. + +Permission is granted to copy and distribute translations of this manual +into another language, under the above conditions for modified versions, +except that this permission notice may be stated in a translation +approved by the Foundation. +@end titlepage + +@node Top, Introduction, (dir), (dir) +@ifinfo +@top PSPP + +This file documents the PSPP package for statistical analysis of sampled +data. This is edition @value{EDITION}, for PSPP version +@value{VERSION}, last modified at @value{TIMESTAMP}. + +@end ifinfo + +@menu +* Introduction:: Description of the package. +* License:: Your rights and obligations. +* Credits:: Acknowledgement of authors. + +* Installation:: How to compile and install PSPP. +* Configuration:: Configuring PSPP. +* Invocation:: Starting and running PSPP. + +* Language:: Basics of the PSPP command language. +* Expressions:: Numeric and string expression syntax. + +* Data Input and Output:: Reading data from user files. +* System and Portable Files:: Dealing with system & portable files. +* Variable Attributes:: Adjusting and examining variables. +* Data Manipulation:: Simple operations on data. +* Data Selection:: Select certain cases for analysis. +* Conditionals and Looping:: Doing things many times or not at all. +* Statistics:: Basic statistical procedures. +* Utilities:: Other commands. +* Not Implemented:: What's not here yet + +* Data File Format:: Format of PSPP system files. +* Portable File Format:: Format of PSPP portable files. +* q2c Input Format:: Format of syntax accepted by q2c. + +* Bugs:: Known problems; submitting bug reports. + +* Function Index:: Index of PSPP functions for expressions. +* Concept Index:: Index of concepts. +* Command Index:: Index of PSPP procedures. + +@end menu + +@node Introduction, License, Top, Top +@chapter Introduction +@cindex introduction + +@cindex PSPP language +@cindex language, PSPP +PSPP is a tool for statistical analysis of sampled data. It reads a +syntax file and a data file, analyzes the data, and writes the results +to a listing file or to standard output. + +The language accepted by PSPP is similar to those accepted by SPSS +statistical products. The details of PSPP's language are given +later in this manual. + +@cindex files, PSPP +@cindex output, PSPP +@cindex PostScript +@cindex graphics +@cindex Ghostscript +@cindex Free Software Foundation +PSPP produces output in two forms: tables and charts. Both of these can +be written in several formats; currently, ASCII, PostScript, and HTML +are supported. In the future, more drivers, such as PCL and X Window +System drivers, may be developed. For now, Ghostscript, available from +the Free Software Foundation, may be used to convert PostScript chart +output to other formats. + +The current version of PSPP, @value{VERSION}, is woefully incomplete in +terms of its statistical procedure support. PSPP is a work in progress. +The author hopes to support fully support all features in the products +that PSPP replaces, eventually. The author welcomes questions, +comments, donations, and code submissions. @xref{Bugs,,Submitting Bug +Reports}, for instructions on contacting the author. + +@node License, Credits, Introduction, Top +@chapter Your rights and obligations +@cindex license +@cindex your rights and obligations +@cindex rights, your +@cindex obligations, your + +@cindex Free Software Foundation +@cindex GNU General Public License +@cindex General Public License +@cindex GPL +@cindex distribution +@cindex redistribution +Most of PSPP is distributed under the GNU General Public +License. The General Public License says, in effect, that you may +modify and distribute PSPP as you like, as long as you grant the +same rights to others. It also states that you must provide source code +when you distribute PSPP, or, if you obtained PSPP +source code from an anonymous ftp site, give out the name of that site. + +The General Public License is given in full in the source distribution +as file @file{COPYING}. In Debian GNU/Linux, this file is also +available as file @file{/usr/doc/copyright/GPL}. + +To quote the GPL itself: + +@quotation +This program is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License along +with this program; if not, write to the Free Software Foundation, Inc., +675 Mass Ave, Cambridge, MA 02139, USA. +@end quotation + +@node Credits, Installation, License, Top +@chapter Credits +@cindex credits +@cindex authors + +@cindex Minton, Claire +@cindex @cite{Cat's Cradle} +@cindex Vonnegut, Kurt, Jr. +@cindex quotations +@quotation +I'm always embarrassed when I see an index an author has made of his own +work. It's a shameless exhibition---to the @i{trained} eye. Never +index your own book. + +---Claire Minton, @cite{Cat's Cradle}, Kurt Vonnegut, Jr. +@end quotation + +@cindex Pfaff, Ben +Most of PSPP, as well as this manual (including the indices), +was written by Ben Pfaff. @xref{Contacting the Author}, for +instructions on contacting the author. + +@cindex Covington, Michael A. +@cindex Van Zandt, James +@cindex @file{ftp.cdrom.com} +@cindex @file{/pub/algorithms/c/julcal10} +@cindex @file{julcal.c} +@cindex @file{julcal.h} +The PSPP source code incorporates @code{julcal10} originally +written by Michael A. Covington and translated into C by Jim Van Zandt. +The original package can be found in directory +@file{ftp://ftp.cdrom.com/pub/algorithms/c/julcal10}. The entire +contents of that directory constitute the package. The files actually +used in PSPP are @code{julcal.c} and @code{julcal.h}. + +@node Installation, Configuration, Credits, Top +@chapter Installing PSPP +@cindex installation +@cindex PSPP, installing + +@cindex GNU C compiler +@cindex gcc +@cindex compiler, recommended +@cindex compiler, gcc +PSPP conforms to the GNU Coding Standards. PSPP is written in, and +requires for proper operation, ANSI/ISO C. You might want to +additionally note the following points: + +@itemize @bullet +@item +The compiler and linker must allow for significance of several +characters in external identifiers. The exact number is unknown but at +least 31 is recommended. + +@item +The @code{int} type must be 32 bits or wider. + +@item +The recommended compiler is gcc 2.7.2.1 or later, but any ANSI compiler +will do if it fits the above criteria. +@end itemize + +Many UNIX variants should work out-of-the-box, as PSPP uses GNU +autoconf to detect differences between environments. Please report any +problems with compilation of PSPP under UNIX and UNIX-like operating +systems---portability is a major concern of the author. + +The pages below give specific instructions for installing PSPP +on each type of system mentioned above. + +@menu +* UNIX installation:: Installing on UNIX-like environments. +@end menu + +@node UNIX installation, , Installation, Installation +@section UNIX installation +@cindex UNIX, installing PSPP under +@cindex installation, under UNIX +@noindent +To install PSPP under a UNIX-like operating system, follow the steps +below in order. Some of the text below was taken directly from various +Free Software Foundation sources. + +@enumerate +@item +@code{cd} to the directory containing the PSPP source. + +@cindex configure, GNU +@cindex GNU configure +@item +Type @samp{./configure} to configure for your particular operating +system and compiler. Running @code{configure} takes a while. While +running, it displays some messages telling which features it is checking +for. + +You can optionally supply some options to @code{configure} in order to +give it hints about how to do its job. Type @code{./configure --help} +to see a list of options. One of the most useful options is +@samp{--with-checker}, which enables the use of the Checker memory +debugger under supported operating systems. Checker must already be +installed to use this option. Do not use @samp{--with-checker} if you +are not debugging PSPP itself. + +@cindex @file{Makefile} +@cindex @file{config.h} +@cindex @file{pref.h} +@cindex makefile +@item +(optional) Edit @file{Makefile}, @file{config.h}, and @file{pref.h}. +These files are produced by @code{configure}. Note that most PSPP +settings can be changed at runtime. + +@file{pref.h} is only generated by @code{configure} if it does not +already exist. (It's copied from @file{prefh.orig}.) + +@cindex compiling +@item +Type @samp{make} to compile the package. If there are any errors during +compilation, try to fix them. If modifications are necessary to compile +correctly under your configuration, contact the author. +@xref{Bugs,,Submitting Bug Reports}, for details. + +@cindex self-tests, running +@item +Type @samp{make check} to run self-tests on the compiled PSPP package. + +@cindex installation +@cindex PSPP, installing +@cindex @file{/usr/local/share/pspp/} +@cindex @file{/usr/local/bin/} +@cindex @file{/usr/local/info/} +@cindex documentation, installing +@item +Become the superuser and type @samp{make install} to install the +PSPP binaries, by default in @file{/usr/local/bin/}. The +directory @file{/usr/local/share/pspp/} is created and populated with +files needed by PSPP at runtime. This step will also cause the +PSPP documentation to be installed in @file{/usr/local/info/}, +but only if that directory already exists. + +@item +(optional) Type @samp{make clean} to delete the PSPP binaries +from the source tree. +@end enumerate + +@node Configuration, Invocation, Installation, Top +@chapter Configuring PSPP +@cindex configuration +@cindex PSPP, configuring + +PSPP has dozens of configuration possibilities and hundreds of +settings. This is both a bane and a blessing. On one hand, it's +possible to easily accommodate diverse ranges of setups. But, on the +other, the multitude of possibilities can overwhelm the casual user. +Fortunately, the configuration mechanisms are profusely described in the +sections below@enddots{} + +@menu +* File locations:: How PSPP finds config files. +* Configuration techniques:: Many different methods of configuration@enddots{} +* Configuration files:: How configuration files are read. +* Environment variables:: All about environment variables. +* Output devices:: Describing your terminal(s) and printer(s). +* PostScript driver class:: Configuration of PostScript devices. +* ASCII driver class:: Configuration of character-code devices. +* HTML driver class:: Configuration for HTML output. +* Miscellaneous configuring:: Even more configuration variables. +* Improving output quality:: Hints for producing ever-more-lovely output. +@end menu + +@node File locations, Configuration techniques, Configuration, Configuration +@section Locating configuration files + +PSPP uses the same method to find most of its configuration files: + +@enumerate +@item +The @dfn{base name} of the file being sought is determined. + +@item +The path to search is determined. + +@item +Each directory in the search path, from left to right, is searched for a +file with the name of the base name. The first occurrence is read +as the configuration file. +@end enumerate + +The first two steps are elaborated below for the sake of our pedantic +friends. + +@enumerate +@item +A @dfn{base name} is a file name lacking an absolute directory +reference. Some examples of base names are: @file{ps-encodings}, +@file{devices}, @file{devps/DESC} (under UNIX), @file{devps\DESC} (under +M$ environments). + +Determining the base name is a two-step process: + +@enumerate a +@item +If the appropriate environment variable is defined, the value of that +variable is used (@pxref{Environment variables}). For instance, when +searching for the output driver initialization file, the variable +examined is @code{STAT_OUTPUT_INIT_FILE}. + +@item +Otherwise, the compiled-in default is used. For example, when searching +for the output driver initialization file, the default base name is +@file{devices}. +@end enumerate + +@strong{Please note:} If a user-specified base name does contain an +absolute directory reference, as in a file name like +@file{/home/pfaff/fonts/TR}, no path is searched---the file name is used +exactly as given---and the algorithm terminates. + +@item +The path is the first of the following that is defined: + +@itemize @bullet +@item +A variable definition for the path given in the user environment. This +is a PSPP-specific environment variable name; for instance, +@code{STAT_OUTPUT_INIT_PATH}. + +@item +In some cases, another, less-specific environment variable is checked. +For instance, when searching for font files, the PostScript driver first +checks for a variable with name @code{STAT_GROFF_FONT_PATH}, then for +one with name @code{GROFF_FONT_PATH}. (However, font searching has its +own list of esoteric search rules.) + +@item +The configuration file path, which is itself determined by the +following rules: + +@enumerate a +@item +If the command line contains an option of the form @samp{-B @var{path}} +or @samp{--config-dir=@var{path}}, then the value given on the +rightmost occurrence of such an option is used. + +@item +Otherwise, if the environment variable @code{STAT_CONFIG_PATH} is +defined, the value of that variable is used. + +@item +Otherwise, the compiled-in fallback default is used. On UNIX machines, +the default fallback path is + +@enumerate 1 +@item +@file{~/.pspp} + +@item +@file{/usr/local/lib/pspp} + +@item +@file{/usr/lib/pspp} +@end enumerate + +On DOS machines, the default fallback path is: + +@enumerate 1 +@item +All the paths from the DOS search path in the @samp{PATH} environment +variable, in left-to-right order. + +@item +@file{C:\PSPP}, as a last resort. +@end enumerate + +Note that the installer of PSPP can easily change this default +fallback path; thus the above should not be taken as gospel. +@end enumerate +@end itemize +@end enumerate + +As a final note: Under DOS, directories given in paths are delimited by +semicolons (@samp{;}); under UNIX, directories are delimited by colons +(@samp{:}). This corresponds with the standard path delimiter under +these OSes. + +@node Configuration techniques, Configuration files, File locations, Configuration +@section Configuration techniques + +There are many ways that PSPP can be configured. These are +described in the list below. Values given by earlier items take +precedence over those given by later items. + +@enumerate +@item +Syntax commands that modify settings, such as @code{SET}. + +@item +Command-line options. @xref{Invocation}. + +@item +PSPP-specific environment variable contents. @xref{Environment +variables}. + +@item +General environment variable contents. @xref{Environment variables}. + +@item +Configuration file contents. @xref{Configuration files}. + +@item +Fallback defaults. +@end enumerate + +Some of the above may not apply to a particular setting. For instance, +the current pager (such as @samp{more}, @samp{most}, or @samp{less}) +cannot be determined by configuration file contents because there is no +appropriate configuration file. + +@node Configuration files, Environment variables, Configuration techniques, Configuration +@section Configuration files + +Most configuration files have a common form: + +@itemize @bullet +@item +Each line forms a separate command or directive. This means that lines +cannot be broken up, unless they are spliced together with a trailing +backslash, as described below. + +@item +Before anything else is done, trailing whitespace is removed. + +@item +When a line ends in a backslash (@samp{\}), the backslash is removed, +and the next line is read and appended to the current line. + +@itemize @minus +@item +Whitespace preceding the backslash is retained. + +@item +This rule continues to be applied until the line read does not end in a +backslash. + +@item +It is an error if the last line in the file ends in a backslash. +@end itemize + +@item +Comments are introduced by an octothorpe (#), and continue until the +end of the line. + +@itemize @minus +@item +An octothorpe inside balanced pairs of double quotation marks (@samp{"}) +or single quotation marks (@samp{'}) does not introduce a comment. + +@item +The backslash character can be used inside balanced quotes of either +type to escape the following character as a literal character. + +(This is distinct from the use of a backslash as a line-splicing +character.) + +@item +Line splicing takes place before comment removal. +@end itemize + +@item +Blank lines, and lines that contain only whitespace, are ignored. +@end itemize + +@node Environment variables, Output devices, Configuration files, Configuration +@section Environment variables + +You may think the concept of environment variables is a fairly simple +one. However, the author of PSPP has found a way to complicate +even something so simple. Environment variables are further described +in the sections below: + +@menu +* Variable values:: Values of variables are determined this way. +* Environment substitutions:: How environment substitutions are made. +* Predefined variables:: A few variables are automatically defined. +@end menu + +@node Variable values, Environment substitutions, Environment variables, Environment variables +@subsection Values of environment variables + +Values for environment variables are obtained by the following means, +which are arranged in order of decreasing precedence: + +@enumerate +@item +Command-line options. @xref{Invocation}. + +@item +The @file{environment} configuration file---more on this below. + +@item +Actual environment variables (defined in the shell or other parent +process). +@end enumerate + +The @file{environment} configuration file is located through application +of the usual algorithm for configuration files (@pxref{File locations}), +except that its contents do not affect the search path used to find +@file{environment} itself. Use of @file{environment} is discouraged on +systems that allow an arbitrarily large environment; it is supported for +use on systems like MS-DOS that limit environment size. + +@file{environment} is composed of lines having the form +@samp{@var{key}=@var{value}}, where @var{key} and the equals sign +(@samp{=}) are required, and @var{value} is optional. If @var{value} is +given, variable @var{key} is given that value; if @var{value} is absent, +variable @var{key} is undefined (deleted). Variables may not be defined +with a null value. + +Environment substitutions are performed on each line in the file +(@pxref{Environment substitutions}). + +See @ref{Configuration files}, for more details on formatting of the +environment configuration file. + +@quotation +@strong{Please note:} Support for @file{environment} is not yet +implemented. +@end quotation + +@node Environment substitutions, Predefined variables, Variable values, Environment variables +@subsection Environment substitutions + +Much of the power of environment variables lies in the way that they may +be substituted into configuration files. Variable substitutions are +described below. + +The line is scanned from left to right. In this scan, all characters +other than dollar signs (@samp{$}) are retained unmolested. Dollar +signs, however, introduce an environment variable reference. References +take three forms: + +@table @code +@item $@var{var} +Replaced by the value of environment variable @var{var}, determined as +specified in @ref{Variable values}. @var{var} must be one of the +following: + +@itemize @bullet +@item +One or more letters. + +@item +Exactly one nonalphabetic character. This may not be a left brace +(@samp{@{}). +@end itemize + +@item $@{@var{var}@} +Same as above, but @var{var} may contain any character (except +@samp{@}}). + +@item $$ +Replaced by a single dollar sign. +@end table + +Undefined variables expand to a empty value. + +@node Predefined variables, , Environment substitutions, Environment variables +@subsection Predefined environment variables + +There are two environment variables predefined for use in environment +substitutions: + +@table @samp +@item VER +Defined as the version number of PSPP, as a string, in a format +something like @samp{0.9.4}. + +@item ARCH +Defined as the host architecture of PSPP, as a string, in standard +cpu-manufacturer-OS format. For instance, Debian GNU/Linux 1.1 on an +Intel machine defines this as @samp{i586-unknown-linux}. This is +somewhat dependent on the system used to compile PSPP. +@end table + +Nothing prevents these values from being overridden, although it's a +good idea not to do so. + +@node Output devices, PostScript driver class, Environment variables, Configuration +@section Output devices + +Configuring output devices is the most complicated aspect of configuring +PSPP. The output device configuration file is named +@file{devices}. It is searched for using the usual algorithm for +finding configuration files (@pxref{File locations}). Each line in the +file is read in the usual manner for configuration files +(@pxref{Configuration files}). + +Lines in @file{devices} are divided into three categories, described +briefly in the table below: + +@table @i +@item driver category definitions +Define a driver in terms of other drivers. + +@item macro definitions +Define environment variables local to the the output driver +configuration file. + +@item device definitions +Describe the configuration of an output device. +@end table + +The following sections further elaborate the contents of the +@file{devices} file. + +@menu +* Driver categories:: How to organize the driver namespace. +* Macro definitions:: Environment variables local to @file{devices}. +* Device definitions:: Output device descriptions. +* Dimensions:: Lengths, widths, sizes, @enddots{} +* papersize:: Letter, legal, A4, envelope, @enddots{} +* Distinguishing line types:: Details on @file{devices} parsing. +* Tokenizing lines:: Dividing @file{devices} lines into tokens. +@end menu + +@node Driver categories, Macro definitions, Output devices, Output devices +@subsection Driver categories + +Drivers can be divided into categories. Drivers are specified by their +names, or by the names of the categories that they are contained in. +Only certain drivers are enabled each time PSPP is run; by +default, these are the drivers in the category `default'. To enable a +different set of drivers, use the @samp{-o @var{device}} command-line +option (@pxref{Invocation}). + +Categories are specified with a line of the form +@samp{@var{category}=@var{driver1} @var{driver2} @var{driver3} @var{@dots{}} +@var{driver@var{n}}}. This line specifies that the category +@var{category} is composed of drivers named @var{driver1}, +@var{driver2}, and so on. There may be any number of drivers in the +category, from zero on up. + +Categories may also be specified on the command line +(@pxref{Invocation}). + +This is all you need to know about categories. If you're still curious, +read on. + +First of all, the term `categories' is a bit of a misnomer. In fact, +the internal representation is nothing like the hierarchy that the term +seems to imply: a linear list is used to keep track of the enabled +drivers. + +When PSPP first begins reading @file{devices}, this list contains +the name of any drivers or categories specified on the command line, or +the single item `default' if none were specified. + +Each time a category definition is specified, the list is searched for +an item with the value of @var{category}. If a matching item is found, +it is deleted. If there was a match, the list of drivers (@var{driver1} +through @var{driver@var{n}}) is then appended to the list. + +Each time a driver definition line is encountered, the list is searched. +If the list contains an item with that driver's name, the driver is +enabled and the item is deleted from the list. Otherwise, the driver +is not enabled. + +It is an error if the list is not empty when the end of @file{devices} +is reached. + +@node Macro definitions, Device definitions, Driver categories, Output devices +@subsection Macro definitions + +Macro definitions take the form @samp{define @var{macroname} +@var{definition}}. In such a macro definition, the environment variable +@var{macroname} is defined to expand to the value @var{definition}. +Before the definition is made, however, any macros used in +@var{definition} are expanded. + +Please note the following nuances of macro usage: + +@itemize @bullet +@item +For the purposes of this section, @dfn{macro} and @dfn{environment +variable} are synonyms. + +@item +Macros may not take arguments. + +@item +Macros may not recurse. + +@item +Macros are just environment variable definitions like other environment +variable definitions, with the exception that they are limited in scope +to the @file{devices} configuration file. + +@item +Macros override other all environment variables of the same name (within +the scope of @file{devices}). + +@item +Earlier macro definitions for a particular @var{key} override later +ones. In particular, macro definitions on the command line override +those in the device definition file. @xref{Non-option Arguments}. + +@item +There are two predefined macros, whose values are determined at runtime: + +@table @samp +@item viewwidth +Defined as the width of the console screen, in columns of text. + +@item viewlength +Defined as the length of the console screen, in lines of text. +@end table +@end itemize + +@node Device definitions, Dimensions, Macro definitions, Output devices +@subsection Driver definitions + +Driver definitions are the ultimate purpose of the @file{devices} +configuration file. These are where the real action is. Driver +definitions tell PSPP where it should send its output. + +Each driver definition line is divided into four fields. These fields +are delimited by colons (@samp{:}). Each line is subjected to +environment variable interpolation before it is processed further +(@pxref{Environment substitutions}). From left to right, the four +fields are, in brief: + +@table @i +@item driver name +A unique identifier, used to determine whether to enable the driver. + +@item class name +One of the predefined driver classes supported by PSPP. The +currently supported driver classes include `postscript' and `ascii'. + +@item device type(s) +Zero or more of the following keywords, delimited by spaces: + +@table @code +@item screen + +Indicates that the device is a screen display. This may reduce the +amount of buffering done by the driver, to make interactive use more +convenient. + +@item printer + +Indicates that the device is a printer. + +@item listing + +Indicates that the device is a listing file. +@end table + +These options are just hints to PSPP and do not cause the output to be +directed to the screen, or to the printer, or to a listing file---those +must be set elsewhere in the options. They are used primarily to decide +which devices should be enabled at any given time. @xref{SET}, for more +information. + +@item options +An optional set of options to pass to the driver itself. The exact +format for the options varies among drivers. +@end table + +The driver is enabled if: + +@enumerate +@item +Its driver name is specified on the command line, or + +@item +It's in a category specified on the command line, or + +@item +If no categories or driver names are specified on the command line, it +is in category @code{default}. +@end enumerate + +For more information on driver names, see @ref{Driver categories}. + +The class name must be one of those supported by PSPP. The +classes supported depend on the options with which PSPP was +compiled. See later sections in this chapter for descriptions of the +available driver classes. + +Options are dependent on the driver. See the driver descriptions for +details. + +@node Dimensions, papersize, Device definitions, Output devices +@subsection Dimensions + +Quite often in configuration it is necessary to specify a length or a +size. PSPP uses a common syntax for all such, calling them +collectively by the name @dfn{dimensions}. + +@itemize @bullet +@item +You can specify dimensions in decimal form (@samp{12.5}) or as +fractions, either as mixed numbers (@samp{12-1/2}) or raw fractions +(@samp{25/2}). + +@item +A number of different units are available. These are suffixed to the +numeric part of the dimension. There must be no spaces between the +number and the unit. The available units are identical to those offered +by the popular typesetting system @TeX{}: + +@table @code +@item in +inch (1 @code{in} = 2.54 @code{cm}) + +@item " +inch (1 @code{in} = 2.54 @code{cm}) + +@item pt +printer's point (1 @code{in} = 72.27 @code{pt}) + +@item pc +pica (12 @code{pt} = 1 @code{pc}) + +@item bp +PostScript point (1 @code{in} = 72 @code{bp}) + +@item cm +centimeter + +@item mm +millimeter (10 @code{mm} = 1 @code{cm}) + +@item dd +didot point (1157 @code{dd} = 1238 @code{pt}) + +@item cc +cicero (1 @code{cc} = 12 @code{dd}) + +@item sp +scaled point (65536 @code{sp} = 1 @code{pt}) +@end table + +@item +If no explicit unit is given, a DWIM@footnote{Do What I Mean} +``feature'' attempts to guess the best unit: + +@itemize @minus +@item +Numbers less than 50 are assumed to be in inches. + +@item +Numbers 50 or greater are assumed to be in millimeters. +@end itemize +@end itemize + +@node papersize, Distinguishing line types, Dimensions, Output devices +@subsection Paper sizes + +Output drivers usually deal with some sort of hardcopy media. This +media is called @dfn{paper} by the drivers, though in reality it could +be a transparency or film or thinly veiled sarcasm. To make it easier +for you to deal with paper, PSPP allows you to have (of course!) a +configuration file that gives symbolic names, like ``letter'' or +``legal'' or ``a4'', to paper sizes, rather than forcing you to use +cryptic numbers like ``8-1/2 x 11'' or ``210 by 297''. Surprisingly +enough, this configuration file is named @file{papersize}. +@xref{Configuration files}. + +When PSPP tries to connect a symbolic paper name to a paper size, it +reads and parses each non-comment line in the file, in order. The first +field on each line must be a symbolic paper name in double quotes. +Paper names may not contain double quotes. Paper names are not +case-sensitive: @samp{legal} and @samp{Legal} are equivalent. + +If a match is found for the paper name, the rest of the line is parsed. +If it is found to be a pair of dimensions (@pxref{Dimensions}) separated +by either @samp{x} or @samp{by}, then those are taken to be the paper +size, in order of width followed by length. There @emph{must} be at +least one space on each side of @samp{x} or @samp{by}. + +Otherwise the line must be of the form +@samp{"@var{paper-1}"="@var{paper-2}"}. In this case the target of the +search becomes paper name @var{paper-2} and the search through the file +continues. + +@node Distinguishing line types, Tokenizing lines, papersize, Output devices +@subsection How lines are divided into types + +The lines in @file{devices} are distinguished in the following manner: + +@enumerate +@item +Leading whitespace is removed. + +@item +If the resulting line begins with the exact string @code{define}, +followed by one or more whitespace characters, the line is processed as +a macro definition. + +@item +Otherwise, the line is scanned for the first instance of a colon +(@samp{:}) or an equals sign (@samp{=}). + +@item +If a colon is encountered first, the line is processed as a driver +definition. + +@item +Otherwise, if an equals sign is encountered, the line is processed as a +macro definition. + +@item +Otherwise, the line is ill-formed. +@end enumerate + +@node Tokenizing lines, , Distinguishing line types, Output devices +@subsection How lines are divided into tokens + +Each driver definition line is run through a simple tokenizer. This +tokenizer recognizes two basic types of tokens. + +The first type is an equals sign (@samp{=}). Equals signs are both +delimiters between tokens and tokens in themselves. + +The second type is an identifier or string token. Identifiers and +strings are equivalent after tokenization, though they are written +differently. An identifier is any string of characters other than +whitespace or equals sign. + +A string is introduced by a single- or double-quote character (@samp{'} +or @samp{"}) and, in general, continues until the next occurrence of +that same character. The following standard C escapes can also be +embedded within strings: + +@table @code +@item \' +A single-quote (@samp{'}). + +@item \" +A double-quote (@samp{"}). + +@item \? +A question mark (@samp{?}). Included for hysterical raisins. + +@item \\ +A backslash (@samp{\}). + +@item \a +Audio bell (ASCII 7). + +@item \b +Backspace (ASCII 8). + +@item \f +Formfeed (ASCII 12). + +@item \n +Newline (ASCII 10) + +@item \r +Carriage return (ASCII 13). + +@item \t +Tab (ASCII 9). + +@item \v +Vertical tab (ASCII 11). + +@item \@var{o}@var{o}@var{o} +Each @samp{o} must be an octal digit. The character is the one having +the octal value specified. Any number of octal digits is read and +interpreted; only the lower 8 bits are used. + +@item \x@var{h}@var{h} +Each @samp{h} must be a hex digit. The character is the one having the +hexadecimal value specified. Any number of hex digits is read and +interpreted; only the lower 8 bits are used. +@end table + +Tokens, outside of quoted strings, are delimited by whitespace or equals +signs. + +@node PostScript driver class, ASCII driver class, Output devices, Configuration +@section The PostScript driver class + +The @code{postscript} driver class is used to produce output that is +acceptable to PostScript printers and to PC-based PostScript +interpreters such as Ghostscript. Continuing a long tradition, +PSPP's PostScript driver is configurable to the point of +absurdity. + +There are actually two PostScript drivers. The first one, +@samp{postscript}, produces ordinary DSC-compliant PostScript output. +The second one @samp{epsf}, produces an Encapsulated PostScript file. +The two drivers are otherwise identical in configuration and in +operation. + +The PostScript driver is described in further detail below. + +@menu +* PS output options:: Output file options. +* PS page options:: Paper, margins, scaling & rotation, more! +* PS file options:: Configuration files. +* PS font options:: Default fonts, font options. +* PS line options:: Line widths, options. +* Prologue:: Details on the PostScript prologue. +* Encodings:: Details on PostScript font encodings. +@end menu + +@node PS output options, PS page options, PostScript driver class, PostScript driver class +@subsection PostScript output options + +These options deal with the form of the output and the output file +itself: + +@table @code +@item output-file=@var{filename} + +File to which output should be sent. This can be an ordinary filename +(i.e., @code{"pspp.ps"}), a pipe filename (i.e., @code{"|lpr"}), or +stdout (@code{"-"}). Default: @code{"pspp.ps"}. + +@item color=@var{boolean} + +Most of the time black-and-white PostScript devices are smart enough to +map colors to shades themselves. However, you can cause the PSPP +output driver to do an ugly simulation of this in its own driver by +turning @code{color} off. Default: @code{on}. + +This is a boolean setting, as are many settings in the PostScript +driver. Valid positive boolean values are @samp{on}, @samp{true}, +@samp{yes}, and nonzero integers. Negative boolean values are +@samp{off}, @samp{false}, @samp{no}, and zero. + +@item data=@var{data-type} + +One of @code{clean7bit}, @code{clean8bit}, or @code{binary}. This +controls what characters will be written to the output file. PostScript +produced with @code{clean7bit} can be transmitted over 7-bit +transmission channels that use ASCII control characters for line +control. @code{clean8bit} is similar but allows characters above 127 to +be written to the output file. @code{binary} allows any character in +the output file. Default: @code{clean7bit}. + +@item line-ends=@var{line-end-type} + +One of @code{cr}, @code{lf}, or @code{crlf}. This controls what is used +for newline in the output file. Default: @code{cr}. + +@item optimize-line-size=@var{level} + +Either @code{0} or @code{1}. If @var{level} is @code{1}, then short +line segments will be collected and merged into longer ones. This +reduces output file size but requires more time and memory. A +@var{level} of @code{0} has the advantage of being better for +interactive environments. @code{1} is the default unless the +@code{screen} flag is set; in that case, the default is @code{0}. + +@item optimize-text-size=@var{level} + +One of @code{0}, @code{1}, or @code{2}, each higher level representing +correspondingly more aggressive space savings for text in the output +file and requiring correspondingly more time and memory. Unfortunately +the levels presently are all the same. @code{1} is the default unless +the @code{screen} flag is set; in that case, the default is @code{0}. +@end table + +@node PS page options, PS file options, PS output options, PostScript driver class +@subsection PostScript page options + +These options affect page setup: + +@table @code +@item headers=@var{boolean} + +Controls whether the standard headers showing the time and date and +title and subtitle are printed at the top of each page. Default: +@code{on}. + +@item paper-size=@var{paper-size} + +Paper size, either as a symbolic name (i.e., @code{letter} or @code{a4}) +or specific measurements (i.e., @code{8-1/2x11} or @code{"210 x 297"}. +@xref{papersize, , Paper sizes}. Default: @code{letter}. + +@item orientation=@var{orientation} + +Either @code{portrait} or @code{landscape}. Default: @code{portrait}. + +@item left-margin=@var{dimension} +@itemx right-margin=@var{dimension} +@itemx top-margin=@var{dimension} +@itemx bottom-margin=@var{dimension} + +Sets the margins around the page. The headers, if enabled, are not +included in the margins; they are in addition to the margins. For a +description of dimensions, see @ref{Dimensions}. Default: @code{0.5in}. + +@end table + +@node PS file options, PS font options, PS page options, PostScript driver class +@subsection PostScript file options + +Oh, my. You don't really want to know about the way that the PostScript +driver deals with files, do you? Well I suppose you're entitled, but I +warn you right now: it's not pretty. Here goes@enddots{} + +First let's look at the options that are available: + +@table @code + +@item font-dir=@var{font-directory} + +Sets the font directory. Default: @code{devps}. + +@item prologue-file=@var{prologue-file-name} + +Sets the name of the PostScript prologue file. You can write your own +prologue, though I have no idea why you'd want to: see @ref{Prologue}. +Default: @code{ps-prologue}. + +@item device-file=@var{device-file-name} + +Sets the name of the Groff-format device description file. The +PostScript driver reads this in order to know about the scaling of fonts +and so on. The format of such files is described in groff_font(5), +included with Groff. Default: @code{DESC}. + +@item encoding-file=@var{encoding-file-name} + +Sets the name of the encoding file. This file contains a list of all +font encodings that will be needed so that the driver can put all of +them at the top of the prologue. @xref{Encodings}. Default: +@code{ps-encodings}. + +If the specified encoding file cannot be found, this error will be +silently ignored, since most people do not need any encodings besides +the ones that can be found using @code{auto-encodings}, described below. + +@item auto-encode=@var{boolean} + +When enabled, the font encodings needed by the default proportional- and +fixed-pitch fonts will automatically be dumped to the PostScript +output. Otherwise, it is assumed that the user has an encoding file +and knows how to use it (@pxref{Encodings}). There is probably no good +reason to turn off this convenient feature. Default: @code{on}. + +@end table + +Next I suppose it's time to describe the search algorithm. When the +PostScript driver needs a file, whether that file be a font, a +PostScript prologue, or what you will, it searches in this manner: + +@enumerate + +@item +Constructs a path by taking the first of the following that is defined: + +@enumerate a + +@item +Environment variable @code{STAT_GROFF_FONT_PATH}. @xref{Environment +variables}. + +@item +Environment variable @code{GROFF_FONT_PATH}. + +@item +The compiled-in fallback default. +@end enumerate + +@item +Constructs a base name from concatenating, in order, the font directory, +a path separator (@samp{/} or @samp{\}), and the file to be found. A +typical base name would be something like @code{devps/ps-encodings}. + +@item +Searches for the base name in the path constructed above. If the file +is found, the algorithm terminates. + +@item +Searches for the base name in the standard configuration path. See +@ref{File locations}, for more details. If the file is found, the +algorithm terminates. + +@item +At this point we remove the font directory and path separator from the +base name. Now the base name is simply the file to be found, i.e., +@code{ps-encodings}. + +@item +Searches for the base name in the path constructed in the first step. +If the file is found, the algorithm terminates. + +@item +Searches for the base name in the standard configuration path. If the +file is found, the algorithm terminates. + +@item +The algorithm terminates unsuccessfully. +@end enumerate + +So, as you see, there are several ways to configure the PostScript +drivers. Careful selection of techniques can make the configuration +very flexible indeed. + +@node PS font options, PS line options, PS file options, PostScript driver class +@subsection PostScript font options + +The list of available font options is short and sweet: + +@table @code +@item prop-font=@var{font-name} + +Sets the default proportional font. The name should be that of a +PostScript font. Default: @code{"Helvetica"}. + +@item fixed-font=@var{font-name} + +Sets the default fixed-pitch font. The name should be that of a +PostScript font. Default: @code{"Courier"}. + +@item font-size=@var{font-size} + +Sets the size of the default fonts, in thousandths of a point. Default: +@code{10000}. + +@end table + +@node PS line options, Prologue, PS font options, PostScript driver class +@subsection PostScript line options + +Most tables contain lines, or rules, between cells. Some features of +the way that lines are drawn in PostScript tables are user-definable: + +@table @code + +@item line-style=@var{style} + +Sets the style used for lines used to divide tables into sections. +@var{style} must be either @code{thick}, in which case thick lines are +used, or @var{double}, in which case double lines are used. Default: +@code{thick}. + +@item line-gutter=@var{dimension} + +Sets the line gutter, which is the amount of whitespace on either side +of lines that border text or graphics objects. @xref{Dimensions}. +Default: @code{0.5pt}. + +@item line-spacing=@var{dimension} + +Sets the line spacing, which is the amount of whitespace that separates +lines that are side by side, as in a double line. Default: +@code{0.5pt}. + +@item line-width=@var{dimension} + +Sets the width of a typical line used in tables. Default: @code{0.5pt}. + +@item line-width-thick=@var{dimension} + +Sets the width of a thick line used in tables. Not used if +@code{line-style} is set to @code{thick}. Default: @code{1.5pt}. + +@end table + +@node Prologue, Encodings, PS line options, PostScript driver class +@subsection The PostScript prologue + +Most PostScript files that are generated mechanically by programs +consist of two parts: a prologue and a body. The prologue is generally +a collection of boilerplate. Only the body differs greatly between +two outputs from the same program. + +This is also the strategy used in the PSPP PostScript driver. In +general, the prologue supplied with PSPP will be more than sufficient. +In this case, you will not need to read the rest of this section. +However, hackers might want to know more. Read on, if you fall into +this category. + +The prologue is dumped into the output stream essentially unmodified. +However, two actions are performed on its lines. First, certain lines +may be omitted as specified in the prologue file itself. Second, +variables are substituted. + +The following lines are omitted: + +@enumerate +@item +All lines that contain three bangs in a row (@code{!!!}). + +@item +Lines that contain @code{!eps}, if the PostScript driver is producing +ordinary PostScript output. Otherwise an EPS file is being produced, +and the line is included in the output, although everything following +@code{!eps} is deleted. + +@item +Lines that contain @code{!ps}, if the PostScript driver is producing EPS +output. Otherwise, ordinary PostScript is being produced, and the line +is included in the output, although everything following @code{!ps} is +deleted. +@end enumerate + +The following are the variables that are substituted. Only the +variables listed are substituted; environment variables are not. +@xref{Environment substitutions}. + +@table @code +@item bounding-box + +The page bounding box, in points, as four space-separated numbers. For +U.S. letter size paper, this is @samp{0 0 612 792}. + +@item creator + +PSPP version as a string: @samp{GNU PSPP 0.1b}, for example. + +@item date + +Date the file was created. Example: @samp{Tue May 21 13:46:22 1991}. + +@item data + +Value of the @code{data} PostScript driver option, as one of the strings +@samp{Clean7Bit}, @samp{Clean8Bit}, or @samp{Binary}. + +@item orientation + +Page orientation, as one of the strings @code{Portrait} or +@code{Landscape}. + +@item user + +Under multiuser OSes, the user's login name, taken either from the +environment variable @code{LOGNAME} or, if that fails, the result of the +C library function @code{getlogin()}. Defaults to @samp{nobody}. + +@item host + +System hostname as reported by @code{gethostname()}. Defaults to +@samp{nowhere}. + +@item prop-font + +Name of the default proportional font, prefixed by the word +@samp{font} and a space. Example: @samp{font Times-Roman}. + +@item fixed-font + +Name of the default fixed-pitch font, prefixed by the word @samp{font} +and a space. + +@item scale-factor + +The page scaling factor as a floating-point number. Example: +@code{1.0}. Note that this is also passed as an argument to the BP +macro. + +@item paper-length +@item paper-width + +The paper length and paper width, respectively, in thousandths of a +point. Note that these are also passed as arguments to the BP macro. + +@item left-margin +@item top-margin + +The left margin and top margin, respectively, in thousandths of a +point. Note that these are also passed as arguments to the BP macro. + +@item title + +Document title as a string. This is not the title specified in the +PSPP syntax file. A typical title is the word @samp{PSPP} followed +by the syntax file name in parentheses. Example: @samp{PSPP +()}. + +@item source-file + +PSPP syntax file name. Example: @samp{mary96/first.stat}. + +@end table + +Any other questions about the PostScript prologue can best be answered +by examining the default prologue or the PSPP source. + +@node Encodings, , Prologue, PostScript driver class +@subsection PostScript encodings + +PostScript fonts often contain many more than 256 characters, in order +to accommodate foreign language characters and special symbols. +PostScript uses @dfn{encodings} to map these onto single-byte symbol +sets. Each font can have many different encodings applied to it. + +PSPP's PostScript driver needs to know which encoding to apply to each +font. It can determine this from the information encapsulated in the +Groff font description that it reads. However, there is an additional +problem---for efficiency, the PostScript driver needs to have a complete +list of all encodings that will be used in the entire session @emph{when +it opens the output file}. For this reason, it can't use the +information built into the fonts because it doesn't know which fonts +will be used. + +As a stopgap solution, there are two mechanisms for specifying which +encodings will be used. The first mechanism is automatic and it is the +only one that most PSPP users will ever need. The second mechanism is +manual, but it is more flexible. Either mechanism or both may be used +at one time. + +The first mechanism is activated by the @samp{auto-encode} driver option +(@pxref{PS file options}). When enabled, @samp{auto-encode} causes the +PostScript driver to include the encodings used by the default +proportional and fixed-pitch fonts (@pxref{PS font options}). Many +PSPP output files will only need these encodings. + +The second mechanism is the file specified by the @samp{encoding-file} +option (@pxref{PS file options}). If it exists, this file must consist +of lines in PSPP configuration-file format (@pxref{Configuration +files}). Each line that is not a comment should name a PostScript +encoding to include in the output. + +It is not an error if an encoding is included more than once, by either +mechanism. It will appear only once in the output. It is also not an +error if an encoding is included in the output but never used. It +@emph{is} an error if an encoding is used but not included by one of +these mechanisms. In this case, the built-in PostScript encoding +@samp{ISOLatin1Encoding} is substituted. + +@node ASCII driver class, HTML driver class, PostScript driver class, Configuration +@section The ASCII driver class + +The ASCII driver class produces output that can be displayed on a +terminal or output to printers. All of its options are highly +configurable. The ASCII driver has class name @samp{ascii}. + +The ASCII driver is described in further detail below. + +@menu +* ASCII output options:: Output file options. +* ASCII page options:: Page size, margins, more. +* ASCII font options:: Box character, bold & italics. +@end menu + +@node ASCII output options, ASCII page options, ASCII driver class, ASCII driver class +@subsection ASCII output options + +@table @code +@item output-file=@var{filename} + +File to which output should be sent. This can be an ordinary filename +(i.e., @code{"pspp.ps"}), a pipe filename (i.e., @code{"|lpr"}), or +stdout (@code{"-"}). Default: @code{"pspp.list"}. + +@item char-set=@var{char-set-type} + +One of @samp{ascii} or @samp{latin1}. This has no effect on output at +the present time. Default: @code{ascii}. + +@item form-feed-string=@var{form-feed-value} + +The string written to the output to cause a formfeed. See also +@code{paginate}, described below, for a related setting. Default: +@code{"\f"}. + +@item newline-string=@var{newline-value} + +The string written to the output to cause a newline (carriage return +plus linefeed). The default, which can be specified explicitly with +@code{newline-string=default}, is to use the system-dependent newline +sequence by opening the output file in text mode. This is usually the +right choice. + +However, @code{newline-string} can be set to any string. When this is +done, the output file is opened in binary mode. + +@item paginate=@var{boolean} + +If set, a formfeed (as set in @code{form-feed-string}, described above) +will be written to the device after every page. Default: @code{on}. + +@item tab-width=@var{tab-width-value} + +The distance between tab stops for this device. If set to 0, tabs will +not be used in the output. Default: @code{8}. + +@item init=@var{initialization-string}. + +String written to the device before anything else, at the beginning of +the output. Default: @code{""} (the empty string). + +@item done=@var{finalization-string}. + +String written to the device after everything else, at the end of the +output. Default: @code{""} (the empty string). +@end table + +@node ASCII page options, ASCII font options, ASCII output options, ASCII driver class +@subsection ASCII page options + +These options affect page setup: + +@table @code +@item headers=@var{boolean} + +If enabled, two lines of header information giving title and subtitle, +page number, date and time, and PSPP version are printed at the top of +every page. These two lines are in addition to any top margin +requested. Default: @code{on}. + +@item length=@var{line-count} + +Physical length of a page, in lines. Headers and margins are subtracted +from this value. Default: @code{66}. + +@item width=@var{character-count} + +Physical width of a page, in characters. Margins are subtracted from +this value. Default: @code{130}. + +@item lpi=@var{lines-per-inch} + +Number of lines per vertical inch. Not currently used. Default: @code{6}. + +@item cpi=@var{characters-per-inch} + +Number of characters per horizontal inch. Not currently used. Default: +@code{10}. + +@item left-margin=@var{left-margin-width} + +Width of the left margin, in characters. PSPP subtracts this value +from the page width. Default: @code{0}. + +@item right-margin=@var{right-margin-width} + +Width of the right margin, in characters. PSPP subtracts this value +from the page width. Default: @code{0}. + +@item top-margin=@var{top-margin-lines} + +Length of the top margin, in lines. PSPP subtracts this value from +the page length. Default: @code{2}. + +@item bottom-margin=@var{bottom-margin-lines} + +Length of the bottom margin, in lines. PSPP subtracts this value from +the page length. Default: @code{2}. + +@end table + +@node ASCII font options, , ASCII page options, ASCII driver class +@subsection ASCII font options + +These are the ASCII font options: + +@table @code +@item box[@var{line-type}]=@var{box-chars} + +The characters used for lines in tables produced by the ASCII driver can +be changed using this option. @var{line-type} is used to indicate which +type of line to change; @var{box-chars} is the character or string of +characters to use for this type of line. + +@var{line-type} must be a 4-digit number in base 4. The digits are in +the order `right', `bottom', `left', `top'. The four possibilities for +each digit are: + +@table @asis +@item 0 +No line. + +@item 1 +Single line. + +@item 2 +Double line. + +@item 3 +Special device-defined line, if one is available; otherwise, a double +line. +@end table + +Examples: + +@table @code +@item box[0101]="|" + +Sets @samp{|} as the character to use for a single-width line with +bottom and top components. + +@item box[2222]="#" + +Sets @samp{#} as the character to use for the intersection of four +double-width lines, one each from the top, bottom, left and right. + +@item box[1100]="\xda" + +Sets @samp{"\xda"}, which under MS-DOG is a box character suitable for +the top-left corner of a box, as the character for the intersection of +two single-width lines, one each from the right and bottom. + +@end table + +Defaults: + +@itemize @bullet +@item +@code{box[0000]=" "} + +@item +@code{box[1000]="-"} +@*@code{box[0010]="-"} +@*@code{box[1010]="-"} + +@item +@code{box[0100]="|"} +@*@code{box[0001]="|"} +@*@code{box[0101]="|"} + +@item +@code{box[2000]="="} +@*@code{box[0020]="="} +@*@code{box[2020]="="} + +@item +@code{box[0200]="#"} +@*@code{box[0002]="#"} +@*@code{box[0202]="#"} + +@item +@code{box[3000]="="} +@*@code{box[0030]="="} +@*@code{box[3030]="="} + +@item +@code{box[0300]="#"} +@*@code{box[0003]="#"} +@*@code{box[0303]="#"} + +@item +For all others, @samp{+} is used unless there are double lines or +special lines, in which case @samp{#} is used. +@end itemize + +@item italic-on=@var{italic-on-string} + +Character sequence written to turn on italics or underline printing. If +this is set to @code{overstrike}, then the driver will simulate +underlining by overstriking with underscore characters (@samp{_}) in the +manner described by @code{overstrike-style} and +@code{carriage-return-style}. Default: @code{overstrike}. + +@item italic-off=@var{italic-off-string} + +Character sequence to turn off italics or underline printing. Default: +@code{""} (the empty string). + +@item bold-on=@var{bold-on-string} + +Character sequence written to turn on bold or emphasized printing. If +set to @code{overstrike}, then the driver will simulated bold printing +by overstriking characters in the manner described by +@code{overstrike-style} and @code{carriage-return-style}. Default: +@code{overstrike}. + +@item bold-off=@var{bold-off-string} + +Character sequence to turn off bold or emphasized printing. Default: +@code{""} (the empty string). + +@item bold-italic-on=@var{bold-italic-on-string} + +Character sequence written to turn on bold-italic printing. If set to +@code{overstrike}, then the driver will simulate bold-italics by +overstriking twice, once with the character, a second time with an +underscore (@samp{_}) character, in the manner described by +@code{overstrike-style} and @code{carriage-return-style}. Default: +@code{overstrike}. + +@item bold-italic-off=@var{bold-italic-off-string} + +Character sequence to turn off bold-italic printing. Default: @code{""} +(the empty string). + +@item overstrike-style=@var{overstrike-option} + +Either @code{single} or @code{line}: + +@itemize @bullet +@item +If @code{single} is selected, then, to overstrike a line of text, the +output driver will output a character, backspace, overstrike, output a +character, backspace, overstrike, and so on along a line. + +@item +If @code{line} is selected then the output driver will output an entire +line, then backspace or emit a carriage return (as indicated by +@code{carriage-return-style}), then overstrike the entire line at once. +@end itemize + +@code{single} is recommended for use with ttys and programs that +understand overstriking in text files, such as the pager @code{less}. +@code{single} will also work with printer devices but results in rapid +back-and-forth motions of the printhead that can cause the printer to +physically overheat! + +@code{line} is recommended for use with printer devices. Most programs +that understand overstriking in text files will not properly deal with +@code{line} mode. + +Default: @code{single}. + +@item carriage-return-style=@var{carriage-return-type} + +Either @code{bs} or @code{cr}. This option applies only when one or +more of the font commands is set to @code{overstrike} and, at the same +time, @code{overstrike-style} is set to @code{line}. + +@itemize @bullet +@item +If @code{bs} is selected then the driver will return to the beginning of +a line by emitting a sequence of backspace characters (ASCII 8). + +@item +If @code{cr} is selected then the driver will return to the beginning of +a line by emitting a single carriage-return character (ASCII 13). +@end itemize + +Although @code{cr} is preferred as being more compact, @code{bs} is more +general since some devices do not interpret carriage returns in the +desired manner. Default: @code{bs}. +@end table + +@node HTML driver class, Miscellaneous configuring, ASCII driver class, Configuration +@section The HTML driver class + +The @code{html} driver class is used to produce output for viewing in +tables-capable web browsers such as Emacs' w3-mode. Its configuration +is very simple. Currently, the output has a very plain format. In the +future, further work may be done on improving the output appearance. + +There are few options for use with the @code{html} driver class: + +@table @code +@item output-file=@var{filename} + +File to which output should be sent. This can be an ordinary filename +(i.e., @code{"pspp.ps"}), a pipe filename (i.e., @code{"|lpr"}), or +stdout (@code{"-"}). Default: @code{"pspp.html"}. + +@item prologue-file=@var{prologue-file-name} + +Sets the name of the PostScript prologue file. You can write your own +prologue if you want to customize colors or other settings: see +@ref{HTML Prologue}. Default: @code{html-prologue}. +@end table + +@menu +* HTML Prologue:: Format of the HTML prologue file. +@end menu + +@node HTML Prologue, , HTML driver class, HTML driver class +@subsection The HTML prologue + +HTML files that are generated by PSPP consist of two parts: a prologue +and a body. The prologue is a collection of boilerplate. Only the body +differs greatly between two outputs. You can tune the colors and other +attributes of the output by editing the prologue. + +The prologue is dumped into the output stream essentially unmodified. +However, two actions are performed on its lines. First, certain lines +may be omitted as specified in the prologue file itself. Second, +variables are substituted. + +The following lines are omitted: + +@enumerate +@item +All lines that contain three bangs in a row (@code{!!!}). + +@item +Lines that contain @code{!title}, if no title is set for the output. If +a title is set, then the characters @code{!title} are removed before the +line is output. + +@item +Lines that contain @code{!subtitle}, if no subtitle is set for the +output. If a subtitle is set, then the characters @code{!subtitle} are +removed before the line is output. +@end enumerate + +The following are the variables that are substituted. Only the +variables listed are substituted; environment variables are not. +@xref{Environment substitutions}. + +@table @code +@item generator + +PSPP version as a string: @samp{GNU PSPP 0.1b}, for example. + +@item date + +Date the file was created. Example: @samp{Tue May 21 13:46:22 1991}. + +@item user + +Under multiuser OSes, the user's login name, taken either from the +environment variable @code{LOGNAME} or, if that fails, the result of the +C library function @code{getlogin()}. Defaults to @samp{nobody}. + +@item host + +System hostname as reported by @code{gethostname()}. Defaults to +@samp{nowhere}. + +@item title + +Document title as a string. This is the title specified in the PSPP +syntax file. + +@item subtitle + +Document subtitle as a string. + +@item source-file + +PSPP syntax file name. Example: @samp{mary96/first.stat}. +@end table + +@node Miscellaneous configuring, Improving output quality, HTML driver class, Configuration +@section Miscellaneous configuration + +The following environment variables can be used to further configure +PSPP: + +@table @code +@item HOME + +Used to determine the user's home directory. No default value. + +@item STAT_INCLUDE_PATH + +Path used to find include files in PSPP syntax files. Defaults vary +across operating systems: + +@table @asis +@item UNIX + +@itemize @bullet +@item +@file{.} + +@item +@file{~/.pspp/include} + +@item +@file{/usr/local/lib/pspp/include} + +@item +@file{/usr/lib/pspp/include} + +@item +@file{/usr/local/share/pspp/include} + +@item +@file{/usr/share/pspp/include} +@end itemize + +@item MS-DOS + +@itemize @bullet +@item +@file{.} + +@item +@file{C:\PSPP\INCLUDE} + +@item +@file{$PATH} +@end itemize + +@item Other OSes +No default path. +@end table + +@item STAT_PAGER +@itemx PAGER + +When PSPP invokes an external pager, it uses the first of these that +is defined. There is a default pager only if the person who compiled +PSPP defined one. + +@item TERM + +The terminal type @code{termcap} or @code{ncurses} will use, if such +support was compiled into PSPP. + +@item STAT_OUTPUT_INIT_FILE + +The basename used to search for the driver definition file. +@xref{Output devices}. @xref{File locations}. Default: @code{devices}. + +@item STAT_OUTPUT_PAPERSIZE_FILE + +The basename used to search for the papersize file. @xref{papersize}. +@xref{File locations}. Default: @code{papersize}. + +@item STAT_OUTPUT_INIT_PATH + +The path used to search for the driver definition file and the papersize +file. @xref{File locations}. Default: the standard configuration path. + +@item TMPDIR + +The @code{sort} procedure stores its temporary files in this directory. +Default: (UNIX) @file{/tmp}, (MS-DOS) @file{\}, (other OSes) empty string. + +@item TEMP +@item TMP + +Under MS-DOS only, these variables are consulted after TMPDIR, in this +order. +@end table + +@node Improving output quality, , Miscellaneous configuring, Configuration +@section Improving output quality + +When its drivers are set up properly, PSPP can produce output that +looks very good indeed. The PostScript driver, suitably configured, can +produce presentation-quality output. Here are a few guidelines for +producing better-looking output, regardless of output driver. Your +mileage may vary, of course, and everyone has different esthetic +preferences. + +@itemize @bullet +@item +Width is important in PSPP output. Greater output width leads to more +readable output, to a point. Try the following to increase the output +width: + +@itemize @minus +@item +If you're using the ASCII driver with a dot-matrix printer, figure out +what you need to do to put the printer into compressed mode. Put that +string into the @code{init-string} setting. Try to get 132 columns; 160 +might be better, but you might find that print that tiny is difficult to +read. + +@item +With the PostScript driver, try these ideas: + +@itemize + +@item +Landscape mode. + +@item +Legal-size (8.5" x 14") paper in landscape mode. + +@item +Reducing font sizes. If you're using 12-point fonts, try 10 point; if +you're using 10-point fonts, try 8 point. Some fonts are more readable +than others at small sizes. +@end itemize +@end itemize + +Try to strike a balance between character size and page width. + +@item +Use high-quality fonts. Many public domain fonts are poor in quality. +Recently, URW made some high-quality fonts available under the GPL. +These are probably suitable. + +@item +Be sure you're using the proper font metrics. The font metrics provided +with PSPP may not correspond to the fonts actually being printed. +This can cause bizarre-looking output. + +@item +Make sure that you're using good ink/ribbon/toner. Darker print is +easier to read. + +@item +Use plain fonts with serifs, such as Times-Roman or Palatino. Avoid +choosing italic or bold fonts as document base fonts. +@end itemize + +@node Invocation, Language, Configuration, Top +@chapter Invoking PSPP +@cindex invocation +@cindex PSPP, invoking + +@cindex command line, options +@cindex options, command-line +@example +pspp [ -B @var{dir} | --config-dir=@var{dir} ] [ -o @var{device} | --device=@var{device} ] + [ -d @var{var}[=@var{value}] | --define=@var{var}[=@var{value}] ] [-u @var{var} | --undef=@var{var} ] + [ -f @var{file} | --out-file=@var{file} ] [ -p | --pipe ] [ -I- | --no-include ] + [ -I @var{dir} | --include=@var{dir} ] [ -i | --interactive ] + [ -n | --edit | --dry-run | --just-print | --recon ] + [ -r | --no-statrc ] [ -h | --help ] [ -l | --list ] + [ -c @var{command} | --command @var{command} ] [ -s | --safer ] + [ --testing-mode ] [ -V | --version ] [ -v | --verbose ] + [ @var{key}=@var{value} ] @var{file}@enddots{} +@end example + +@menu +* Non-option Arguments:: Specifying syntax files and output devices. +* Configuration Options:: Change the configuration for the current run. +* Input and output options:: Controlling input and output files. +* Language control options:: Language variants. +* Informational options:: Helpful information about PSPP. +@end menu + +@node Non-option Arguments, Configuration Options, Invocation, Invocation +@section Non-option Arguments + +Syntax files and output device substitutions can be specified on +PSPP's command line: + +@table @code +@item @var{file} + +A file by itself on the command line will be executed as a syntax file. +PSPP terminates after the syntax file runs, unless the @code{-i} or +@code{--interactive} option is given (@pxref{Language control options}). + +@item @var{file1} @var{file2} + +When two or more filenames are given on the command line, the first +syntax file is executed, then PSPP's dictionary is cleared, then the second +syntax file is executed. + +@item @var{file1} + @var{file2} + +If syntax files' names are delimited by a plus sign (@samp{+}), then the +dictionary is not cleared between their executions, as if they were +concatenated together into a single file. + +@item @var{key}=@var{value} + +Defines an output device macro @var{key} to expand to @var{value}, +overriding any macro having the same @var{key} defined in the device +configuration file. @xref{Macro definitions}. + +@end table + +There is one other way to specify a syntax file, if your operating +system supports it. If you have a syntax file @file{foobar.stat}, put +the notation + +@example +#! /usr/local/bin/pspp +@end example + +at the top, and mark the file as executable with @code{chmod +x +foobar.stat}. (If PSPP is not installed in @file{/usr/local/bin}, +then insert its actual installation directory into the syntax file +instead.) Now you should be able to invoke the syntax file just by +typing its name. You can include any options on the command line as +usual. PSPP entirely ignores any lines beginning with @samp{#!}. + +@node Configuration Options, Input and output options, Non-option Arguments, Invocation +@section Configuration Options + +Configuration options are used to change PSPP's configuration for the +current run. The configuration options are: + +@table @code +@item -B @var{dir} +@itemx --config-dir=@var{dir} + +Sets the configuration directory to @var{dir}. @xref{File locations}. + +@item -o @var{device} +@itemx --device=@var{device} + +Selects the output device with name @var{device}. If this option is +given more than once, then all devices mentioned are selected. This +option disables all devices besides those mentioned on the command line. + +@item -d @var{var}[=@var{value}] +@itemx --define=@var{var}[=@var{value}] + +Defines an `environment variable' named @var{var} having the optional +value @var{value} specified. @xref{Variable values}. + +@item -u @var{var} +@itemx --undef=@var{var} + +Undefines the `environment variable' named @var{var}. @xref{Variable +values}. +@end table + +@node Input and output options, Language control options, Configuration Options, Invocation +@section Input and output options + +Input and output options affect how PSPP reads input and writes +output. These are the input and output options: + +@table @code +@item -f @var{file} +@itemx --out-file=@var{file} + +This overrides the output file name for devices designated as listing +devices. If a file named @var{file} already exists, it is overwritten. + +@item -p +@itemx --pipe + +Allows PSPP to be used as a filter by causing the syntax file to be +read from stdin and output to be written to stdout. Conflicts with the +@code{-f @var{file}} and @code{--file=@var{file}} options. + +@item -I- +@itemx --no-include + +Clears all directories from the include path. This includes all +directories put in the include path by default. @xref{Miscellaneous +configuring}. + +@item -I @var{dir} +@itemx --include=@var{dir} + +Appends directory @var{dir} to the path that is searched for include +files in PSPP syntax files. + +@item -c @var{command} +@itemx --command=@var{command} + +Execute literal command @var{command}. The command is executed before +startup syntax files, if any. + +@item --testing-mode + +Invoke heuristics to assist with testing PSPP. For use by @code{make +check} and similar scripts. +@end table + +@node Language control options, Informational options, Input and output options, Invocation +@section Language control options + +Language control options control how PSPP syntax files are parsed and +interpreted. The available language control options are: + +@table @code +@item -i +@itemx --interactive + +When a syntax file is specified on the command line, PSPP normally +terminates after processing it. Giving this option will cause PSPP to +bring up a command prompt after processing the syntax file. + +In addition, this forces syntax files to be interpreted in interactive +mode, rather than the default batch mode. @xref{Tokenizing lines}, for +information on the differences between batch mode and interactive mode +command interpretation. + +@item -n +@itemx --edit +@itemx --dry-run +@itemx --just-print +@itemx --recon + +Only the syntax of any syntax file specified or of commands entered at +the command line is checked. Transformations are not performed and +procedures are not executed. Not yet implemented. + +@item -r +@itemx --no-statrc + +Prevents the execution of the PSPP startup syntax file. Not yet +implemented, as startup syntax files aren't, either. + +@item -s +@itemx --safer + +Disables certain unsafe operations. This includes the @code{ERASE} and +@code{HOST} commands, as well as use of pipes as input and output files. +@end table + +@node Informational options, , Language control options, Invocation +@section Informational options + +Informational options cause information about PSPP to be written to +the terminal. Here are the available options: + +@table @code +@item -h +@item --help + +Prints a message describing PSPP command-line syntax and the available +device driver classes, then terminates. + +@item -l +@item --list + +Lists the available device driver classes, then terminates. + +@item -V +@item --version + +Prints a brief message listing PSPP's version, warranties you don't +have, copying conditions and copyright, and e-mail address for bug +reports, then terminates. + +@item -v +@item --verbose + +Increments PSPP's verbosity level. Higher verbosity levels cause +PSPP to display greater amounts of information about what it is +doing. Often useful for debugging PSPP's configuration. + +This option can be given multiple times to set the verbosity level to +that value. The default verbosity level is 0, in which no informational +messages will be displayed. + +Higher verbosity levels cause messages to be displayed when the +corresponding events take place. + +@table @asis +@item 1 + +Driver and subsystem initializations. + +@item 2 + +Completion of driver initializations. Beginning of driver closings. + +@item 3 + +Completion of driver closings. + +@item 4 + +Files searched for; success of searches. + +@item 5 + +Individual directories included in file searches. +@end table + +Each verbosity level also includes messages from lower verbosity levels. + +@end table + +@node Language, Expressions, Invocation, Top +@chapter The PSPP language +@cindex language, PSPP +@cindex PSPP, language + +@quotation +@strong{Please note:} PSPP is not even close to completion. +Only a few actual statistical procedures are implemented. PSPP +is a work in progress. +@end quotation + +This chapter discusses elements common to many PSPP commands. +Later chapters will describe individual commands in detail. + +@menu +* Tokens:: Characters combine to form tokens. +* Commands:: Tokens combine to form commands. +* Types of Commands:: Commands come in several flavors. +* Order of Commands:: Commands combine to form syntax files. +* Missing Observations:: Handling missing observations. +* Variables:: The unit of data storage. +* Files:: Files used by PSPP. +* BNF:: How command syntax is described. +@end menu + +@node Tokens, Commands, Language, Language +@section Tokens +@cindex language, lexical analysis +@cindex language, tokens +@cindex tokens +@cindex lexical analysis +@cindex lexemes + +PSPP divides most syntax file lines into series of short chunks +called @dfn{tokens}, @dfn{lexical elements}, or @dfn{lexemes}. These +tokens are then grouped to form commands, each of which tells +PSPP to take some action---read in data, write out data, perform +a statistical procedure, etc. The process of dividing input into tokens +is @dfn{tokenization}, or @dfn{lexical analysis}. Each type of token is +described below. + +@cindex delimiters +@cindex whitespace +Tokens must be separated from each other by @dfn{delimiters}. +Delimiters include whitespace (spaces, tabs, carriage returns, line +feeds, vertical tabs), punctuation (commas, forward slashes, etc.), and +operators (plus, minus, times, divide, etc.) Note that while whitespace +only separates tokens, other delimiters are tokens in themselves. + +@table @strong +@cindex identifiers +@item Identifiers +Identifiers are names that specify variable names, commands, or command +details. + +@itemize @bullet +@item +The first character in an identifier must be a letter, @samp{#}, or +@samp{@@}. Some system identifiers begin with @samp{$}, but +user-defined variables' names may not begin with @samp{$}. + +@item +The remaining characters in the identifier must be letters, digits, or +one of the following special characters: + +@example +. _ $ # @@ +@end example + +@item +@cindex variable names +@cindex names, variable +Variable names may be any length, but only the first 8 characters are +significant. + +@item +@cindex case-sensitivity +Identifiers are not case-sensitive: @code{foobar}, @code{Foobar}, +@code{FooBar}, @code{FOOBAR}, and @code{FoObaR} are different +representations of the same identifier. + +@item +@cindex keywords +Identifiers other than variable names may be abbreviated to their first +3 characters if this abbreviation is unambiguous. These identifiers are +often called @dfn{keywords}. (Unique abbreviations of more than 3 +characters are also accepted: @samp{FRE}, @samp{FREQ}, and +@samp{FREQUENCIES} are equivalent when the last is a keyword.) + +@item +Whether an identifier is a keyword depends on the context. + +@item +@cindex keywords, reserved +@cindex reserved keywords +Some keywords are reserved. These keywords may not be used in any +context besides those explicitly described in this manual. The reserved +keywords are: + +@example +ALL AND BY EQ GE GT LE LT NE NOT OR TO WITH +@end example + +@item +Since keywords are identifiers, all the rules for identifiers apply. +Specifically, they must be delimited as are other identifiers: +@code{WITH} is a reserved keyword, but @code{WITHOUT} is a valid +variable name. +@end itemize + +@cindex @samp{.} +@cindex period +@cindex variable names, ending with period +@strong{Caution:} It is legal to end a variable name with a period, but +@emph{don't do it!} The variable name will be misinterpreted when it is +the final token on a line: @code{FOO.} will be divided into two separate +tokens, @samp{FOO} and @samp{.}, the @dfn{terminal dot}. +@xref{Commands, , Forming commands of tokens}. + +@item Numbers +@cindex numbers +@cindex integers +@cindex reals +Numbers may be specified as integers or reals. Integers are internally +converted into reals. Scientific notation is not supported. Here are +some examples of valid numbers: + +@example +1234 3.14159265359 .707106781185 8945. +@end example + +@strong{Caution:} The last example will be interpreted as two tokens, +@samp{8945} and @samp{.}, if it is the last token on a line. + +@item Strings +@cindex strings +@cindex @samp{'} +@cindex @samp{"} +@cindex case-sensitivity +Strings are literal sequences of characters enclosed in pairs of single +quotes (@samp{'}) or double quotes (@samp{"}). + +@itemize @bullet +@item +Whitespace and case of letters @emph{are} significant inside strings. +@item +Whitespace characters inside a string are not delimiters. +@item +To include single-quote characters in a string, enclose the string in +double quotes. +@item +To include double-quote characters in a string, enclose the string in +single quotes. +@item +It is not possible to put both single- and double-quote characters +inside one string. +@end itemize + +@item Hexstrings +@cindex hexstrings +Hexstrings are string variants that use hex digits to specify +characters. + +@itemize @bullet +@item +A hexstring may be used anywhere that an ordinary string is allowed. + +@item +@cindex @samp{X'} +@cindex @samp{'} +A hexstring begins with @samp{X'} or @samp{x'}, and ends with @samp{'}. + +@cindex whitespace +@item +No whitespace is allowed between the initial @samp{X} and @samp{'}. + +@item +Double quotes @samp{"} may be used in place of single quotes @samp{'} if +done in both places. + +@item +Each pair of hex digits is internally changed into a single character +with the given value. + +@item +If there is an odd number of hex digits, the missing last digit is +assumed to be @samp{0}. + +@item +@cindex portability +@strong{Please note:} Use of hexstrings is nonportable because the same +numeric values are associated with different glyphs by different +operating systems. Therefore, their use should be confined to syntax +files that will not be widely distributed. + +@item +@cindex characters, reserved +@cindex 0 +@cindex whitespace +@strong{Please note also:} The character with value 00 is reserved for +internal use by PSPP. Its use in strings causes an error and +replacement with a blank space (in ASCII, hex 20, decimal 32). +@end itemize + +@item Punctuation +@cindex punctuation +Punctuation separates tokens; punctuators are delimiters. These are the +punctuation characters: + +@example +, / = ( ) +@end example + +@item Operators +@cindex operators +Operators describe mathematical operations. Some operators are delimiters: + +@example +( ) + - * / ** +@end example + +Many of the above operators are also punctuators. Punctuators are +distinguished from operators by context. + +The other operators are all reserved keywords. None of these are +delimiters: + +@example +AND EQ GE GT LE LT NE OR +@end example + +@item Terminal Dot +@cindex terminal dot +@cindex dot, terminal +@cindex period +@cindex @samp{.} +A period (@samp{.}) at the end of a line (except for whitespace) is one +type of a @dfn{terminal dot}, although not every terminal dot is a +period at the end of a line. @xref{Commands, , Forming commands of +tokens}. A period is a terminal dot @emph{only} +when it is at the end of a line; otherwise it is part of a +floating-point number. (A period outside a number in the middle of a +line is an error.) + +@quotation +@cindex terminal dot, changing +@cindex dot, terminal, changing +@strong{Please note:} The character used for the @dfn{terminal dot} can +be changed with the SET command. This is strongly discouraged, and +throughout all the remainder of this manual it will be assumed that the +default setting is in effect. +@end quotation + +@end table + +@node Commands, Types of Commands, Tokens, Language +@section Forming commands of tokens + +@cindex PSPP, command structure +@cindex language, command structure +@cindex commands, structure + +Most PSPP commands share a common structure, diagrammed below: + +@example +@var{cmd}@dots{} [@var{sbc}[=][@var{spec} [[,]@var{spec}]@dots{}]] [[/[=][@var{spec} [[,]@var{spec}]@dots{}]]@dots{}]. +@end example + +@cindex @samp{[ ]} +In the above, rather daunting, expression, pairs of square brackets +(@samp{[ ]}) indicate optional elements, and names such as @var{cmd} +indicate parts of the syntax that vary from command to command. +Ellipses (@samp{...}) indicate that the preceding part may be repeated +an arbitrary number of times. Let's pick apart what it says above: + +@itemize @bullet +@cindex commands, names +@item +A command begins with a command name of one or more keywords, such as +@code{FREQUENCIES}, @code{DATA LIST}, or @code{N OF CASES}. @var{cmd} +may be abbreviated to its first word if that is unambiguous; each word +in @var{cmd} may be abbreviated to a unique prefix of three or more +characters as described above. + +@cindex subcommands +@item +The command name may be followed by one or more @dfn{subcommands}: + +@itemize @minus +@item +Each subcommand begins with a unique keyword, indicated by @var{sbc} +above. This is analogous to the command name. + +@item +The subcommand name is optionally followed by an equals sign (@samp{=}). + +@item +Some subcommands accept a series of one or more specifications +(@var{spec}), optionally separated by commas. + +@item +Each subcommand must be separated from the next (if any) by a forward +slash (@samp{/}). +@end itemize + +@cindex dot, terminal +@cindex terminal dot +@item +Each command must be terminated with a @dfn{terminal dot}. +The terminal dot may be given one of three ways: + +@itemize @minus +@item +(most commonly) A period character at the very end of a line, as +described above. + +@item +(only if NULLINE is on: @xref{SET, , Setting user preferences}, for more +details.) A completely blank line. + +@item +(in batch mode only) Any line that is not indented from the left side of +the page causes a terminal dot to be inserted before that line. +Therefore, each command begins with a line that is flush left, followed +by zero or more lines that are indented one or more characters from the +left margin. + +In batch mode, PSPP will ignore a plus sign, minus sign, or period +(@samp{+}, @samp{@minus{}}, or @samp{.}) as the first character in a +line. Any of these characters as the first character on a line will +begin a new command. This allows for visual indentation of a command +without that command being considered part of the previous command. + +PSPP is in batch mode when it is reading input from a file, rather +than from an interactive user. Note that the other forms of the +terminal dot may also be used in batch mode. + +Sometimes, one encounters syntax files that are intended to be +interpreted in interactive mode rather than batch mode (for instance, +this can happen if a session log file is used directly as a syntax +file). When this occurs, use the @samp{-i} command line option to force +interpretation in interactive mode (@pxref{Language control options}). +@end itemize +@end itemize + +PSPP ignores empty commands when they are generated by the above +rules. Note that, as a consequence of these rules, each command must +begin on a new line. + +@node Types of Commands, Order of Commands, Commands, Language +@section Types of Commands + +Commands in PSPP are divided roughly into six categories: + +@table @strong +@item Utility commands +Set or display various global options that affect PSPP operations. +May appear anywhere in a syntax file. @xref{Utilities, , Utility +commands}. + +@item File definition commands +Give instructions for reading data from text files or from special +binary ``system files''. Most of these commands discard any previous +data or variables in order to replace it with the new data and +variables. At least one must appear before the first command in any of +the categories below. @xref{Data Input and Output}. + +@item Input program commands +Though rarely used, these provide powerful tools for reading data files +in arbitrary textual or binary formats. @xref{INPUT PROGRAM}. + +@item Transformations +Perform operations on data and write data to output files. Transformations +are not carried out until a procedure is executed. + +@item Restricted transformations +Same as transformations for most purposes. @xref{Order of Commands}, for a +detailed description of the differences. + +@item Procedures +Analyze data, writing results of analyses to the listing file. Cause +transformations specified earlier in the file to be performed. In a +more general sense, a @dfn{procedure} is any command that causes the +active file (the data) to be read. +@end table + +@node Order of Commands, Missing Observations, Types of Commands, Language +@section Order of Commands +@cindex commands, ordering +@cindex order of commands + +PSPP does not place many restrictions on ordering of commands. +The main restriction is that variables must be defined with one of the +file-definition commands before they are otherwise referred to. + +Of course, there are specific rules, for those who are interested. +PSPP possesses five internal states, called initial, INPUT +PROGRAM, FILE TYPE, transformation, and procedure states. (Please note +the distinction between the INPUT PROGRAM and FILE TYPE @emph{commands} +and the INPUT PROGRAM and FILE TYPE @emph{states}.) + +PSPP starts up in the initial state. Each successful completion +of a command may cause a state transition. Each type of command has its +own rules for state transitions: + +@table @strong +@item Utility commands +@itemize @bullet +@item +Legal in all states, except Pennsylvania. +@item +Do not cause state transitions. Exception: when the N OF CASES command +is executed in the procedure state, it causes a transition to the +transformation state. +@end itemize + +@item DATA LIST +@itemize @bullet +@item +Legal in all states. +@item +When executed in the initial or procedure state, causes a transition to +the transformation state. +@item +Clears the active file if executed in the procedure or transformation +state. +@end itemize + +@item INPUT PROGRAM +@itemize @bullet +@item +Invalid in INPUT PROGRAM and FILE TYPE states. +@item +Causes a transition to the INPUT PROGRAM state. +@item +Clears the active file. +@end itemize + +@item FILE TYPE +@itemize @bullet +@item +Invalid in INPUT PROGRAM and FILE TYPE states. +@item +Causes a transition to the FILE TYPE state. +@item +Clears the active file. +@end itemize + +@item Other file definition commands +@itemize @bullet +@item +Invalid in INPUT PROGRAM and FILE TYPE states. +@item +Cause a transition to the transformation state. +@item +Clear the active file, except for ADD FILES, MATCH FILES, and UPDATE. +@end itemize + +@item Transformations +@itemize @bullet +@item +Invalid in initial and FILE TYPE states. +@item +Cause a transition to the transformation state. +@end itemize + +@item Restricted transformations +@itemize @bullet +@item +Invalid in initial, INPUT PROGRAM, and FILE TYPE states. +@item +Cause a transition to the transformation state. +@end itemize + +@item Procedures +@itemize @bullet +@item +Invalid in initial, INPUT PROGRAM, and FILE TYPE states. +@item +Cause a transition to the procedure state. +@end itemize +@end table + +@node Missing Observations, Variables, Order of Commands, Language +@section Handling missing observations +@cindex missing values +@cindex values, missing + +PSPP includes special support for unknown numeric data values. +Missing observations are assigned a special value, called the +@dfn{system-missing value}. This ``value'' actually indicates the +absence of value; it means that the actual value is unknown. Procedures +automatically exclude from analyses those observations or cases that +have missing values. Whether single observations or entire cases are +excluded depends on the procedure. + +The system-missing value exists only for numeric variables. String +variables always have a defined value, even if it is only a string of +spaces. + +Variables, whether numeric or string, can have designated +@dfn{user-missing values}. Every user-missing value is an actual value +for that variable. However, most of the time user-missing values are +treated in the same way as the system-missing value. String variables +that are wider than a certain width, usually 8 characters (depending on +computer architecture), cannot have user-missing values. + +For more information on missing values, see the following sections: +@ref{Variables}, @ref{MISSING VALUES}, @ref{Expressions}. See also the +documentation on individual procedures for information on how they +handle missing values. + +@node Variables, Files, Missing Observations, Language +@section Variables +@cindex variables + +Variables are the basic unit of data storage in PSPP. All the +variables in a file taken together, apart from any associated data, are +said to form a @dfn{dictionary}. Each case contain a value for each +variable. Some details of variables are described in the sections +below. + +@menu +* Attributes:: Attributes of variables. +* System Variables:: Variables automatically defined by PSPP. +* Sets of Variables:: Lists of variable names. +* Input/Output Formats:: Input and output formats. +* Scratch Variables:: Variables deleted by procedures. +@end menu + +@node Attributes, System Variables, Variables, Variables +@subsection Attributes of Variables +@cindex variables, attributes of +@cindex attributes of variables +Each variable has a number of attributes, including: + +@table @strong +@item Name +This is an identifier. Each variable must have a different name. +@xref{Tokens}. + +@cindex variables, type +@cindex type of variables +@item Type +Numeric or string. + +@cindex variables, width +@cindex width of variables +@item Width +(string variables only) String variables with a width of 8 characters or +fewer are called @dfn{short string variables}. Short string variables +can be used in many procedures where @dfn{long string variables} (those +with widths greater than 8) are not allowed. + +@quotation +@strong{Please note:} Certain systems may consider strings longer than 8 +characters to be short strings. Eight characters represents a minimum +figure for the maximum length of a short string. +@end quotation + +@item Position +Variables in the dictionary are arranged in a specific order. The +DISPLAY command can be used to show this order: see @ref{DISPLAY}. + +@item Orientation +Dexter or sinister. @xref{LEAVE}. + +@cindex missing values +@cindex values, missing +@item Missing values +Optionally, up to three values, or a range of values, or a specific +value plus a range, can be specified as @dfn{user-missing values}. +There is also a @dfn{system-missing value} that is assigned to an +observation when there is no other obvious value for that observation. +Observations with missing values are automatically excluded from +analyses. User-missing values are actual data values, while the +system-missing value is not a value at all. @xref{Missing Observations}. + +@cindex variable labels +@cindex labels, variable +@item Variable label +A string that describes the variable. @xref{VARIABLE LABELS}. + +@cindex value labels +@cindex labels, value +@item Value label +Optionally, these associate each possible value of the variable with a +string. @xref{VALUE LABELS}. + +@cindex print format +@item Print format +Display width, format, and (for numeric variables) number of decimal +places. This attribute does not affect how data are stored, just how +they are displayed. Example: a width of 8, with 2 decimal places. +@xref{PRINT FORMATS}. + +@cindex write format +@item Write format +Similar to print format, but used by certain commands that are +designed to write to binary files. @xref{WRITE FORMATS}. +@end table + +@node System Variables, Sets of Variables, Attributes, Variables +@subsection Variables Automatically Defined by PSPP +@cindex system variables +@cindex variables, system + +There are seven system variables. These are not like ordinary +variables, as they are not stored in each case. They can only be used +in expressions. These system variables, whose values and output formats +cannot be modified, are described below. + +@table @code +@cindex @code{$CASENUM} +@item $CASENUM +Case number of the case at the moment. This changes as cases are +shuffled around. + +@cindex @code{$DATE} +@item $DATE +Date the PSPP process was started, in format A9, following the +pattern @code{DD MMM YY}. + +@cindex @code{$JDATE} +@item $JDATE +Number of days between 15 Oct 1582 and the time the PSPP process +was started. + +@cindex @code{$LENGTH} +@item $LENGTH +Page length, in lines, in format F11. + +@cindex @code{$SYSMIS} +@item $SYSMIS +System missing value, in format F1. + +@cindex @code{$TIME} +@item $TIME +Number of seconds between midnight 14 Oct 1582 and the time the active file +was read, in format F20. + +@cindex @code{$WIDTH} +@item $WIDTH +Page width, in characters, in format F3. +@end table + +@node Sets of Variables, Input/Output Formats, System Variables, Variables +@subsection Lists of variable names +@cindex TO convention +@cindex convention, TO + +There are several ways to specify a set of variables: + +@enumerate +@item +(Most commonly.) List the variable names one after another, optionally +separating them by commas. + +@cindex @code{TO} +@item +(This method cannot be used on commands that define the dictionary, such +as @code{DATA LIST}.) The syntax is the names of two existed variables, +separated by the reserved keyword @code{TO}. The meaning is to include +every variable in the dictionary between and including the variables +specified. For instance, if the dictionary contains six variables with +the names @code{ID}, @code{X1}, @code{X2}, @code{GOAL}, @code{MET}, and +@code{NEXTGOAL}, in that order, then @code{X2 TO MET} would include +variables @code{X2}, @code{GOAL}, and @code{MET}. + +@item +(This method can be used only on commands that define the dictionary, +such as @code{DATA LIST}.) It is used to define sequences of variables +that end in consecutive integers. The syntax is two identifiers that +end in numbers. This method is best illustrated with examples: + +@itemize @bullet +@item +The syntax @code{X1 TO X5} defines 5 variables: + +@itemize @minus +@item +X1 +@item +X2 +@item +X3 +@item +X4 +@item +X5 +@end itemize + +@item +The syntax @code{ITEM0008 TO ITEM0013} defines 6 variables: + +@itemize @minus +@item +ITEM0008 +@item +ITEM0009 +@item +ITEM0010 +@item +ITEM0011 +@item +ITEM0012 +@item +ITEM0013 +@end itemize + +@item +Each of the syntaxes @code{QUES001 TO QUES9} and @code{QUES6 TO QUES3} +are invalid, although for different reasons, which should be evident. +@end itemize + +Note that after a set of variables has been defined on @code{DATA LIST} +or another command with this method, the same set can be referenced on +later commands using the same syntax. + +@item +The above methods can be combined, either one after another or delimited +by commas. For instance, the combined syntax @code{A Q5 TO Q8 X TO Z} +is legal as long as each part @code{A}, @code{Q5 TO Q8}, @code{X TO Z} +is individually legal. +@end enumerate + +@node Input/Output Formats, Scratch Variables, Sets of Variables, Variables +@subsection Input and Output Formats + +Data that PSPP inputs and outputs must have one of a number of formats. +These formats are described, in general, by a format specification of +the form @code{NAMEw.d}, where @var{name} is the +format name and @var{w} is a field width. @var{d} is the optional +desired number of decimal places, if appropriate. If @var{d} is not +included then it is assumed to be 0. Some formats do not allow @var{d} +to be specified. + +When an input format is specified on DATA LIST or another command, then +it is converted to an output format for the purposes of PRINT and other +data output commands. For most purposes, input and output formats are +the same; the salient differences are described below. + +Below are listed the input and output formats supported by PSPP. If an +input format is mapped to a different output format by default, then +that mapping is indicated with @result{}. Each format has the listed +bounds on input width (iw) and output width (ow). + +The standard numeric input and output formats are given in the following +table: + +@table @asis +@item Fw.d: 1 <= iw,ow <= 40 +Standard decimal format with @var{d} decimal places. If the number is +too large to fit within the field width, it is expressed in scientific +notation (@code{1.2+34}) if w >= 6, with always at least two digits in +the exponent. When used as an input format, scientific notation is +allowed but an E or an F must be used to introduce the exponent. + +The default output format is the same as the input format, except if +@var{d} > 1. In that case the output @var{w} is always made to be at +least 2 + @var{d}. + +@item Ew.d: 1 <= iw <= 40; 6 <= ow <= 40 +For input this is equivalent to F format except that no E or F is +require to introduce the exponent. For output, produces scientific +notation in the form @code{1.2+34}. There are always at least two +digits given in the exponent. + +The default output @var{w} is the largest of the input @var{w}, the +input @var{d} + 7, and 10. The default output @var{d} is the input +@var{d}, but at least 3. + +@item COMMAw.d: 1 <= iw,ow <= 40 +Equivalent to F format, except that groups of three digits are +comma-separated on output. If the number is too large to express in the +field width, then first commas are eliminated, then if there is still +not enough space the number is expressed in scientific notation given +that w >= 6. Commas are allowed and ignored when this is used as an +input format. + +@item DOTw.d: 1 <= iw,ow <= 40 +Equivalent to COMMA format except that the roles of comma and decimal +point are interchanged. However: If SET /DECIMAL=DOT is in effect, then +COMMA uses @samp{,} for a decimal point and DOT uses @samp{.} for a +decimal point. + +@item DOLLARw.d: 1 <= iw <= 40; 2 <= ow <= 40 +Equivalent to COMMA format, except that the number is prefixed by a +dollar sign (@samp{$}) if there is room. On input the value is allowed +to be prefixed by a dollar sign, which is ignored. + +The default output @var{w} is the input @var{w}, but at least 2. + +@item PCTw.d: 2 <= iw,ow <= 40 +Equivalent to F format, except that the number is suffixed by a percent +sign (@samp{%}) if there is room. On input the value is allowed to be +suffixed by a percent sign, which is ignored. + +The default output @var{w} is the input @var{w}, but at least 2. + +@item Nw.d: 1 <= iw,ow <= 40 +Only digits are allowed within the field width. The decimal point is +assumed to be @var{d} digits from the right margin. + +The default output format is F with the same @var{w} and @var{d}, except +if @var{d} > 1. In that case the output @var{w} is always made to be at +least 2 + @var{d}. + +@item Zw.d @result{} F: 1 <= iw,ow <= 40 +Zoned decimal input. If you need to use this then you know how. + +@item IBw.d @result{} F: 1 <= iw,ow <= 8 +Integer binary format. The field is interpreted as a fixed-point +positive or negative binary number in two's-complement notation. The +location of the decimal point is implied. Endianness is the same as the +host machine. + +The default output format is F8.2 if @var{d} is 0. Otherwise it is F, +with output @var{w} as 9 + input @var{d} and output @var{d} as input +@var{d}. + +@item PIB @result{} F: 1 <= iw,ow <= 8 +Positive integer binary format. The field is interpreted as a +fixed-point positive binary number. The location of the decimal point +is implied. Endianness is teh same as the host machine. + +The default output format follows the rules for IB format. + +@item Pw.d @result{} F: 1 <= iw,ow <= 16 +Binary coded decimal format. Each byte from left to right, except the +rightmost, represents two digits. The upper nibble of each byte is more +significant. The upper nibble of the final byte is the least +significant digit. The lower nibble of the final byte is the sign; a +value of D represents a negative sign and all other values are +considered positive. The decimal point is implied. + +The default output format follows the rules for IB format. + +@item PKw.d @result{} F: 1 <= iw,ow <= 16 +Positive binary code decimal format. Same as P but the last byte is the +same as the others. + +The default output format follows the rules for IB format. + +@item RBw @result{} F: 2 <= iw,ow <= 8 + +Binary C architecture-dependent ``double'' format. For a standard +IEEE754 implementation @var{w} should be 8. + +The default output format follows the rules for IB format. + +@item PIBHEXw.d @result{} F: 2 <= iw,ow <= 16 +PIB format encoded as textual hex digit pairs. @var{w} must be even. + +The input width is mapped to a default output width as follows: +2@result{}4, 4@result{}6, 6@result{}9, 8@result{}11, 10@result{}14, +12@result{}16, 14@result{}18, 16@result{}21. No allowances are made for +decimal places. + +@item RBHEXw @result{} F: 4 <= iw,ow <= 16 + +RB format encoded as textual hex digits pairs. @var{w} must be even. + +The default output format is F8.2. + +@item CCAw.d: 1 <= ow <= 40 +@itemx CCBw.d: 1 <= ow <= 40 +@itemx CCCw.d: 1 <= ow <= 40 +@itemx CCDw.d: 1 <= ow <= 40 +@itemx CCEw.d: 1 <= ow <= 40 + +User-defined custom currency formats. May not be used as an input +format. @xref{SET}, for more details. +@end table + +The date and time numeric input and output formats accept a number of +possible formats. Before describing the formats themselves, some +definitions of the elements that make up their formats will be helpful: + +@table @dfn +@item leader +All formats accept an optional whitespace leader. + +@item day +An integer between 1 and 31 representing the day of month. + +@item day-count +An integer representing a number of days. + +@item date-delimiter +One or more characters of whitespace or the following characters: +@code{- / . ,} + +@item month +A month name in one of the following forms: +@itemize @bullet +@item +An integer between 1 and 12. +@item +Roman numerals representing an integer between 1 and 12. +@item +At least the first three characters of an English month name (January, +February, @dots{}). +@end itemize + +@item year +An integer year number between 1582 and 19999, or between 1 and 199. +Years between 1 and 199 will have 1900 added. + +@item julian +A single number with a year number in the first 2, 3, or 4 digits (as +above) and the day number within the year in the last 3 digits. + +@item quarter +An integer between 1 and 4 representing a quarter. + +@item q-delimiter +The letter @samp{Q} or @samp{q}. + +@item week +An integer between 1 and 53 representing a week within a year. + +@item wk-delimiter +The letters @samp{wk} in any case. + +@item time-delimiter +At least one characters of whitespace or @samp{:} or @samp{.}. + +@item hour +An integer greater than 0 representing an hour. + +@item minute +An integer between 0 and 59 representing a minute within an hour. + +@item opt-second +Optionally, a time-delimiter followed by a real number representing a +number of seconds. + +@item hour24 +An integer between 0 and 23 representing an hour within a day. + +@item weekday +At least the first two characters of an English day word. + +@item spaces +Any amount or no amount of whitespace. + +@item sign +An optional positive or negative sign. + +@item trailer +All formats accept an optional whitespace trailer. +@end table + +The date input formats are strung together from the above pieces. On +output, the date formats are always printed in a single canonical +manner, based on field width. The date input and output formats are +described below: + +@table @asis +@item DATEw: 9 <= iw,ow <= 40 +Date format. Input format: leader + day + date-delimiter + +month + date-delimiter + year + trailer. Output format: DD-MMM-YY for +@var{w} < 11, DD-MMM-YYYY otherwise. + +@item EDATEw: 8 <= iw,ow <= 40 +European date format. Input format same as DATE. Output format: +DD.MM.YY for @var{w} < 10, DD.MM.YYYY otherwise. + +@item SDATEw: 8 <= iw,ow <= 40 +Standard date format. Input format: leader + year + date-delimiter + +month + date-delimiter + day + trailer. Output format: YY/MM/DD for +@var{w} < 10, YYYY/MM/DD otherwise. + +@item ADATEw: 8 <= iw,ow <= 40 +American date format. Input format: leader + month + date-delimiter + +day + date-delimiter + year + trailer. Output format: MM/DD/YY for +@var{w} < 10, MM/DD/YYYY otherwise. + +@item JDATEw: 5 <= iw,ow <= 40 +Julian date format. Input format: leader + julian + trailer. Output +format: YYDDD for @var{w} < 7, YYYYDDD otherwise. + +@item QYRw: 4 <= iw <= 40, 6 <= ow <= 40 +Quarter/year format. Input format: leader + quarter + q-delimiter + +year + trailer. Output format: @samp{Q Q YY}, where the first +@samp{Q} is one of the digits 1, 2, 3, 4, if @var{w} < 8, @code{Q Q +YYYY} otherwise. + +@item MOYRw: 6 <= iw,ow <= 40 +Month/year format. Input format: leader + month + date-delimiter + year ++ trailer. Output format: @samp{MMM YY} for @var{w} < 8, @samp{MMM +YYYY} otherwise. + +@item WKYRw: 6 <= iw <= 40, 8 <= ow <= 40 +Week/year format. Input format: leader + week + wk-delimiter + year + +trailer. Output format: @samp{WW WK YY} for @var{w} < 10, @samp{WW WK +YYYY} otherwise. + +@item DATETIMEw.d: 17 <= iw,ow <= 40 +Date and time format. Input format: leader + day + date-delimiter + +month + date-delimiter + yaer + time-delimiter + hour24 + time-delimiter ++ minute + opt-second. Output format: @samp{DD-MMM-YYYY HH:MM}. If +@var{w} > 19 then seconds @samp{:SS} is added. If @var{w} > 22 and +@var{d} > 0 then fractional seconds @samp{.SS} are added. + +@item TIMEw.d: 5 <= iw,ow <= 40 +Time format. Input format: leader + sign + spaces + hour + +time-delimiter + minute + opt-second. Output format: @samp{HH:MM}. +Seconds and fractional seconds are available with @var{w} of at least 8 +and 10, respectively. + +@item DTIMEw.d: 1 <= iw <= 40, 8 <= ow <= 40 +Time format with day count. Input format: leader + sign + spaces + +day-count + time-delimiter + hour + time-delimiter + minute + +opt-second. Output format: @samp{DD HH:MM}. Seconds and fractional +seconds are available with @var{w} of at least 8 and 10, respectively. + +@item WKDAYw: 2 <= iw,ow <= 40 +A weekday as a number between 1 and 7, where 1 is Sunday. Input format: +leader + weekday + trailer. Output format: as many characters, in all +capital letters, of the English name of the weekday as will fit in the +field width. + +@item MONTHw: 3 <= iw,ow <= 40 +A month as a number between 1 and 12, where 1 is January. Input format: +leader + month + trailer. Output format: as many character, in all +capital letters, of the English name of the month as will fit in the +field width. +@end table + +There are only two formats that may be used with string variables: + +@table @asis +@item Aw: 1 <= iw <= 255, 1 <= ow <= 254 +The entire field is treated as a string value. + +@item AHEXw @result{} A: 2 <= iw <= 254; 2 <= ow <= 510 +The field is composed of characters in a string encoded as textual hex +digit pairs. + +The default output @var{w} is half the input @var{w}. +@end table + +@node Scratch Variables, , Input/Output Formats, Variables +@subsection Scratch Variables + +Most of the time, variables don't retain their values between cases. +Instead, either they're being read from a data file or the active file, +in which case they assume the value read, or, if created with COMPUTE or +another transformation, they're initialized to the system-missing value +or to blanks, depending on type. + +However, sometimes it's useful to have a variable that keeps its value +between cases. You can do this with LEAVE (@pxref{LEAVE}), or you can +use a @dfn{scratch variable}. Scratch variables are variables whose +names begin with an octothorpe (@samp{#}). + +Scratch variables have the same properties as variables left with LEAVE: +they retain their values between cases, and for the first case they are +initialized to 0 or blanks. They have the additional property that they +are deleted before the execution of any procedure. For this reason, +scratch variables can't be used for analysis. To obtain the same +effect, use COMPUTE (@pxref{COMPUTE}) to copy the scratch variable's +value into an ordinary variable, then analysis that variable. + +@node Files, BNF, Variables, Language +@section Files Used by PSPP + +PSPP makes use of many files each time it runs. Some of these it +reads, some it writes, some it creates. Here is a table listing the +most important of these files: + +@table @strong +@cindex file, command +@cindex file, syntax file +@cindex command file +@cindex syntax file +@item command file +@itemx syntax file +These names (synonyms) refer to the file that contains instructions to +PSPP that tell it what to do. The syntax file's name is specified on +the PSPP command line. Syntax files can also be pulled in with the +@code{INCLUDE} command. + +@cindex file, data +@cindex data file +@item data file +Data files contain raw data in ASCII format suitable for being read in +by the @code{DATA LIST} command. Data can be embedded in the syntax +file with @code{BEGIN DATA} and @code{END DATA} commands: this makes the +syntax file a data file too. + +@cindex file, output +@cindex output file +@item listing file +One or more output files are created by PSPP each time it is +run. The output files receive the tables and charts produced by +statistical procedures. The output files may be in any number of formats, +depending on how PSPP is configured. + +@cindex active file +@cindex file, active +@item active file +The active file is the ``file'' on which all PSPP procedures +are performed. The active file contains variable definitions and +cases. The active file is not necessarily a disk file: it is stored +in memory if there is room. +@end table + +@node BNF, , Files, Language +@section Backus-Naur Form +@cindex BNF +@cindex Backus-Naur Form +@cindex command syntax, description of +@cindex description of command syntax + +The syntax of some parts of the PSPP language is presented in this +manual using the formalism known as @dfn{Backus-Naur Form}, or BNF. The +following table describes BNF: + +@itemize @bullet +@cindex keywords +@cindex terminals +@item +Words in all-uppercase are PSPP keyword tokens. In BNF, these are +often called @dfn{terminals}. There are some special terminals, which +are actually written in lowercase for clarity: + +@table @asis +@cindex @code{number} +@item @code{number} +A real number. + +@cindex @code{integer} +@item @code{integer} +An integer number. + +@cindex @code{string} +@item @code{string} +A string. + +@cindex @code{var-name} +@item @code{var-name} +A single variable name. + +@cindex operators +@cindex punctuators +@item @code{=}, @code{/}, @code{+}, @code{-}, etc. +Operators and punctuators. + +@cindex @code{.} +@cindex terminal dot +@cindex dot, terminal +@item @code{.} +The terminal dot. This is not necessarily an actual dot in the syntax +file: @xref{Commands}, for more details. +@end table + +@item +@cindex productions +@cindex nonterminals +Other words in all lowercase refer to BNF definitions, called +@dfn{productions}. These productions are also known as +@dfn{nonterminals}. Some nonterminals are very common, so they are +defined here in English for clarity: + +@table @code +@cindex @code{var-list} +@item var-list +A list of one or more variable names or the keyword @code{ALL}. + +@cindex @code{expression} +@item expression +An expression. @xref{Expressions}, for details. +@end table + +@item +@cindex @code{::=} +@cindex ``is defined as'' +@cindex productions +@samp{::=} means ``is defined as''. The left side of @samp{::=} gives +the name of the nonterminal being defined. The right side of @samp{::=} +gives the definition of that nonterminal. If the right side is empty, +then one possible expansion of that nonterminal is nothing. A BNF +definition is called a @dfn{production}. + +@item +@cindex terminals and nonterminals, differences +So, the key difference between a terminal and a nonterminal is that a +terminal cannot be broken into smaller parts---in fact, every terminal +is a single token (@pxref{Tokens}). On the other hand, nonterminals are +composed of a (possibly empty) sequence of terminals and nonterminals. +Thus, terminals indicate the deepest level of syntax description. (In +parsing theory, terminals are the leaves of the parse tree; nonterminals +form the branches.) + +@item +@cindex start symbol +@cindex symbol, start +The first nonterminal defined in a set of productions is called the +@dfn{start symbol}. The start symbol defines the entire syntax for +that command. +@end itemize + +@node Expressions, Data Input and Output, Language, Top +@chapter Mathematical Expressions +@cindex expressions, mathematical +@cindex mathematical expressions + +Some PSPP commands use expressions, which share a common syntax +among all PSPP commands. Expressions are made up of +@dfn{operands}, which can be numbers, strings, or variable names, +separated by @dfn{operators}. There are five types of operators: +grouping, arithmetic, logical, relational, and functions. + +Every operator takes one or more @dfn{arguments} as input and produces +or @dfn{returns} exactly one result as output. Both strings and numeric +values can be used as arguments and are produced as results, but each +operator accepts only specific combinations of numeric and string values +as arguments. With few exceptions, operator arguments may be +full-fledged expressions in themselves. + +@menu +* Booleans:: Boolean values. +* Missing Values in Expressions:: Using missing values in expressions. +* Grouping Operators:: ( ) +* Arithmetic Operators:: + - * / ** +* Logical Operators:: AND NOT OR +* Relational Operators:: EQ GE GT LE LT NE +* Functions:: More-sophisticated operators. +* Order of Operations:: Operator precedence. +@end menu + +@node Booleans, Missing Values in Expressions, Expressions, Expressions +@section Boolean values +@cindex Boolean +@cindex values, Boolean + +There is a third type for arguments and results, the @dfn{Boolean} type, +which is used to represent true/false conditions. Booleans have only +three possible values: 0 (false), 1 (true), and system-missing. +System-missing is neither true or false. + +@itemize @bullet +@item +A numeric expression that has value 0, 1, or system-missing may be used +in place of a Boolean. Thus, the expression @code{0 AND 1} is valid +(although it is always true). + +@item +A numeric expression with any other value will cause an error if it is +used as a Boolean. So, @code{2 OR 3} is invalid. + +@item +A Boolean expression may not be used in place of a numeric expression. +Thus, @code{(1>2) + (3<4)} is invalid. + +@item +Strings and Booleans are not compatible, and neither may be used in +place of the other. +@end itemize + +@node Missing Values in Expressions, Grouping Operators, Booleans, Expressions +@section Missing Values in Expressions + +String missing values are not treated specially in expressions. Most +numeric operators return system-missing when given system-missing +arguments. Exceptions are listed under particular operator +descriptions. + +User-missing values for numeric variables are always transformed into +the system-missing value, except inside the arguments to the +@code{VALUE}, @code{SYSMIS}, and @code{MISSING} functions. + +The missing-value functions can be used to precisely control how missing +values are treated in expressions. @xref{Missing Value Functions}, for +more details. + +@node Grouping Operators, Arithmetic Operators, Missing Values in Expressions, Expressions +@section Grouping Operators +@cindex parentheses +@cindex @samp{( )} +@cindex grouping operators +@cindex operators, grouping + +Parentheses (@samp{()}) are the grouping operators. Surround an +expression with parentheses to force early evaluation. + +Parentheses also surround the arguments to functions, but in that +situation they act as punctuators, not as operators. + +@node Arithmetic Operators, Logical Operators, Grouping Operators, Expressions +@section Arithmetic Operators +@cindex operators, arithmetic +@cindex arithmetic operators + +The arithmetic operators take numeric arguments and produce numeric +results. + +@table @code +@cindex @samp{+} +@cindex addition +@item @var{a} + @var{b} +Adds @var{a} and @var{b}, returning the sum. + +@cindex @samp{-} +@cindex subtraction +@item @var{a} - @var{b} +Subtracts @var{b} from @var{a}, returning the difference. + +@cindex @samp{*} +@cindex multiplication +@item @var{a} * @var{b} +Multiplies @var{a} and @var{b}, returning the product. + +@cindex @samp{/} +@cindex division +@item @var{a} / @var{b} +Divides @var{a} by @var{b}, returning the quotient. If @var{b} is +zero, the result is system-missing. + +@cindex @samp{**} +@cindex exponentiation +@item @var{a} ** @var{b} +Returns the result of raising @var{a} to the power @var{b}. If +@var{a} is negative and @var{b} is not an integer, the result is +system-missing. The result of @code{0**0} is system-missing as well. + +@cindex @samp{-} +@cindex negation +@item - @var{a} +Reverses the sign of @var{a}. +@end table + +@node Logical Operators, Relational Operators, Arithmetic Operators, Expressions +@section Logical Operators +@cindex logical operators +@cindex operators, logical + +@cindex true +@cindex false +@cindex Boolean +@cindex values, system-missing +@cindex system-missing +The logical operators take logical arguments and produce logical +results, meaning ``true or false''. PSPP logical operators are +not true Boolean operators because they may also result in a +system-missing value. + +@table @code +@cindex @code{AND} +@cindex @samp{&} +@cindex intersection, logical +@cindex logical intersection +@item @var{a} AND @var{b} +@itemx @var{a} & @var{b} +True if both @var{a} and @var{b} are true. However, if one argument is +false and the other is missing, the result is false, not missing. If +both arguments are missing, the result is missing. + +@cindex @code{OR} +@cindex @samp{|} +@cindex union, logical +@cindex logical union +@item @var{a} OR @var{b} +@itemx @var{a} | @var{b} +True if at least one of @var{a} and @var{b} is true. If one argument is +true and the other is missing, the result is true, not missing. If both +arguments are missing, the result is missing. + +@cindex @code{NOT} +@cindex @samp{~} +@cindex inversion, logical +@cindex logical inversion +@item NOT @var{a} +@itemx ~ @var{a} +True if @var{a} is false. +@end table + +@node Relational Operators, Functions, Logical Operators, Expressions +@section Relational Operators + +The relational operators take numeric or string arguments and produce Boolean +results. + +Note that, with numeric arguments, PSPP does not make exact +relational tests. Instead, two numbers are considered to be equal even +if they differ by a small amount. This amount, @dfn{epsilon}, is +dependent on the PSPP configuration and determined at compile +time. (The default value is 0.000000001, or +@ifinfo +@code{10**(-9)}.) +@end ifinfo +@tex +$10 ^ -9$.) +@end tex +Use of epsilon allows for round-off errors. Use of epsilon is also +idiotic, but the author is not a numeric analyst. + +Strings cannot be compared to numbers. When strings of different +lengths are compared, the shorter string is right-padded with spaces +to match the length of the longer string. + +The results of string comparisons, other than tests for equality or +inequality, are dependent on the character set in use. String +comparisons are case-sensitive. + +@table @code +@cindex equality, testing +@cindex testing for equality +@cindex @code{EQ} +@cindex @samp{=} +@item @var{a} EQ @var{b} +@itemx @var{a} = @var{b} +True if @var{a} is equal to @var{b}. + +@cindex less than or equal to +@cindex @code{LE} +@cindex @code{<=} +@item @var{a} LE @var{b} +@itemx @var{a} <= @var{b} +True if @var{a} is less than or equal to @var{b}. + +@cindex less than +@cindex @code{LT} +@cindex @code{<} +@item @var{a} LT @var{b} +@itemx @var{a} < @var{b} +True if @var{a} is less than @var{b}. + +@cindex greater than or equal to +@cindex @code{GE} +@cindex @code{>=} +@item @var{a} GE @var{b} +@itemx @var{a} >= @var{b} +True if @var{a} is greater than or equal to @var{b}. + +@cindex greater than +@cindex @code{GT} +@cindex @samp{>} +@item @var{a} GT @var{b} +@itemx @var{a} > @var{b} +True if @var{a} is greater than @var{b}. + +@cindex inequality, testing +@cindex testing for inequality +@cindex @code{NE} +@cindex @code{~=} +@cindex @code{<>} +@item @var{a} NE @var{b} +@itemx @var{a} ~= @var{b} +@itemx @var{a} <> @var{b} +True is @var{a} is not equal to @var{b}. +@end table + +@node Functions, Order of Operations, Relational Operators, Expressions +@section Functions +@cindex functions + +@cindex mathematics +@cindex operators +@cindex parentheses +@cindex @code{(} +@cindex @code{)} +@cindex names, of functions +PSPP functions provide mathematical abilities above and beyond +those possible using simple operators. Functions have a common +syntax: each is composed of a function name followed by a left +parenthesis, one or more arguments, and a right parenthesis. Function +names are @strong{not} reserved; their names are specially treated +only when followed by a left parenthesis: @code{EXP(10)} refers to the +constant value @code{e} raised to the 10th power, but @code{EXP} by +itself refers to the value of variable EXP. + +The sections below describe each function in detail. + +@menu +* Advanced Mathematics:: EXP LG10 LN SQRT +* Miscellaneous Mathematics:: ABS MOD MOD10 RND TRUNC +* Trigonometry:: ACOS ARCOS ARSIN ARTAN ASIN ATAN COS SIN TAN +* Missing Value Functions:: MISSING NMISS NVALID SYSMIS VALUE +* Pseudo-Random Numbers:: NORMAL UNIFORM +* Set Membership:: ANY RANGE +* Statistical Functions:: CFVAR MAX MEAN MIN SD SUM VARIANCE +* String Functions:: CONCAT INDEX LENGTH LOWER LPAD LTRIM NUMBER + RINDEX RPAD RTRIM STRING SUBSTR UPCASE +* Time & Date:: CTIME.xxx DATE.xxx TIME.xxx XDATE.xxx +* Miscellaneous Functions:: LAG YRMODA +* Functions Not Implemented:: CDF.xxx CDFNORM IDF.xxx NCDF.xxx PROBIT RV.xxx +@end menu + +@node Advanced Mathematics, Miscellaneous Mathematics, Functions, Functions +@subsection Advanced Mathematical Functions +@cindex mathematics, advanced + +Advanced mathematical functions take numeric arguments and produce +numeric results. + +@deftypefn {Function} {} EXP (@var{exponent}) +Returns @i{e} (approximately 2.71828) raised to power @var{exponent}. +@end deftypefn + +@cindex logarithms +@deftypefn {Function} {} LG10 (@var{number}) +Takes the base-10 logarithm of @var{number}. If @var{number} is +not positive, the result is system-missing. +@end deftypefn + +@deftypefn {Function} {} LN (@var{number}) +Takes the base-@samp{e} logarithm of @var{number}. If @var{number} is +not positive, the result is system-missing. +@end deftypefn + +@cindex square roots +@deftypefn {Function} {} SQRT (@var{number}) +Takes the square root of @var{number}. If @var{number} is negative, +the result is system-missing. +@end deftypefn + +@node Miscellaneous Mathematics, Trigonometry, Advanced Mathematics, Functions +@subsection Miscellaneous Mathematical Functions +@cindex mathematics, miscellaneous + +Miscellaneous mathematical functions take numeric arguments and produce +numeric results. + +@cindex absolute value +@deftypefn {Function} {} ABS (@var{number}) +Results in the absolute value of @var{number}. +@end deftypefn + +@cindex modulus +@deftypefn {Function} {} MOD (@var{numerator}, @var{denominator}) +Returns the remainder (modulus) of @var{numerator} divided by +@var{denominator}. If @var{denominator} is 0, the result is +system-missing. However, if @var{numerator} is 0 and +@var{denominator} is system-missing, the result is 0. +@end deftypefn + +@cindex modulus, by 10 +@deftypefn {Function} {} MOD10 (@var{number}) +Returns the remainder when @var{number} is divided by 10. If +@var{number} is negative, MOD10(@var{number}) is negative or zero. +@end deftypefn + +@cindex rounding +@deftypefn {Function} {} RND (@var{number}) +Takes the absolute value of @var{number} and rounds it to an integer. +Then, if @var{number} was negative originally, negates the result. +@end deftypefn + +@cindex truncation +@deftypefn {Function} {} TRUNC (@var{number}) +Discards the fractional part of @var{number}; that is, rounds +@var{number} towards zero. +@end deftypefn + +@node Trigonometry, Missing Value Functions, Miscellaneous Mathematics, Functions +@subsection Trigonometric Functions +@cindex trigonometry + +Trigonometric functions take numeric arguments and produce numeric +results. + +@cindex arccosine +@cindex inverse cosine +@deftypefn {Function} {} ACOS (@var{number}) +@deftypefnx {Function} {} ARCOS (@var{number}) +Takes the arccosine, in radians, of @var{number}. Results in +system-missing if @var{number} is not between -1 and 1. Portability: +none. +@end deftypefn + +@cindex arcsine +@cindex inverse sine +@deftypefn {Function} {} ARSIN (@var{number}) +Takes the arcsine, in radians, of @var{number}. Results in +system-missing if @var{number} is not between -1 and 1 inclusive. +@end deftypefn + +@cindex arctangent +@cindex inverse tangent +@deftypefn {Function} {} ARTAN (@var{number}) +Takes the arctangent, in radians, of @var{number}. +@end deftypefn + +@cindex arcsine +@cindex inverse sine +@deftypefn {Function} {} ASIN (@var{number}) +Takes the arcsine, in radians, of @var{number}. Results in +system-missing if @var{number} is not between -1 and 1 inclusive. +Portability: none. +@end deftypefn + +@cindex arctangent +@cindex inverse tangent +@deftypefn {Function} {} ATAN (@var{number}) +Takes the arctangent, in radians, of @var{number}. +@end deftypefn + +@quotation +@strong{Please note:} Use of the AR* group of inverse trigonometric +functions is recommended over the A* group because they are more +portable. +@end quotation + +@cindex cosine +@deftypefn {Function} {} COS (@var{radians}) +Takes the cosine of @var{radians}. +@end deftypefn + +@cindex sine +@deftypefn {Function} {} SIN (@var{angle}) +Takes the sine of @var{radians}. +@end deftypefn + +@cindex tangent +@deftypefn {Function} {} TAN (@var{angle}) +Takes the tangent of @var{radians}. Results in system-missing at values +of @var{angle} that are too close to odd multiples of pi/2. +Portability: none. +@end deftypefn + +@node Missing Value Functions, Pseudo-Random Numbers, Trigonometry, Functions +@subsection Missing-Value Functions +@cindex missing values +@cindex values, missing +@cindex functions, missing-value + +Missing-value functions take various types as arguments, returning +various types of results. + +@deftypefn {Function} {} MISSING (@var{variable or expression}) +@var{num} may be a single variable name or an expression. If it is a +variable name, results in 1 if the variable has a user-missing or +system-missing value for the current case, 0 otherwise. If it is an +expression, results in 1 if the expression has the system-missing value, +0 otherwise. + +@quotation +@strong{Please note:} If the argument is a string expression other than +a variable name, MISSING is guaranteed to return 0, because strings do +not have a system-missing value. Also, when using a numeric expression +argument, remember that user-missing values are converted to the +system-missing value in most contexts. Thus, the expressions +@code{MISSING(VAR1 @var{op} VAR2)} and @code{MISSING(VAR1) OR +MISSING(VAR2)} are often equivalent, depending on the specific operator +@var{op} used. +@end quotation +@end deftypefn + +@deftypefn {Function} {} NMISS (@var{expr} [, @var{expr}]@dots{}) +Each argument must be a numeric expression. Returns the number of +user- or system-missing values in the list. As a special extension, +the syntax @code{@var{var1} TO @var{var2}} may be used to refer to a +range of variables; see @ref{Sets of Variables}, for more details. +@end deftypefn + +@deftypefn {Function} {} NVALID (@var{expr} [, @var{expr}]@dots{}) +Each argument must be a numeric expression. Returns the number of +values in the list that are not user- or system-missing. As a special extension, +the syntax @code{@var{var1} TO @var{var2}} may be used to refer to a +range of variables; see @ref{Sets of Variables}, for more details. +@end deftypefn + +@deftypefn {Function} {} SYSMIS (@var{variable or expression}) +When given the name of a numeric variable, returns 1 if the value of +that variable is system-missing. Otherwise, if the value is not +missing or if it is user-missing, returns 0. If given the name of a +string variable, always returns 1. If given an expression other than +a single variable name, results in 1 if the value is system- or +user-missing, 0 otherwise. +@end deftypefn + +@deftypefn {Function} {} VALUE (@var{variable}) +Prevents the user-missing values of @var{variable} from being +transformed into system-missing values: If @var{variable} is not +system- or user-missing, results in the value of @var{variable}. If +@var{variable} is user-missing, results in the value of @var{variable} +anyway. If @var{variable} is system-missing, results in system-missing. +@end deftypefn + +@node Pseudo-Random Numbers, Set Membership, Missing Value Functions, Functions +@subsection Pseudo-Random Number Generation Functions +@cindex random numbers +@cindex pseudo-random numbers (see random numbers) + +Pseudo-random number generation functions take numeric arguments and +produce numeric results. + +@cindex Knuth +The system's C library random generator is used as a basis for +generating random numbers, since random number generation is a +system-dependent task. However, Knuth's Algorithm B is used to +shuffle the resultant values, which is enough to make even a stream of +consecutive integers random enough for most applications. + +(If you're worried about the quality of the random number generator, +well, you're using a statistical processing package---analyze it!) + +@cindex random numbers, normally-distributed +@deftypefn {Function} {} NORMAL (@var{number}) +Results in a random number. Results from @code{NORMAL} are normally +distributed with a mean of 0 and a standard deviation of @var{number}. +@end deftypefn + +@cindex random numbers, uniformly-distributed +@deftypefn {Function} {} UNIFORM (@var{number}) +Results in a random number between 0 and @var{number}. Results from +@code{UNIFORM} are evenly distributed across its entire range. There +may be a maximum on the largest random number ever generated---this is +often 2**31-1 (2,147,483,647), but it may be orders of magnitude +higher or lower. +@end deftypefn + +@node Set Membership, Statistical Functions, Pseudo-Random Numbers, Functions +@subsection Set-Membership Functions +@cindex set membership +@cindex membership, of set + +Set membership functions determine whether a value is a member of a set. +They take a set of numeric arguments or a set of string arguments, and +produce Boolean results. + +String comparisons are performed according to the rules given in +@ref{Relational Operators}. + +@deftypefn {Function} {} ANY (@var{value}, @var{set} [, @var{set}]@dots{}) +Results in true if @var{value} is equal to any of the @var{set} +values. Otherwise, results in false. If @var{value} is +system-missing, returns system-missing. System-missing values in +@var{set} do not cause ANY to return system-missing. +@end deftypefn + +@deftypefn {Function} {} RANGE (@var{value}, @var{low}, @var{high} [, @var{low}, @var{high}]@dots{}) +Results in true if @var{value} is in any of the intervals bounded by +@var{low} and @var{high} inclusive. Otherwise, results in false. +Each @var{low} must be less than or equal to its corresponding +@var{high} value. @var{low} and @var{high} must be given in pairs. +If @var{value} is system-missing, returns system-missing. +System-missing values in @var{set} do not cause RANGE to return +system-missing. +@end deftypefn + +@node Statistical Functions, String Functions, Set Membership, Functions +@subsection Statistical Functions +@cindex functions, statistical +@cindex statistics + +Statistical functions compute descriptive statistics on a list of +values. Some statistics can be computed on numeric or string values; +other can only be computed on numeric values. They result in the same +type as their arguments. + +@cindex arguments, minimum valid +@cindex minimum valid number of arguments +With statistical functions it is possible to specify a minimum number of +non-missing arguments for the function to be evaluated. To do so, +append a dot and the number to the function name. For instance, to +specify a minimum of three valid arguments to the MEAN function, use the +name @code{MEAN.3}. + +@cindex coefficient of variation +@cindex variation, coefficient of +@deftypefn {Function} {} CFVAR (@var{number}, @var{number}[, @dots{}]) +Results in the coefficient of variation of the values of @var{number}. +This function requires at least two valid arguments to give a +non-missing result. (The coefficient of variation is the standard +deviation divided by the mean.) +@end deftypefn + +@cindex maximum +@deftypefn {Function} {} MAX (@var{value}, @var{value}[, @dots{}]) +Results in the value of the greatest @var{value}. The @var{value}s may +be numeric or string. Although at least two arguments must be given, +only one need be valid for MAX to give a non-missing result. +@end deftypefn + +@cindex mean +@deftypefn {Function} {} MEAN (@var{number}, @var{number}[, @dots{}]) +Results in the mean of the values of @var{number}. Although at least +two arguments must be given, only one need be valid for MEAN to give a +non-missing result. +@end deftypefn + +@cindex minimum +@deftypefn {Function} {} MIN (@var{number}, @var{number}[, @dots{}]) +Results in the value of the least @var{value}. The @var{value}s may +be numeric or string. Although at least two arguments must be given, +only one need be valid for MAX to give a non-missing result. +@end deftypefn + +@cindex standard deviation +@cindex deviation, standard +@deftypefn {Function} {} SD (@var{number}, @var{number}[, @dots{}]) +Results in the standard deviation of the values of @var{number}. +This function requires at least two valid arguments to give a +non-missing result. +@end deftypefn + +@cindex sum +@deftypefn {Function} {} SUM (@var{number}, @var{number}[, @dots{}]) +Results in the sum of the values of @var{number}. Although at least two +arguments must be given, only one need by valid for SUM to give a +non-missing result. +@end deftypefn + +@cindex variance +@deftypefn {Function} {} VAR (@var{number}, @var{number}[, @dots{}]) +Results in the variance of the values of @var{number}. This function +requires at least two valid arguments to give a non-missing result. +@end deftypefn + +@deftypefn {Function} {} VARIANCE (@var{number}, @var{number}[, @dots{}]) +Results in the variance of the values of @var{number}. This function +requires at least two valid arguments to give a non-missing result. +(Use VAR in preference to VARIANCE for reasons of portability.) +@end deftypefn + +@node String Functions, Time & Date, Statistical Functions, Functions +@subsection String Functions +@cindex functions, string +@cindex string functions + +String functions take various arguments and return various results. + +@cindex concatenation +@cindex strings, concatenation of +@deftypefn {Function} {} CONCAT (@var{string}, @var{string}[, @dots{}]) +Returns a string consisting of each @var{string} in sequence. +@code{CONCAT("abc", "def", "ghi")} has a value of @code{"abcdefghi"}. +The resultant string is truncated to a maximum of 255 characters. +@end deftypefn + +@cindex searching strings +@deftypefn {Function} {} INDEX (@var{haystack}, @var{needle}) +Returns a positive integer indicating the position of the first +occurrence @var{needle} in @var{haystack}. Returns 0 if @var{haystack} +does not contain @var{needle}. Returns system-missing if @var{needle} +is an empty string. +@end deftypefn + +@deftypefn {Function} {} INDEX (@var{haystack}, @var{needle}, @var{divisor}) +Divides @var{needle} into parts, each with length @var{divisor}. +Searches @var{haystack} for the first occurrence of each part, and +returns the smallest value. Returns 0 if @var{haystack} does not +contain any part in @var{needle}. It is an error if @var{divisor} +cannot be evenly divided into the length of @var{needle}. Returns +system-missing if @var{needle} is an empty string. +@end deftypefn + +@cindex strings, finding length of +@deftypefn {Function} {} LENGTH (@var{string}) +Returns the number of characters in @var{string}. +@end deftypefn + +@cindex strings, case of +@deftypefn {Function} {} LOWER (@var{string}) +Returns a string identical to @var{string} except that all uppercase +letters are changed to lowercase letters. The definitions of +``uppercase'' and ``lowercase'' are system-dependent. +@end deftypefn + +@cindex strings, padding +@deftypefn {Function} {} LPAD (@var{string}, @var{length}) +If @var{string} is at least @var{length} characters in length, returns +@var{string} unchanged. Otherwise, returns @var{string} padded with +spaces on the left side to length @var{length}. Returns an empty string +if @var{length} is system-missing, negative, or greater than 255. +@end deftypefn + +@deftypefn {Function} {} LPAD (@var{string}, @var{length}, @var{padding}) +If @var{string} is at least @var{length} characters in length, returns +@var{string} unchanged. Otherwise, returns @var{string} padded with +@var{padding} on the left side to length @var{length}. Returns an empty +string if @var{length} is system-missing, negative, or greater than 255, or +if @var{padding} does not contain exactly one character. +@end deftypefn + +@cindex strings, trimming +@cindex whitespace, trimming +@deftypefn {Function} {} LTRIM (@var{string}) +Returns @var{string}, after removing leading spaces. Other whitespace, +such as tabs, carriage returns, line feeds, and vertical tabs, is not +removed. +@end deftypefn + +@deftypefn {Function} {} LTRIM (@var{string}, @var{padding}) +Returns @var{string}, after removing leading @var{padding} characters. +If @var{padding} does not contain exactly one character, returns an +empty string. +@end deftypefn + +@cindex numbers, converting from strings +@cindex strings, converting to numbers +@deftypefn {Function} {} NUMBER (@var{string}) +Returns the number produced when @var{string} is interpreted according +to format F@var{x}.0, where @var{x} is the number of characters in +@var{string}. If @var{string} does not form a proper number, +system-missing is returned without an error message. Portability: none. +@end deftypefn + +@deftypefn {Function} {} NUMBER (@var{string}, @var{format}) +Returns the number produced when @var{string} is interpreted according +to format specifier @var{format}. Only the number of characters in +@var{string} specified by @var{format} are examined. For example, +@code{NUMBER("123", F3.0)} and @code{NUMBER("1234", F3.0)} both have +value 123. If @var{string} does not form a proper number, +system-missing is returned without an error message. +@end deftypefn + +@cindex strings, searching backwards +@deftypefn {Function} {} RINDEX (@var{string}, @var{format}) +Returns a positive integer indicating the position of the last +occurrence of @var{needle} in @var{haystack}. Returns 0 if +@var{haystack} does not contain @var{needle}. Returns system-missing if +@var{needle} is an empty string. +@end deftypefn + +@deftypefn {Function} {} RINDEX (@var{haystack}, @var{needle}, @var{divisor}) +Divides @var{needle} into parts, each with length @var{divisor}. +Searches @var{haystack} for the last occurrence of each part, and +returns the largest value. Returns 0 if @var{haystack} does not contain +any part in @var{needle}. It is an error if @var{divisor} cannot be +evenly divided into the length of @var{needle}. Returns system-missing +if @var{needle} is an empty string. +@end deftypefn + +@cindex padding strings +@cindex strings, padding +@deftypefn {Function} {} RPAD (@var{string}, @var{length}) +If @var{string} is at least @var{length} characters in length, returns +@var{string} unchanged. Otherwise, returns @var{string} padded with +spaces on the right to length @var{length}. Returns an empty string if +@var{length} is system-missing, negative, or greater than 255. +@end deftypefn + +@deftypefn {Function} {} RPAD (@var{string}, @var{length}, @var{padding}) +If @var{string} is at least @var{length} characters in length, returns +@var{string} unchanged. Otherwise, returns @var{string} padded with +@var{padding} on the right to length @var{length}. Returns an empty +string if @var{length} is system-missing, negative, or greater than 255, +or if @var{padding} does not contain exactly one character. +@end deftypefn + +@cindex strings, trimming +@cindex whitespace, trimming +@deftypefn {Function} {} RTRIM (@var{string}) +Returns @var{string}, after removing trailing spaces. Other types of +whitespace are not removed. +@end deftypefn + +@deftypefn {Function} {} RTRIM (@var{string}, @var{padding}) +Returns @var{string}, after removing trailing @var{padding} characters. +If @var{padding} does not contain exactly one character, returns an +empty string. +@end deftypefn + +@cindex strings, converting from numbers +@cindex numbers, converting to strings +@deftypefn {Function} {} STRING (@var{number}, @var{format}) +Returns a string corresponding to @var{number} in the format given by +format specifier @var{format}. For example, @code{STRING(123.56, F5.1)} +has the value @code{"123.6"}. +@end deftypefn + +@cindex substrings +@cindex strings, taking substrings of +@deftypefn {Function} {} SUBSTR (@var{string}, @var{start}) +Returns a string consisting of the value of @var{string} from position +@var{start} onward. Returns an empty string if @var{start} is system-missing +or has a value less than 1 or greater than the number of characters in +@var{string}. +@end deftypefn + +@deftypefn {Function} {} SUBSTR (@var{string}, @var{start}, @var{count}) +Returns a string consisting of the first @var{count} characters from +@var{string} beginning at position @var{start}. Returns an empty string +if @var{start} or @var{count} is system-missing, if @var{start} is less +than 1 or greater than the number of characters in @var{string}, or if +@var{count} is less than 1. Returns a string shorter than @var{count} +characters if @var{start} + @var{count} - 1 is greater than the number +of characters in @var{string}. Examples: @code{SUBSTR("abcdefg", 3, 2)} +has value @code{"cd"}; @code{SUBSTR("Ben Pfaff", 5, 10)} has the value +@code{"Pfaff"}. +@end deftypefn + +@cindex case conversion +@cindex strings, case of +@deftypefn {Function} {} UPCASE (@var{string}) +Returns @var{string}, changing lowercase letters to uppercase letters. +@end deftypefn + +@node Time & Date, Miscellaneous Functions, String Functions, Functions +@subsection Time & Date Functions +@cindex functions, time & date +@cindex times +@cindex dates + +@cindex dates, legal range of +The legal range of dates for use in PSPP is 15 Oct 1582 +through 31 Dec 19999. + +@cindex arguments, invalid +@cindex invalid arguments +@quotation +@strong{Please note:} Most time & date extraction functions will accept +invalid arguments: + +@itemize @bullet +@item +Negative numbers in PSPP time format. +@item +Numbers less than 86,400 in PSPP date format. +@end itemize + +However, sensible results are not guaranteed for these invalid values. +The given equivalents for these functions are definitely not guaranteed +for invalid values. +@end quotation + +@quotation +@strong{Please note also:} The time & date construction +functions @strong{do} produce reasonable and useful results for +out-of-range values; these are not considered invalid. +@end quotation + +@menu +* Time & Date Concepts:: How times & dates are defined and represented +* Time Construction:: TIME.@{DAYS HMS@} +* Time Extraction:: CTIME.@{DAYS HOURS MINUTES SECONDS@} +* Date Construction:: DATE.@{DMY MDY MOYR QYR WKYR YRDAY@} +* Date Extraction:: XDATE.@{DATE HOUR JDAY MDAY MINUTE MONTH + QUARTER SECOND TDAY TIME WEEK + WKDAY YEAR@} +@end menu + +@node Time & Date Concepts, Time Construction, Time & Date, Time & Date +@subsubsection How times & dates are defined and represented + +@cindex time, concepts +@cindex time, intervals +Times and dates are handled by PSPP as single numbers. A +@dfn{time} is an interval. PSPP measures times in seconds. +Thus, the following intervals correspond with the numeric values given: + +@example + 10 minutes 600 + 1 hour 3,600 + 1 day, 3 hours, 10 seconds 97,210 + 40 days 3,456,000 + 10010 d, 14 min, 24 s 864,864,864 +@end example + +@cindex dates, concepts +@cindex time, instants of +A @dfn{date}, on the other hand, is a particular instant in the past or +the future. PSPP represents a date as a number of seconds after the +midnight that separated 8 Oct 1582 and 9 Oct 1582. (Please note that 15 +Oct 1582 immediately followed 9 Oct 1582.) Thus, the midnights before +the dates given below correspond with the numeric PSPP dates given: + +@example + 15 Oct 1582 86,400 + 4 Jul 1776 6,113,318,400 + 1 Jan 1900 10,010,390,400 + 1 Oct 1978 12,495,427,200 + 24 Aug 1995 13,028,601,600 +@end example + +@cindex time, mathematical properties of +@cindex mathematics, applied to times & dates +@cindex dates, mathematical properties of +@noindent +Please note: + +@itemize @bullet +@item +A time may be added to, or subtracted from, a date, resulting in a date. + +@item +The difference of two dates may be taken, resulting in a time. + +@item +Two times may be added to, or subtracted from, each other, resulting in +a time. +@end itemize + +(Adding two dates does not produce a useful result.) + +Since times and dates are merely numbers, the ordinary addition and +subtraction operators are employed for these purposes. + +@quotation +@strong{Please note:} Many dates and times have extremely large +values---just look at the values above. Thus, it is not a good idea to +take powers of these values; also, the accuracy of some procedures may +be affected. If necessary, convert times or dates in seconds to some +other unit, like days or years, before performing analysis. +@end quotation + +@node Time Construction, Time Extraction, Time & Date Concepts, Time & Date +@subsubsection Functions that Produce Times +@cindex times, constructing +@cindex constructing times + +These functions take numeric arguments and produce numeric results in +PSPP time format. + +@cindex days +@cindex time, in days +@deftypefn {Function} {} TIME.DAYS (@var{ndays}) +Results in a time value corresponding to @var{ndays} days. +(@code{TIME.DAYS(@var{x})} is equivalent to @code{@var{x} * 60 * 60 * +24}.) +@end deftypefn + +@cindex hours-minutes-seconds +@cindex time, in hours-minutes-seconds +@deftypefn {Function} {} TIME.HMS (@var{nhours}, @var{nmins}, @var{nsecs}) +Results in a time value corresponding to @var{nhours} hours, @var{nmins} +minutes, and @var{nsecs} seconds. (@code{TIME.HMS(@var{h}, @var{m}, +@var{s})} is equivalent to @code{@var{h}*60*60 + @var{m}*60 + +@var{s}}.) +@end deftypefn + +@node Time Extraction, Date Construction, Time Construction, Time & Date +@subsubsection Functions that Examine Times +@cindex extraction, of time +@cindex time examination +@cindex examination, of times +@cindex time, lengths of + +These functions take numeric arguments in PSPP time format and +give numeric results. + +@cindex days +@cindex time, in days +@deftypefn {Function} {} CTIME.DAYS (@var{time}) +Results in the number of days and fractional days in @var{time}. +(@code{CTIME.DAYS(@var{x})} is equivalent to @code{@var{x}/60/60/24}.) +@end deftypefn + +@cindex hours +@cindex time, in hours +@deftypefn {Function} {} CTIME.HOURS (@var{time}) +Results in the number of hours and fractional hours in @var{time}. +(@code{CTIME.HOURS(@var{x})} is equivalent to @code{@var{x}/60/60}.) +@end deftypefn + +@cindex minutes +@cindex time, in minutes +@deftypefn {Function} {} CTIME.MINUTES (@var{time}) +Results in the number of minutes and fractional minutes in @var{time}. +(@code{CTIME.MINUTES(@var{x})} is equivalent to @code{@var{x}/60}.) +@end deftypefn + +@cindex seconds +@cindex time, in seconds +@deftypefn {Function} {} CTIME.SECONDS (@var{time}) +Results in the number of seconds and fractional seconds in @var{time}. +(@code{CTIME.SECONDS} does nothing; @code{CTIME.SECONDS(@var{x})} is +equivalent to @code{@var{x}}.) +@end deftypefn + +@node Date Construction, Date Extraction, Time Extraction, Time & Date +@subsubsection Functions that Produce Dates +@cindex dates, constructing +@cindex constructing dates + +@cindex arguments, of date construction functions +These functions take numeric arguments and give numeric results in the +PSPP date format. Arguments taken by these functions are: + +@table @var +@item day +Refers to a day of the month between 1 and 31. + +@item month +Refers to a month of the year between 1 and 12. + +@item quarter +Refers to a quarter of the year between 1 and 4. The quarters of the +year begin on the first days of months 1, 4, 7, and 10. + +@item week +Refers to a week of the year between 1 and 53. + +@item yday +Refers to a day of the year between 1 and 366. + +@item year +Refers to a year between 1582 and 19999. +@end table + +@cindex arguments, invalid +If these functions' arguments are out-of-range, they are correctly +normalized before conversion to date format. Non-integers are rounded +toward zero. + +@cindex day-month-year +@cindex dates, day-month-year +@deftypefn {Function} {} DATE.DMY (@var{day}, @var{month}, @var{year}) +@deftypefnx {Function} {} DATE.MDY (@var{month}, @var{day}, @var{year}) +Results in a date value corresponding to the midnight before day +@var{day} of month @var{month} of year @var{year}. +@end deftypefn + +@cindex month-year +@cindex dates, month-year +@deftypefn {Function} {} DATE.MOYR (@var{month}, @var{year}) +Results in a date value corresponding to the midnight before the first +day of month @var{month} of year @var{year}. +@end deftypefn + +@cindex quarter-year +@cindex dates, quarter-year +@deftypefn {Function} {} DATE.QYR (@var{quarter}, @var{year}) +Results in a date value corresponding to the midnight before the first +day of quarter @var{quarter} of year @var{year}. +@end deftypefn + +@cindex week-year +@cindex dates, week-year +@deftypefn {Function} {} DATE.WKYR (@var{week}, @var{year}) +Results in a date value corresponding to the midnight before the first +day of week @var{week} of year @var{year}. +@end deftypefn + +@cindex year-day +@cindex dates, year-day +@deftypefn {Function} {} DATE.YRDAY (@var{year}, @var{yday}) +Results in a date value corresponding to the midnight before day +@var{yday} of year @var{year}. +@end deftypefn + +@node Date Extraction, , Date Construction, Time & Date +@subsubsection Functions that Examine Dates +@cindex extraction, of dates +@cindex date examination + +@cindex arguments, of date extraction functions +These functions take numeric arguments in PSPP date or time +format and give numeric results. These names are used for arguments: + +@table @var +@item date +A numeric value in PSPP date format. + +@item time +A numeric value in PSPP time format. + +@item time-or-date +A numeric value in PSPP time or date format. +@end table + +@cindex days +@cindex dates, in days +@cindex time, in days +@deftypefn {Function} {} XDATE.DATE (@var{time-or-date}) +For a time, results in the time corresponding to the number of whole +days @var{date-or-time} includes. For a date, results in the date +corresponding to the latest midnight at or before @var{date-or-time}; +that is, gives the date that @var{date-or-time} is in. +(XDATE.DATE(@var{x}) is equivalent to TRUNC(@var{x}/86400)*86400.) +Applying this function to a time is a Portability: none feature. +@end deftypefn + +@cindex hours +@cindex dates, in hours +@cindex time, in hours +@deftypefn {Function} {} XDATE.HOUR (@var{time-or-date}) +For a time, results in the number of whole hours beyond the number of +whole days represented by @var{date-or-time}. For a date, results in +the hour (as an integer between 0 and 23) corresponding to +@var{date-or-time}. (XDATE.HOUR(@var{x}) is equivalent to +MOD(TRUNC(@var{x}/3600),24)) Applying this function to a time is a +Portability: none feature. +@end deftypefn + +@cindex day of the year +@cindex dates, day of the year +@deftypefn {Function} {} XDATE.JDAY(@var{date}) +Results in the day of the year (as an integer between 1 and 366) +corresponding to @var{date}. +@end deftypefn + +@cindex day of the month +@cindex dates, day of the month +@deftypefn {Function} {} XDATE.MDAY(@var{date}) +Results in the day of the month (as an integer between 1 and 31) +corresponding to @var{date}. +@end deftypefn + +@cindex minutes +@cindex dates, in minutes +@cindex time, in minutes +@deftypefn {Function} {} XDATE.MINUTE(@var{time-or-date}) +Results in the number of minutes (as an integer between 0 and 59) after +the last hour in @var{time-or-date}. (XDATE.MINUTE(@var{x}) is +equivalent to MOD(TRUNC(@var{x}/60),60)) Applying this function to a +time is a Portability: none feature. +@end deftypefn + +@cindex months +@cindex dates, in months +@deftypefn {Function} {} XDATE.MONTH(@var{date}) +Results in the month of the year (as an integer between 1 and 12) +corresponding to @var{date}. +@end deftypefn + +@cindex quarters +@cindex dates, in quarters +@deftypefn {Function} {} XDATE.QUARTER(@var{date}) +Results in the quarter of the year (as an integer between 1 and 4) +corresponding to @var{date}. +@end deftypefn + +@cindex seconds +@cindex dates, in seconds +@cindex time, in seconds +@deftypefn {Function} {} XDATE.SECOND(@var{time-or-date}) +Results in the number of whole seconds after the last whole minute (as +an integer between 0 and 59) in @var{time-or-date}. +(XDATE.SECOND(@var{x}) is equivalent to MOD(@var{x}, 60).) Applying +this function to a time is a Portability: none feature. +@end deftypefn + +@cindex days +@cindex times, in days +@deftypefn {Function} {} XDATE.TDAY(@var{time}) +Results in the number of whole days (as an integer) in @var{time}. +(XDATE.TDAY(@var{x}) is equivalent to TRUNC(@var{x}/86400).) +@end deftypefn + +@cindex time +@cindex dates, time of day +@deftypefn {Function} {} XDATE.TIME(@var{date}) +Results in the time of day at the instant corresponding to @var{date}, +in PSPP time format. This is the number of seconds since +midnight on the day corresponding to @var{date}. (XDATE.TIME(@var{x}) is +equivalent to TRUNC(@var{x}/86400)*86400.) +@end deftypefn + +@cindex week +@cindex dates, in weeks +@deftypefn {Function} {} XDATE.WEEK(@var{date}) +Results in the week of the year (as an integer between 1 and 53) +corresponding to @var{date}. +@end deftypefn + +@cindex day of the week +@cindex weekday +@cindex dates, day of the week +@cindex dates, in weekdays +@deftypefn {Function} {} XDATE.WKDAY(@var{date}) +Results in the day of week (as an integer between 1 and 7) corresponding +to @var{date}. The days of the week are: + +@table @asis +@item 1 +Sunday +@item 2 +Monday +@item 3 +Tuesday +@item 4 +Wednesday +@item 5 +Thursday +@item 6 +Friday +@item 7 +Saturday +@end table +@end deftypefn + +@cindex years +@cindex dates, in years +@deftypefn {Function} {} XDATE.YEAR (@var{date}) +Returns the year (as an integer between 1582 and 19999) corresponding to +@var{date}. +@end deftypefn + +@node Miscellaneous Functions, Functions Not Implemented, Time & Date, Functions +@subsection Miscellaneous Functions +@cindex functions, miscellaneous + +Miscellaneous functions take various arguments and produce various +results. + +@cindex cross-case function +@cindex function, cross-case +@deftypefn {Function} {} LAG (@var{variable}) +@var{variable} must be a numeric or string variable name. @code{LAG} +results in the value of that variable for the case before the current +one. In case-selection procedures, @code{LAG} results in the value of +the variable for the last case selected. Results in system-missing (for +numeric variables) or blanks (for string variables) for the first case +or before any cases are selected. +@end deftypefn + +@deftypefn {Function} {} LAG (@var{variable}, @var{ncases}) +@var{variable} must be a numeric or string variable name. @var{ncases} +must be a small positive constant integer, although there is no explicit +limit. (Use of a large value for @var{ncases} will increase memory +consumption, since PSPP must keep @var{ncases} cases in memory.) +@code{LAG (@var{variable}, @var{ncases}} results in the value of +@var{variable} that is @var{ncases} before the case currently being +processed. See @code{LAG (@var{variable})} above for more details. +@end deftypefn + +@cindex date, Julian +@cindex Julian date +@deftypefn {Function} {} YRMODA (@var{year}, @var{month}, @var{day}) +@var{year} is a year between 0 and 199 or 1582 and 19999. @var{month} is +a month between 1 and 12. @var{day} is a day between 1 and 31. If +@var{month} or @var{day} is out-of-range, it changes the next higher +unit. For instance, a @var{day} of 0 refers to the last day of the +previous month, and a @var{month} of 13 refers to the first month of the +next year. @var{year} must be in range. If @var{year} is between 0 and +199, 1900 is added. @var{year}, @var{month}, and @var{day} must all be +integers. + +@code{YRMODA} results in the number of days between 15 Oct 1582 and +the date specified, plus one. The date passed to @code{YRMODA} must be +on or after 15 Oct 1582. 15 Oct 1582 has a value of 1. +@end deftypefn + +@node Functions Not Implemented, , Miscellaneous Functions, Functions +@subsection Functions Not Implemented +@cindex functions, not implemented +@cindex not implemented +@cindex features, not implemented + +These functions are not yet implemented and thus not yet documented, +since it's a hassle. + +@findex CDF.xxx +@findex CDFNORM +@findex IDF.xxx +@findex NCDF.xxx +@findex PROBIT +@findex RV.xxx + +@itemize @bullet +@item +@code{CDF.xxx} +@item +@code{CDFNORM} +@item +@code{IDF.xxx} +@item +@code{NCDF.xxx} +@item +@code{PROBIT} +@item +@code{RV.xxx} +@end itemize + +@node Order of Operations, , Functions, Expressions +@section Operator Precedence +@cindex operator precedence +@cindex precedence, operator +@cindex order of operations +@cindex operations, order of + +The following table describes operator precedence. Smaller-numbered +levels in the table have higher precedence. Within a level, operations +are performed from left to right, except for level 2 (exponentiation), +where operations are performed from right to left. If an operator +appears in the table in two places (@code{-}), the first occurrence is +unary, the second is binary. + +@enumerate +@item +@code{( )} +@item +@code{**} +@item +@code{-} +@item +@code{* /} +@item +@code{+ -} +@item +@code{EQ GE GT LE LT NE} +@item +@code{AND NOT OR} +@end enumerate + +@node Data Input and Output, System and Portable Files, Expressions, Top +@chapter Data Input and Output +@cindex input +@cindex output +@cindex data + +Data is the focus of the PSPP language. This chapter examines +the PSPP commands for defining variables and reading and writing data. + +@quotation +@strong{Please note:} Data is not actually read until a procedure is +executed. These commands tell PSPP how to read data, but they +do not @emph{cause} PSPP to read data. +@end quotation + +@menu +* BEGIN DATA:: Embed data within a syntax file. +* CLEAR TRANSFORMATIONS:: Clear pending transformations. +* DATA LIST:: Fundamental data reading command. +* END CASE:: Output the current case. +* END FILE:: Terminate the current input program. +* FILE HANDLE:: Support for fixed-length records. +* INPUT PROGRAM:: Support for complex input programs. +* LIST:: List cases in the active file. +* MATRIX DATA:: Read matrices in text format. +* NEW FILE:: Clear the active file and dictionary. +* PRINT:: Display values in print formats. +* PRINT EJECT:: Eject the current page then print. +* PRINT SPACE:: Print blank lines. +* REREAD:: Take another look at the previous input line. +* REPEATING DATA:: Multiple cases on a single line. +* WRITE:: Display values in write formats. +@end menu + +@node BEGIN DATA, CLEAR TRANSFORMATIONS, Data Input and Output, Data Input and Output +@section BEGIN DATA +@vindex BEGIN DATA +@vindex END DATA +@cindex Embedding data in syntax files +@cindex Data, embedding in syntax files + +@display +BEGIN DATA. +@dots{} +END DATA. +@end display + +BEGIN DATA and END DATA can be used to embed raw ASCII data in a PSPP +syntax file. DATA LIST or another input procedure must be used before +BEGIN DATA (@pxref{DATA LIST}). BEGIN DATA and END DATA must be used +together. The END DATA command must appear by itself on a single line, +with no leading whitespace and exactly one space between the words +@code{END} and @code{DATA}, followed immediately by the terminal dot, +like this: + +@example +END DATA. +@end example + +@node CLEAR TRANSFORMATIONS, DATA LIST, BEGIN DATA, Data Input and Output +@section CLEAR TRANSFORMATIONS +@vindex CLEAR TRANSFORMATIONS + +@display +CLEAR TRANSFORMATIONS. +@end display + +The CLEAR TRANSFORMATIONS command clears out all pending +transformations. It does not cancel the current input program. It is +valid only when PSPP is interactive, not in syntax files. + +@node DATA LIST, END CASE, CLEAR TRANSFORMATIONS, Data Input and Output +@section DATA LIST +@vindex DATA LIST +@cindex reading data from a file +@cindex data, reading from a file +@cindex data, embedding in syntax files +@cindex embedding data in syntax files + +Used to read text or binary data, DATA LIST is the most +fundamental data-reading command. Even the more sophisticated input +methods use DATA LIST commands as a building block. +Understanding DATA LIST is important to understanding how to use +PSPP to read your data files. + +There are two major variants of DATA LIST, which are fixed +format and free format. In addition, free format has a minor variant, +list format, which is discussed in terms of its differences from vanilla +free format. + +Each form of DATA LIST is described in detail below. + +@menu +* DATA LIST FIXED:: Fixed columnar locations for data. +* DATA LIST FREE:: Any spacing you like. +* DATA LIST LIST:: Each case must be on a single line. +@end menu + +@node DATA LIST FIXED, DATA LIST FREE, DATA LIST, DATA LIST +@subsection DATA LIST FIXED +@vindex DATA LIST FIXED +@cindex reading fixed-format data +@cindex fixed-format data, reading +@cindex data, fixed-format, reading +@cindex embedding fixed-format data + +@display +DATA LIST [FIXED] + @{TABLE,NOTABLE@} + FILE='filename' + RECORDS=record_count + END=end_var + /[line_no] var_spec@dots{} + +where each var_spec takes one of the forms + var_list start-end [type_spec] + var_list (fortran_spec) +@end display + +DATA LIST FIXED is used to read data files that have values at fixed +positions on each line of single-line or multiline records. The +keyword FIXED is optional. + +The FILE subcommand must be used if input is to be taken from an +external file. It may be used to specify a filename as a string or a +file handle (@pxref{FILE HANDLE}). If the FILE subcommand is not used, +then input is assumed to be specified within the command file using +BEGIN DATA@dots{}END DATA (@pxref{BEGIN DATA}). + +The optional RECORDS subcommand, which takes a single integer as an +argument, is used to specify the number of lines per record. If RECORDS +is not specified, then the number of lines per record is calculated from +the list of variable specifications later in the DATA LIST command. + +The END subcommand is only useful in conjunction with the INPUT PROGRAM +input procedure, and for that reason it is not discussed here +(@pxref{INPUT PROGRAM}). + +DATA LIST can optionally output a table describing how the data file +will be read. The TABLE subcommand enables this output, and NOTABLE +disables it. The default is to output the table. + +The list of variables to be read from the data list must come last in +the DATA LIST command. Each line in the data record is introduced by a +slash (@samp{/}). Optionally, a line number may follow the slash. +Following, any number of variable specifications may be present. + +Each variable specification consists of a list of variable names +followed by a description of their location on the input line. Sets of +variables may specified using DATA LIST's TO convention (@pxref{Sets of +Variables}). There are two ways to specify the location of the variable +on the line: SPSS style and FORTRAN style. + +With SPSS style, the starting column and ending column for the field +are specified after the variable name, separated by a dash (@samp{-}). +For instance, the third through fifth columns on a line would be +specified @samp{3-5}. By default, variables are considered to be in +@samp{F} format (@pxref{Input/Output Formats}). (This default can be +changed; see @ref{SET} for more information.) + +When using SPSS style, to use a variable format other than the default, +specify the format type in parentheses after the column numbers. For +instance, for alphanumeric @samp{A} format, use @samp{(A)}. + +In addition, implied decimal places can be specified in parentheses +after the column numbers. As an example, suppose that a data file has a +field in which the characters @samp{1234} should be interpreted as +having the value 12.34. Then this field has two implied decimal places, +and the corresponding specification would be @samp{(2)}. If a field +that has implied decimal places contains a decimal point, then the +implied decimal places are not applied. + +Changing the variable format and adding implied decimal places can be +done together; for instance, @samp{(N,5)}. + +When using SPSS style, the input and output width of each variable is +computed from the field width. The field width must be evenly divisible +into the number of variables specified. + +FORTRAN style is an altogether different approach to specifying field +locations. With this approach, a list of variable input format +specifications, separated by commas, are placed after the variable names +inside parentheses. Each format specifier advances as many characters +into the input line as it uses. + +In addition to the standard format specifiers (@pxref{Input/Output +Formats}), FORTRAN style defines some extensions: + +@table @asis +@item @code{X} +Advance the current column on this line by one character position. + +@item @code{T}@var{x} +Set the current column on this line to column @var{x}, with column +numbers considered to begin with 1 at the left margin. + +@item @code{NEWREC}@var{x} +Skip forward @var{x} lines in the current record, resetting the active +column to the left margin. + +@item Repeat count +Any format specifier may be preceded by a number. This causes the +action of that format specifier to be repeated the specified number of +times. + +@item (@var{spec1}, @dots{}, @var{specN}) +Group the given specifiers together. This is most useful when preceded +by a repeat count. Groups may be nested arbitrarily. +@end table + +FORTRAN and SPSS styles may be freely intermixed. SPSS style leaves the +active column immediately after the ending column specified. Record +motion using @code{NEWREC} in FORTRAN style also applies to later +FORTRAN and SPSS specifiers. + +@menu +* DATA LIST FIXED Examples:: Examples of DATA LIST FIXED. +@end menu + +@node DATA LIST FIXED Examples, , DATA LIST FIXED, DATA LIST FIXED +@unnumberedsubsubsec Examples + +@enumerate +@item +@example +DATA LIST TABLE /NAME 1-10 (A) INFO1 TO INFO3 12-17 (1). + +BEGIN DATA. +John Smith 102311 +Bob Arnold 122015 +Bill Yates 918 6 +END DATA. +@end example + +Defines the following variables: + +@itemize @bullet +@item +@code{NAME}, a 10-character-wide long string variable, in columns 1 +through 10. + +@item +@code{INFO1}, a numeric variable, in columns 12 through 13. + +@item +@code{INFO2}, a numeric variable, in columns 14 through 15. + +@item +@code{INFO3}, a numeric variable, in columns 16 through 17. +@end itemize + +The @code{BEGIN DATA}/@code{END DATA} commands cause three cases to be +defined: + +@example +Case NAME INFO1 INFO2 INFO3 + 1 John Smith 10 23 11 + 2 Bob Arnold 12 20 15 + 3 Bill Yates 9 18 6 +@end example + +The @code{TABLE} keyword causes PSPP to print out a table +describing the four variables defined. + +@item +@example +DAT LIS FIL="survey.dat" + /ID 1-5 NAME 7-36 (A) SURNAME 38-67 (A) MINITIAL 69 (A) + /Q01 TO Q50 7-56 + /. +@end example + +Defines the following variables: + +@itemize @bullet +@item +@code{ID}, a numeric variable, in columns 1-5 of the first record. + +@item +@code{NAME}, a 30-character long string variable, in columns 7-36 of the +first record. + +@item +@code{SURNAME}, a 30-character long string variable, in columns 38-67 of +the first record. + +@item +@code{MINITIAL}, a 1-character short string variable, in column 69 of +the first record. + +@item +Fifty variables @code{Q01}, @code{Q02}, @code{Q03}, @dots{}, @code{Q49}, +@code{Q50}, all numeric, @code{Q01} in column 7, @code{Q02} in column 8, +@dots{}, @code{Q49} in column 55, @code{Q50} in column 56, all in the second +record. +@end itemize + +Cases are separated by a blank record. + +Data is read from file @file{survey.dat} in the current directory. + +This example shows keywords abbreviated to their first 3 letters. + +@end enumerate + +@node DATA LIST FREE, DATA LIST LIST, DATA LIST FIXED, DATA LIST +@subsection DATA LIST FREE +@vindex DATA LIST FREE + +@display +DATA LIST FREE + [@{NOTABLE,TABLE@}] + FILE='filename' + END=end_var + /var_spec@dots{} + +where each var_spec takes one of the forms + var_list [(type_spec)] + var_list * +@end display + +In free format, the input data is structured as a series of comma- or +whitespace-delimited fields (end of line is one form of whitespace; it +is not treated specially). Field contents may be surrounded by matched +pairs of apostrophes (@samp{'}) or quotes (@samp{"}), or they may be +unenclosed. For any type of field leading white space (up to the +apostrophe or quote, if any) is not included in the field. + +Multiple consecutive delimiters are equivalent to a single delimiter. +To specify an empty field, write an empty set of single or double +quotes; for instance, @samp{""}. + +The NOTABLE and TABLE subcommands are as in DATA LIST FIXED above. +NOTABLE is the default. + +The FILE and END subcommands are as in DATA LIST FIXED above. + +The variables to be parsed are given as a single list of variable names. +This list must be introduced by a single slash (@samp{/}). The set of +variable names may contain format specifications in parentheses +(@pxref{Input/Output Formats}). Format specifications apply to all +variables back to the previous parenthesized format specification. + +In addition, an asterisk may be used to indicate that all variables +preceding it are to have input/output format @samp{F8.0}. + +Specified field widths are ignored on input, although all normal limits +on field width apply, but they are honored on output. + +@node DATA LIST LIST, , DATA LIST FREE, DATA LIST +@subsection DATA LIST LIST +@vindex DATA LIST LIST + +@display +DATA LIST LIST + [@{NOTABLE,TABLE@}] + FILE='filename' + END=end_var + /var_spec@dots{} + +where each var_spec takes one of the forms + var_list [(type_spec)] + var_list * +@end display + +Syntactically and semantically, DATA LIST LIST is equivalent to DATA +LIST FREE, with one exception: each input line is expected to correspond +to exactly one input record. If more or fewer fields are found on an +input line than expected, an appropriate diagnostic is issued. + +@node END CASE, END FILE, DATA LIST, Data Input and Output +@section END CASE +@vindex END CASE + +@display +END CASE. +@end display + +END CASE is used within INPUT PROGRAM to output the current case. +@xref{INPUT PROGRAM}. + +@node END FILE, FILE HANDLE, END CASE, Data Input and Output +@section END FILE +@vindex END FILE + +@display +END FILE. +@end display + +END FILE is used within INPUT PROGRAM to terminate the current input +program. @xref{INPUT PROGRAM}. + +@node FILE HANDLE, INPUT PROGRAM, END FILE, Data Input and Output +@section FILE HANDLE +@vindex FILE HANDLE + +@display +FILE HANDLE handle_name + /NAME='filename' + /RECFORM=@{VARIABLE,FIXED,SPANNED@} + /LRECL=rec_len + /MODE=@{CHARACTER,IMAGE,BINARY,MULTIPUNCH,360@} +@end display + +Use the FILE HANDLE command to define the attributes of a file that does +not use conventional variable-length records terminated by newline +characters. + +Specify the file handle name as an identifier. Any given identifier may +only appear once in a PSPP run. File handles may not be reassigned to a +different file. The file handle name must immediately follow the FILE +HANDLE command name. + +The NAME subcommand specifies the name of the file associated with the +handle. It is the only required subcommand. + +The RECFORM subcommand specifies how the file is laid out. VARIABLE +specifies variable-length lines terminated with newlines, and it is the +default. FIXED specifies fixed-length records. SPANNED is not +supported. + +LRECL specifies the length of fixed-length records. It is required if +@code{/RECFORM FIXED} is specified. + +MODE specifies a file mode. CHARACTER, the default, causes the data +file to be opened in ANSI C text mode. BINARY causes the data file to +be opened in ANSI C binary mode. The other possibilities are not +supported. + +@node INPUT PROGRAM, LIST, FILE HANDLE, Data Input and Output +@section INPUT PROGRAM +@vindex INPUT PROGRAM + +@display +INPUT PROGRAM. +@dots{} input commands @dots{} +END INPUT PROGRAM. +@end display + +The INPUT PROGRAM@dots{}END INPUT PROGRAM construct is used to specify a +complex input program. By placing data input commands within INPUT +PROGRAM, PSPP programs can take advantage of more complex file +structures than available by using DATA LIST by itself. + +The first sort of extended input program is to simply put multiple DATA +LIST commands within the INPUT PROGRAM. This will cause all of the data +files to be read in parallel. Input will stop when end of file is +reached on any of the data files. + +Transformations, such as conditional and looping constructs, can also be +included within an INPUT PROGRAM. These can be used to combine input +from several data files in more complex ways. However, input will still +stop when end of file is reached on any of the data files. + +To prevent INPUT PROGRAM from terminating at the first end of file, use +the END subcommand on DATA LIST. This subcommand takes a variable name, +which should be a numeric scratch variable (@pxref{Scratch Variables}). +(It need not be a scratch variable but otherwise the results can be +surprising.) The value of this variable is set to 0 when reading the +data file, or 1 when end of file is encountered. + +Some additional commands are useful in conjunction with INPUT PROGRAM. +END CASE is the first one. Normally each loop through the INPUT PROGRAM +structure produces one case. But with END CASE you can control exactly +when cases are output. When END CASE is used, looping from the end of +INPUT PROGRAM to the beginning does not cause a case to be output. + +END FILE is the other command. When the END subcommand is used on DATA +LIST, there is no way for the INPUT PROGRAM construct to stop looping, +so an infinite loop results. The END FILE command, when executed, +stops the flow of input data and passes out of the INPUT PROGRAM +structure. + +All this is very confusing. A few examples should help to clarify. + +@example +INPUT PROGRAM. + DATA LIST NOTABLE FILE='a.data'/X 1-10. + DATA LIST NOTABLE FILE='b.data'/Y 1-10. +END INPUT PROGRAM. +LIST. +@end example + +The example above reads variable X from file @file{a.data} and variable +Y from file @file{b.data}. If one file is shorter than the other then +the extra data in the longer file is ignored. + +@example +INPUT PROGRAM. + NUMERIC #A #B. + + DO IF NOT #A. + DATA LIST NOTABLE END=#A FILE='a.data'/X 1-10. + END IF. + DO IF NOT #B. + DATA LIST NOTABLE END=#B FILE='b.data'/Y 1-10. + END IF. + DO IF #A AND #B. + END FILE. + END IF. + END CASE. +END INPUT PROGRAM. +LIST. +@end example + +This example reads variable X from @file{a.data} and variable Y from +@file{b.data}. If one file is shorter than the other then the missing +field is set to the system-missing value alongside the present value for +the remaining length of the longer file. + +@example +INPUT PROGRAM. + NUMERIC #A #B. + + DO IF #A. + DATA LIST NOTABLE END=#B FILE='b.data'/X 1-10. + DO IF #B. + END FILE. + ELSE. + END CASE. + END IF. + ELSE. + DATA LIST NOTABLE END=#A FILE='a.data'/X 1-10. + DO IF NOT #A. + END CASE. + END IF. + END IF. +END INPUT PROGRAM. +LIST. +@end example + +The above example reads data from file @file{a.data}, then from +@file{b.data}, and concatenates them into a single active file. + +@example +INPUT PROGRAM. + NUMERIC #EOF. + + LOOP IF NOT #EOF. + DATA LIST NOTABLE END=#EOF FILE='a.data'/X 1-10. + DO IF NOT #EOF. + END CASE. + END IF. + END LOOP. + + COMPUTE #EOF = 0. + LOOP IF NOT #EOF. + DATA LIST NOTABLE END=#EOF FILE='b.data'/X 1-10. + DO IF NOT #EOF. + END CASE. + END IF. + END LOOP. + + END FILE. +END INPUT PROGRAM. +LIST. +@end example + +The above example does the same thing as the previous example, in a +different way. + +@example +INPUT PROGRAM. + LOOP #I=1 TO 50. + COMPUTE X=UNIFORM(10). + END CASE. + END LOOP. + END FILE. +END INPUT PROGRAM. +LIST/FORMAT=NUMBERED. +@end example + +The above example causes an active file to be created consisting of 50 +random variates between 0 and 10. + +@node LIST, MATRIX DATA, INPUT PROGRAM, Data Input and Output +@section LIST +@vindex LIST + +@display +LIST + /VARIABLES=var_list + /CASES=FROM start_index TO end_index BY incr_index + /FORMAT=@{UNNUMBERED,NUMBERED@} @{WRAP,SINGLE@} + @{NOWEIGHT,WEIGHT@} +@end display + +The LIST procedure prints the values of specified variables to the +listing file. + +The VARIABLES subcommand specifies the variables whose values are to be +printed. Keyword VARIABLES is optional. If VARIABLES subcommand is not +specified then all variables in the active file are printed. + +The CASES subcommand can be used to specify a subset of cases to be +printed. Specify FROM and the case number of the first case to print, +TO and the case number of the last case to print, and BY and the number +of cases to advance between printing cases, or any subset of those +settings. If CASES is not specified then all cases are printed. + +The FORMAT subcommand can be used to change the output format. NUMBERED +will print case numbers along with each case; UNNUMBERED, the default, +causes the case numbers to be omitted. The WRAP and SINGLE settings are +currently not used. WEIGHT will cause case weights to be printed along +with variable values; NOWEIGHT, the default, causes case weights to be +omitted from the output. + +Case numbers start from 1. They are counted after all transformations +have been considered. + +LIST will attempt to fit all the values on a single line. If necessary, +variable names will be display vertically in order to fit. If values +cannot fit on a single line, then a multi-line format will be used. + +LIST is a procedure. It causes the data to be read. + +@node MATRIX DATA, NEW FILE, LIST, Data Input and Output +@section MATRIX DATA +@vindex MATRIX DATA + +@display +MATRIX DATA + /VARIABLES=var_list + /FILE='filename' + /FORMAT=@{LIST,FREE@} @{LOWER,UPPER,FULL@} @{DIAGONAL,NODIAGONAL@} + /SPLIT=@{new_var,var_list@} + /FACTORS=var_list + /CELLS=n_cells + /N=n + /CONTENTS=@{N_VECTOR,N_SCALAR,N_MATRIX,MEAN,STDDEV,COUNT,MSE, + DFE,MAT,COV,CORR,PROX@} +@end display + +The MATRIX DATA command reads square matrices in one of several textual +formats. MATRIX DATA clears the dictionary and replaces it and reads a +data file. + +Use VARIABLES to specify the variables that form the rows and columns of +the matrices. You may not specify a variable named VARNAME_. You +should specify VARIABLES first. + +Specify the file to read on FILE, either as a file name string or a file +handle (@pxref{FILE HANDLE}). If FILE is not specified then matrix data +must immediately follow MATRIX DATA with a BEGIN DATA@dots{}END DATA +construct (@pxref{BEGIN DATA}). + +The FORMAT subcommand specifies how the matrices are formatted. LIST, +the default, indicates that there is one line per row of matrix data; +FREE allows single matrix rows to be broken across multiple lines. This +is analogous to the difference between DATA LIST FREE and DATA LIST LIST +(@pxref{DATA LIST}). LOWER, the default, indicates that the lower +triangle of the matrix is given; UPPER indicates the upper triangle; and +FULL indicates that the entire matrix is given. DIAGONAL, the default, +indicates that the diagonal is part of the data; NODIAGONAL indicates +that it is omitted. DIAGONAL/NODIAGONAL have no effect when FULL is +specified. + +The SPLIT subcommand is used to specify SPLIT FILE variables for the +input matrices (@pxref{SPLIT FILE}). Specify either a single variable +not specified on VARIABLES, or one or more variables that are specified +on VARIABLES. In the former case, the SPLIT values are not present in +the data and ROWTYPE_ may not be specified on VARIABLES. In the latter +case, the SPLIT values are present in the data. + +Specify a list of factor variables on FACTORS. Factor variables must +also be listed on VARIABLES. Factor variables are used when there are +some variables where, for each possible combination of their values, +statistics on the matrix variables are included in the data. + +If FACTORS is specified and ROWTYPE_ is not specified on VARIABLES, the +CELLS subcommand is required. Specify the number of factor variable +combinations that are given. For instance, if factor variable A has 2 +values and factor variable B has 3 values, specify 6. + +The N subcommand specifies a population number of observations. When N +is specified, one N record is output for each SPLIT FILE. + +Use CONTENTS to specify what sort of information the matrices include. +Each possible option is described in more detail below. When ROWTYPE_ +is specified on VARIABLES, CONTENTS is optional; otherwise, if CONTENTS +is not specified then /CONTENTS=CORR is assumed. + +@table @asis +@item N +@item N_VECTOR +Number of observations as a vector, one value for each variable. +@item N_SCALAR +Number of observations as a single value. +@item N_MATRIX +Matrix of counts. +@item MEAN +Vector of means. +@item STDDEV +Vector of standard deviations. +@item COUNT +Vector of counts. +@item MSE +Vector of mean squared errors. +@item DFE +Vector of degrees of freedom. +@item MAT +Generic matrix. +@item COV +Covariance matrix. +@item CORR +Correlation matrix. +@item PROX +Proximities matrix. +@end table + +The exact semantics of the matrices read by MATRIX DATA are complex. +Right now MATRIX DATA isn't too useful due to a lack of procedures +accepting or producing related data, so these semantics aren't +documented. Later, they'll be described here in detail. + +@node NEW FILE, PRINT, MATRIX DATA, Data Input and Output +@section NEW FILE +@vindex NEW FILE + +@display +NEW FILE. +@end display + +The NEW FILE command clears the current active file. + +@node PRINT, PRINT EJECT, NEW FILE, Data Input and Output +@section PRINT +@vindex PRINT + +@display +PRINT + OUTFILE='filename' + RECORDS=n_lines + @{NOTABLE,TABLE@} + /[line_no] arg@dots{} + +arg takes one of the following forms: + 'string' [start-end] + var_list start-end [type_spec] + var_list (fortran_spec) + var_list * +@end display + +The PRINT transformation writes variable data to an output file. PRINT +is executed when a procedure causes the data to be read. In order to +execute the PRINT transformation without invoking a procedure, use the +EXECUTE command (@pxref{EXECUTE}). + +All PRINT subcommands are optional. + +The OUTFILE subcommand specifies the file to receive the output. The +file may be a file name as a string or a file handle (@pxref{FILE +HANDLE}). If OUTFILE is not present then output will be sent to PSPP's +output listing file. + +The RECORDS subcommand specifies the number of lines to be output. The +number of lines may optionally be surrounded by parentheses. + +TABLE will cause the PRINT command to output a table to the listing file +that describes what it will print to the output file. NOTABLE, the +default, suppresses this output table. + +Introduce the strings and variables to be printed with a slash +(@samp{/}). Optionally, the slash may be followed by a number +indicating which output line will be specified. In the absence of this +line number, the next line number will be specified. Multiple lines may +be specified using multiple slashes with the intended output for a line +following its respective slash. + +Literal strings may be printed. Specify the string itself. Optionally +the string may be followed by a column number or range of column +numbers, specifying the location on the line for the string to be +printed. Otherwise, the string will be printed at the current position +on the line. + +Variables to be printed can be specified in the same ways as available +for DATA LIST FIXED (@pxref{DATA LIST FIXED}). In addition, a variable +list may be followed by an asterisk (@samp{*}), which indicates that the +variables should be printed in their dictionary print formats, separated +by spaces. A variable list followed by a slash or the end of command +will be interpreted the same way. + +If a FORTRAN type specification is used to move backwards on the current +line, then text is written at that point on the line, the line will be +truncated to that length, although additional text being added will +again extend the line to that length. + +@node PRINT EJECT, PRINT SPACE, PRINT, Data Input and Output +@section PRINT EJECT +@vindex PRINT EJECT + +@display +PRINT EJECT + OUTFILE='filename' + RECORDS=n_lines + @{NOTABLE,TABLE@} + /[line_no] arg@dots{} + +arg takes one of the following forms: + 'string' [start-end] + var_list start-end [type_spec] + var_list (fortran_spec) + var_list * +@end display + +PRINT EJECT is used to write data to an output file. Before the data is +written, the current page in the listing file is ejected. + +@xref{PRINT}, for more information on syntax and usage. + +@node PRINT SPACE, REREAD, PRINT EJECT, Data Input and Output +@section PRINT SPACE +@vindex PRINT SPACE + +@display +PRINT SPACE OUTFILE='filename' n_lines. +@end display + +The PRINT SPACE prints one or more blank lines to an output file. + +The OUTFILE subcommand is optional. It may be used to direct output to +a file specified by file name as a string or file handle (@pxref{FILE +HANDLE}). If OUTFILE is not specified then output will be directed to +the listing file. + +n_lines is also optional. If present, it is an expression +(@pxref{Expressions}) specifying the number of blank lines to be +printed. The expression must evaluate to a nonnegative value. + +@node REREAD, REPEATING DATA, PRINT SPACE, Data Input and Output +@section REREAD +@vindex REREAD + +@display +REREAD FILE=handle COLUMN=column. +@end display + +The REREAD transformation allows the previous input line in a data file +already processed by DATA LIST or another input command to be re-read +for further processing. + +The FILE subcommand, which is optional, is used to specify the file to +have its line re-read. The file must be specified in the form of a file +handle (@pxref{FILE HANDLE}). If FILE is not specified then the last +file specified on DATA LIST will be assumed (last file specified +lexically, not in terms of flow-of-control). + +By default, the line re-read is re-read in its entirety. With the +COLUMN subcommand, a prefix of the line can be exempted from +re-reading. Specify an expression (@pxref{Expressions}) evaluating to +the first column that should be included in the re-read line. Columns +are numbered from 1 at the left margin. + +Multiple REREAD commands will not back up in the data file. Instead, +they will re-read the same line multiple times. + +@node REPEATING DATA, WRITE, REREAD, Data Input and Output +@section REPEATING DATA +@vindex REPEATING DATA + +@display +REPEATING DATA + /STARTS=start-end + /OCCURS=n_occurs + /FILE='filename' + /LENGTH=length + /CONTINUED[=cont_start-cont_end] + /ID=id_start-id_end=id_var + /@{TABLE,NOTABLE@} + /DATA=var_spec@dots{} + +where each var_spec takes one of the forms + var_list start-end [type_spec] + var_list (fortran_spec) +@end display + +The REPEATING DATA command is used to parse groups of data repeating in +a uniform format, possibly with several groups on a single line. Each +group of data corresponds with one case. REPEATING DATA may only be +used within an INPUT PROGRAM structure. When used with DATA LIST, it +can be used to parse groups of cases that share a subset of variables +but differ in their other data. + +The STARTS subcommand is required. Specify a range of columns, using +literal numbers or numeric variable names. This range specifies the +columns on the first line that are used to contain groups of data. The +ending column is optional. If it is not specified, then the record +width of the input file is used. For the inline file (@pxref{BEGIN +DATA}) this is 80 columns; for a file with fixed record widths it is the +record width; for other files it is 1024 characters by default. + +The OCCURS subcommand is required. It must be a number or the name of a +numeric variable. Its value is the number of groups present in the +current record. + +The DATA subcommand is required. It must be the last subcommand +specified. It is used to specify the data present within each repeating +group. Column numbers are specified relative to the beginning of a +group at column 1. Data is specified in the same way as with DATA LIST +FIXED (@pxref{DATA LIST FIXED}). + +All other subcommands are optional. + +FILE specifies the file to read, either a file name as a string or a +file handle (@pxref{FILE HANDLE}). If FILE is not present then the +default is the last file handle used on DATA LIST (lexically, not in +terms of flow of control). + +By default REPEATING DATA will output a table describing how it will +parse the input data. Specifying NOTABLE will disable this behavior; +specifying TABLE will explicitly enable it. + +The LENGTH subcommand specifies the length in characters of each group. +If it is not present then length is inferred from the DATA subcommand. +LENGTH can be a number or a variable name. + +Normally all the data groups are expected to be present on a single +line. Use the CONTINUED command to indicate that data can be continued +onto additional lines. If data on continuation lines starts at the left +margin and continues through the entire field width, no column +specifications are necessary on CONTINUED. Otherwise, specify the +possible range of columns in the same way as on STARTS. + +When data groups are continued from line to line, it's easily possible +for cases to get out of sync if hand editing is not done carefully. The +ID subcommand allows a case identifier to be present on each line of +repeating data groups. REPEATING DATA will check for the same +identifier on each line and report mismatches. Specify the range of +columns that the identifier will occupy, followed by an equals sign +(@samp{=}) and the identifier variable name. The variable must already +have been declared with NUMERIC or another command. + +@node WRITE, , REPEATING DATA, Data Input and Output +@section WRITE +@vindex WRITE + +@display +WRITE + OUTFILE='filename' + RECORDS=n_lines + @{NOTABLE,TABLE@} + /[line_no] arg@dots{} + +arg takes one of the following forms: + 'string' [start-end] + var_list start-end [type_spec] + var_list (fortran_spec) + var_list * +@end display + +WRITE is used to write text or binary data to an output file. + +@xref{PRINT}, for more information on syntax and usage. The main +difference between PRINT and WRITE is that whereas by default PRINT uses +variables' print formats, WRITE uses write formats. + +The sole additional difference is that if WRITE is used to send output +to a binary file, carriage control characters will not be output. +@xref{FILE HANDLE}, for information on how to declare a file as binary. + +@node System and Portable Files, Variable Attributes, Data Input and Output, Top +@chapter System Files and Portable Files + +The commands in this chapter read, write, and examine system files and +portable files. + +@menu +* APPLY DICTIONARY:: Apply system file dictionary to active file. +* EXPORT:: Write to a portable file. +* GET:: Read from a system file. +* IMPORT:: Read from a portable file. +* MATCH FILES:: Merge system files. +* SAVE:: Write to a system file. +* SYSFILE INFO:: Display system file dictionary. +* XSAVE:: Write to a system file, as a transform. +@end menu + +@node APPLY DICTIONARY, EXPORT, System and Portable Files, System and Portable Files +@section APPLY DICTIONARY +@vindex APPLY DICTIONARY + +@display +APPLY DICTIONARY FROM='filename'. +@end display + +The APPLY DICTIONARY command applies the variable labels, value labels, +and missing values from variables in a system file to corresponding +variables in the active file. In some cases it also updates the +weighting variable. + +Specify a system file with a file name string or as a file handle +(@pxref{FILE HANDLE}). The dictionary in the system file will be read, +but it will not replace the active file dictionary. The system file's +data will not be read. + +Only variables with names that exist in both the active file and the +system file are considered. Variables with the same name but different +types (numeric, string) will cause an error message. Otherwise, the +system file variables' attributes will replace those in their matching +active file variables, as described below. + +If a system file variable has a variable label, then it will replace the +active file variable's variable label. If the system file variable does +not have a variable label, then the active file variable's variable +label, if any, will be retained. + +If the active file variable is numeric or short string, then value +labels and missing values, if any, will be copied to the active file +variable. If the system file variable does not have value labels or +missing values, then those in the active file variable, if any, will not +be disturbed. + +Finally, weighting of the active file is updated (@pxref{WEIGHT}). If +the active file has a weighting variable, and the system file does not, +or if the weighting variable in the system file does not exist in the +active file, then the active file weighting variable, if any, is +retained. Otherwise, the weighting variable in the system file becomes +the active file weighting variable. + +APPLY DICTIONARY takes effect immediately. It does not read the active +file. The system file is not modified. + +@node EXPORT, GET, APPLY DICTIONARY, System and Portable Files +@section EXPORT +@vindex EXPORT + +@display +EXPORT + /OUTFILE='filename' + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} +@end display + +The EXPORT procedure writes the active file dictionary and data to a +specified portable file. + +The OUTFILE subcommand, which is the only required subcommand, specifies +the portable file to be written as a file name string or a file handle +(@pxref{FILE HANDLE}). + +DROP, KEEP, and RENAME follow the same format as the SAVE procedure +(@pxref{SAVE}). + +EXPORT is a procedure. It causes the active file to be read. + +@node GET, IMPORT, EXPORT, System and Portable Files +@section GET +@vindex GET + +@display +GET + /FILE='filename' + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} +@end display + +The GET transformation clears the current dictionary and active file and +replaces them with the dictionary and data from a specified system file. + +The FILE subcommand is the only required subcommand. Specify the system +file to be read as a string file name or a file handle (@pxref{FILE +HANDLE}). + +By default, all the variables in a system file are read. The DROP +subcommand can be used to specify a list of variables that are not to be +read. By contrast, the KEEP subcommand can be used to specify variable +that are to be read, with all other variables not read. + +Normally variables in a system file retain the names that they were +saved under. Use the RENAME subcommand to change these names. Specify, +within parentheses, a list of variable names followed by an equals sign +(@samp{=}) and the names that they should be renamed to. Multiple +parenthesized groups of variable names can be included on a single +RENAME subcommand. Variables' names may be swapped using a RENAME +subcommand of the form @samp{/RENAME=(A B=B A)}. + +Alternate syntax for the RENAME subcommand allows the parentheses to be +eliminated. When this is done, only a single variable may be renamed at +once. For instance, @samp{/RENAME=A=B}. This alternate syntax is +deprecated. + +DROP, KEEP, and RENAME are performed in left-to-right order. They each +may be present any number of times. + +Please note that DROP, KEEP, and RENAME do not cause the system file on +disk to be modified. Only the active file read from the system file is +changed. + +GET does not cause the data to be read, only the dictionary. The data +is read later, when a procedure is executed. + +@node IMPORT, MATCH FILES, GET, System and Portable Files +@section IMPORT +@vindex IMPORT + +@display +IMPORT + /FILE='filename' + /TYPE=@{COMM,TAPE@} + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} +@end display + +The IMPORT transformation clears the active file dictionary and data and +replaces them with a dictionary and data from a portable file on disk. + +The FILE subcommand, which is the only required subcommand, specifies +the portable file to be read as a file name string or a file handle +(@pxref{FILE HANDLE}). + +The TYPE subcommand is currently not used. + +DROP, KEEP, and RENAME follow the syntax used by GET (@pxref{GET}). + +IMPORT does not cause the data to be read, only the dictionary. The +data is read later, when a procedure is executed. + +@node MATCH FILES, SAVE, IMPORT, System and Portable Files +@section MATCH FILES +@vindex MATCH FILES + +@display +MATCH FILES + /BY var_list + /@{FILE,TABLE@}=@{*,'filename'@} + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} + /IN=var_name + /FIRST=var_name + /LAST=var_name + /MAP +@end display + +The MATCH FILES command merges one or more system files, optionally +including the active file. Records with the same values for BY +variables are combined into a single record. Records with different +values are output in order. Thus, multiple sorted system files are +combined into a single sorted system file based on the value of the BY +variables. + +The BY subcommand specifies a list of variables that are used to match +records from each of the system files. Variables specified must exist +in all the files specified on FILE and TABLE. BY should usually be +specified. If TABLE is used then BY is required. + +Specify FILE with a system file as a file name string or file handle +(@pxref{FILE HANDLE}). An asterisk (@samp{*}) may also be specified to +indicate the current active file. The files specified on FILE are +merged together based on the BY variables, or combined case-by-case if +BY is not specified. Normally at least two FILE subcommands should be +specified. + +Specify TABLE with a system file in order to use it as a @dfn{table +lookup file}. Records in table lookup files are not used up after +they've been used once. This means that data in table lookup files can +correspond to any number of records in FILE files. Table lookup files +correspond to lookup tables in traditional relational database systems. +It is incorrect to have records with duplicate BY values in table lookup +files. + +Any number of FILE and TABLE subcommands may be specified. Each +instance of FILE or TABLE can be followed by DROP, KEEP, and/or RENAME +subcommands. These take the same form as the corresponding subcommands +of GET (@pxref{GET}), and perform the same functions. + +Variables belonging to files that are not present for the current case +are set to the system-missing value for numeric variables or spaces for +string variables. + +IN, FIRST, LAST, and MAP are currently not used. + +@node SAVE, SYSFILE INFO, MATCH FILES, System and Portable Files +@section SAVE +@vindex SAVE + +@display +SAVE + /OUTFILE='filename' + /@{COMPRESSED,UNCOMPRESSED@} + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} +@end display + +The SAVE procedure causes the dictionary and data in the active file to +be written to a system file. + +The FILE subcommand is the only required subcommand. Specify the system +file to be written as a string file name or a file handle (@pxref{FILE +HANDLE}). + +The COMPRESS and UNCOMPRESS subcommand determine whether the saved +system file is compressed. By default, system files are compressed. +This default can be changed with the SET command (@pxref{SET}). + +By default, all the variables in the active file dictionary are written +to the system file. The DROP subcommand can be used to specify a list +of variables not to be written. In contrast, KEEP specifies variables +to be written, with all variables not specified not written. + +Normally variables are saved to a system file under the same names they +have in the active file. Use the RENAME command to change these names. +Specify, within parentheses, a list of variable names followed by an +equals sign (@samp{=}) and the names that they should be renamed to. +Multiple parenthesized groups of variable names can be included on a +single RENAME subcommand. Variables' names may be swapped using a +RENAME subcommand of the form @samp{/RENAME=(A B=B A)}. + +Alternate syntax for the RENAME subcommand allows the parentheses to be +eliminated. When this is done, only a single variable may be renamed at +once. For instance, @samp{/RENAME=A=B}. This alternate syntax is +deprecated. + +DROP, KEEP, and RENAME are performed in left-to-right order. They each +may be present any number of times. + +Please note that DROP, KEEP, and RENAME do not cause the active file to +be modified. Only the system file written to disk is changed. + +SAVE causes the data to be read. It is a procedure. + +@node SYSFILE INFO, XSAVE, SAVE, System and Portable Files +@section SYSFILE INFO +@vindex SYSFILE INFO + +@display +SYSFILE INFO FILE='filename'. +@end display + +The SYSFILE INFO command reads the dictionary in a system file and +displays the information in its dictionary. + +Specify a file name or file handle. SYSFILE INFO will read that file as +a system file and display information on its dictionary. + +The file does not replace the current active file. + +@node XSAVE, , SYSFILE INFO, System and Portable Files +@section XSAVE +@vindex XSAVE + +@display +XSAVE + /FILE='filename' + /@{COMPRESSED,UNCOMPRESSED@} + /DROP=var_list + /KEEP=var_list + /RENAME=(src_names=target_names)@dots{} +@end display + +The XSAVE transformation writes the active file dictionary and data to a +system file stored on disk. + +XSAVE is a transformation, not a procedure. It is executed when the +data is read by a procedure or procedure-like command. In all other +respects, XSAVE is identical to SAVE. @xref{SAVE}, for more information +on syntax and usage. + +@node Variable Attributes, Data Manipulation, System and Portable Files, Top +@chapter Manipulating variables + +The variables in the active file dictionary are important. There are +several utility functions for examining and adjusting them. + +@menu +* ADD VALUE LABELS:: Add value labels to variables. +* DISPLAY:: Display variable names & descriptions. +* DISPLAY VECTORS:: Display a list of vectors. +* FORMATS:: Set print and write formats. +* LEAVE:: Don't clear variables between cases. +* MISSING VALUES:: Set missing values for variables. +* MODIFY VARS:: Rename, reorder, and drop variables. +* NUMERIC:: Create new numeric variables. +* PRINT FORMATS:: Set variable print formats. +* RENAME VARIABLES:: Rename variables. +* VALUE LABELS:: Set value labels for variables. +* STRING:: Create new string variables. +* VARIABLE LABELS:: Set variable labels for variables. +* VECTOR:: Declare an array of variables. +* WRITE FORMATS:: Set variable write formats. +@end menu + +@node ADD VALUE LABELS, DISPLAY, Variable Attributes, Variable Attributes +@section ADD VALUE LABELS +@vindex ADD VALUE LABELS + +@display +ADD VALUE LABELS + /var_list value 'label' [value 'label']@dots{} +@end display + +ADD VALUE LABELS has the same syntax and purpose as VALUE LABELS (see +above), but it does not clear away value labels from the variables +before adding the ones specified. + +@node DISPLAY, DISPLAY VECTORS, ADD VALUE LABELS, Variable Attributes +@section DISPLAY +@vindex DISPLAY + +@display +DISPLAY @{NAMES,INDEX,LABELS,VARIABLES,DICTIONARY,SCRATCH@} + [SORTED] [var_list] +@end display + +DISPLAY displays requested information on variables. Variables can +optionally be sorted alphabetically. The entire dictionary or just +specified variables can be described. + +One of the following keywords can be present: + +@table @asis +@item NAMES +The variables' names are displayed. + +@item INDEX +The variables' names are displayed along with a value describing their +position within the active file dictionary. + +@item LABELS +Variable names, positions, and variable labels are displayed. + +@item VARIABLES +Variable names, positions, print and write formats, and missing values +are displayed. + +@item DICTIONARY +Variable names, positions, print and write formats, missing values, +variable labels, and value labels are displayed. + +@item SCRATCH +Varible names are displayed, for scratch variables only (@pxref{Scratch +Variables}). +@end table + +If SORTED is specified, then the variables are displayed in ascending +order based on their names; otherwise, they are displayed in the order +that they occur in the active file dictionary. + +@node DISPLAY VECTORS, FORMATS, DISPLAY, Variable Attributes +@section DISPLAY VECTORS +@vindex DISPLAY VECTORS + +@display +DISPLAY VECTORS. +@end display + +The DISPLAY VECTORS command causes a list of the currently declared +vectors to be displayed. + +@node FORMATS, LEAVE, DISPLAY VECTORS, Variable Attributes +@section FORMATS +@vindex FORMATS + +@display +FORMATS var_list (fmt_spec). +@end display + +The FORMATS command set the print and write formats for the specified +variables to the specified format specification. @xref{Input/Output +Formats}. + +Specify a list of variables followed by a format specification in +parentheses. The print and write formats of the specified variables +will be changed. + +Additional lists of variables and formats may be included if they are +delimited by a slash (@samp{/}). + +The FORMATS command takes effect immediately. It is not affected by +conditional and looping structures such as DO IF or LOOP. + +@node LEAVE, MISSING VALUES, FORMATS, Variable Attributes +@section LEAVE +@vindex LEAVE + +@display +LEAVE var_list. +@end display + +The LEAVE command prevents the specified variables from being +reinitialized whenever a new case is processed. + +Normally, when a data file is processed, every variable in the active +file is initialized to the system-missing value or spaces at the +beginning of processing for each case. When a variable has been +specified on LEAVE, this is not the case. Instead, that variable is +initialized to 0 (not system-missing) or spaces for the first case. +After that, it retains its value between cases. + +This becomes useful for counters. For instance, in the example below +the variable SUM maintains a running total of the values in the ITEM +variable. + +@example +DATA LIST /ITEM 1-3. +COMPUTE SUM=SUM+ITEM. +PRINT /ITEM SUM. +LEAVE SUM +BEGIN DATA. +123 +404 +555 +999 +END DATA. +@end example + +@noindent Partial output from this example: + +@example +123 123.00 +404 527.00 +555 1082.00 +999 2081.00 +@end example + +It is best to use the LEAVE command immediately before invoking a +procedure command, because it is reset by certain transformations---for +instance, COMPUTE and IF. LEAVE is also reset by all procedure +invocations. + +@node MISSING VALUES, MODIFY VARS, LEAVE, Variable Attributes +@section MISSING VALUES +@vindex MISSING VALUES + +@display +MISSING VALUES var_list (missing_values). + +missing_values takes one of the following forms: + num1 + num1, num2 + num1, num2, num3 + num1 THRU num2 + num1 THRU num2, num3 + string1 + string1, string2 + string1, string2, string3 +As part of a range, LO or LOWEST may take the place of num1; +HI or HIGHEST may take the place of num2. +@end display + +The MISSING VALUES command sets user-missing values for numeric and +short string variables. Long string variables may not have missing +values. + +Specify a list of variables, followed by a list of their user-missing +values in parentheses. Up to three discrete values may be given, or, +for numeric variables only, a range of values optionally accompanied by +a single discrete value. Ranges may be open-ended on one end, indicated +through the use of the keyword LO or LOWEST or HI or HIGHEST. + +The MISSING VALUES command takes effect immediately. It is not affected +by conditional and looping constructs such as DO IF or LOOP. + +@node MODIFY VARS, NUMERIC, MISSING VALUES, Variable Attributes +@section MODIFY VARS +@vindex MODIFY VARS + +@display +MODIFY VARS + /REORDER=@{FORWARD,BACKWARD@} @{POSITIONAL,ALPHA@} (var_list)@dots{} + /RENAME=(old_names=new_names)@dots{} + /@{DROP,KEEP@}=var_list + /MAP +@end display + +The MODIFY VARS commands allows variables in the active file to be +reordered, renamed, or deleted from the active file. + +At least one subcommand must be specified, and no subcommand may be +specified more than once. DROP and KEEP may not both be specified. + +The REORDER subcommand changes the order of variables in the active +file. Specify one or more lists of variable names in parentheses. By +default, each list of variables is rearranged into the specified order. +To put the variables into the reverse of the specified order, put +keyword BACKWARD before the parentheses. To put them into alphabetical +order in the dictionary, specify keyword ALPHA before the parentheses. +BACKWARD and ALPHA may also be combined. + +To rename variables in the active file, specify RENAME, an equals sign +(@samp{=}), and lists of the old variable names and new variable names +separated by another equals sign within parentheses. There must be the +same number of old and new variable names. Each old variable is renamed to +the corresponding new variable name. Multiple parenthesized groups of +variables may be specified. + +The DROP subcommand deletes a specified list of variables from the +active file. + +The KEEP subcommand keeps the specified list of variables in the active +file. Any unlisted variables are delete from the active file. + +MAP is currently ignored. + +MODIFY VARS takes effect immediately. It does not cause the data to be +read. + +@node NUMERIC, PRINT FORMATS, MODIFY VARS, Variable Attributes +@section NUMERIC +@vindex NUMERIC + +@display +NUMERIC /var_list [(fmt_spec)]. +@end display + +The NUMERIC command explicitly declares new numeric variables, +optionally setting their output formats. + +Specify a slash (@samp{/}), followed by the names of the new numeric +variables. If you wish to set their output formats, follow their names +by an output format specification in parentheses (@pxref{Input/Output +Formats}). If no output format specification is given then the +variables will default to F8.2. + +Variables created with NUMERIC will be initialized to the system-missing +value. + +@node PRINT FORMATS, RENAME VARIABLES, NUMERIC, Variable Attributes +@section PRINT FORMATS +@vindex PRINT FORMATS + +@display +PRINT FORMATS var_list (fmt_spec). +@end display + +The PRINT FORMATS command sets the print formats for the specified +variables to the specified format specification. + +Syntax is identical to that of FORMATS (@pxref{FORMATS}), but the PRINT +FORMATS command sets only print formats, not write formats. + +@node RENAME VARIABLES, VALUE LABELS, PRINT FORMATS, Variable Attributes +@section RENAME VARIABLES +@vindex RENAME VARIABLES + +@display +RENAME VARIABLES (old_names=new_names)@dots{} . +@end display + +The RENAME VARIABLES command allows the names of variables in the active +file to be changed. + +To rename variables, specify lists of the old variable names and new +variable names, separated by an equals sign (@samp{=}), within +parentheses. There must be the same number of old and new variable +names. Each old variable is renamed to the corresponding new variable +name. Multiple parenthesized groups of variables may be specified. + +RENAME VARIABLES takes effect immediately. It does not cause the data +to be read. + +@node VALUE LABELS, STRING, RENAME VARIABLES, Variable Attributes +@section VALUE LABELS +@vindex VALUE LABELS + +@display +VALUE LABELS + /var_list value 'label' [value 'label']@dots{} +@end display + +The VALUE LABELS command allows values of numeric and short string +variables to be associated with labels. In this way, a short value can +stand for a long value. + +In order to set up value labels for a set of variables, specify the +variable names after a slash (@samp{/}), followed by a list of values +and their associated labels, separated by spaces. + +Before the VALUE LABELS command is executed, any existing value labels +are cleared from the variables specified. + +@node STRING, VARIABLE LABELS, VALUE LABELS, Variable Attributes +@section STRING +@vindex STRING + +@display +STRING /var_list (fmt_spec). +@end display + +The STRING command creates new string variables for use in +transformations. + +Specify a slash (@samp{/}), followed by the names of the string +variables to create and the desired output format specification in +parentheses (@pxref{Input/Output Formats}). Variable widths are +implicitly derived from the specified output formats. + +Created variables are initialized to spaces. + +@node VARIABLE LABELS, VECTOR, STRING, Variable Attributes +@section VARIABLE LABELS +@vindex VARIABLE LABELS + +@display +VARIABLE LABELS + /var_list 'var_label'. +@end display + +The VARIABLE LABELS command is used to associate an explanatory name +with a group of variables. This name (a variable label) is displayed by +statistical procedures. + +To assign a variable label to a group of variables, specify a slash +(@samp{/}), followed by the list of variable names and the variable +label as a string. + +@node VECTOR, WRITE FORMATS, VARIABLE LABELS, Variable Attributes +@section VECTOR +@vindex VECTOR + +@display +Two possible syntaxes: + VECTOR vec_name=var_list. + VECTOR vec_name_list(count). +@end display + +The VECTOR command allows a group of variables to be accessed as if they +were consecutive members of an array with a vector(index) notation. + +To make a vector out of a set of existing variables, specify a name for +the vector followed by an equals sign (@samp{=}) and the variables that +belong in the vector. + +To make a vector and create variables at the same time, specify one or +more vector names followed by a count in parentheses. This will cause +variables named @code{@var{vec}1} through @code{@var{vec}@var{count}} to +be created as numeric variables. Variable names including numeric +suffixes may not exceed 8 characters in length, and none of the +variables may exist prior to the VECTOR command. + +All the variables in a vector must be the same type. + +Vectors created with VECTOR disappear after any procedure or +procedure-like command is executed. The variables contained in the +vectors remain, unless they are scratch variables (@pxref{Scratch +Variables}). + +Variables within a vector may be references in expressions using +vector(index) syntax. + +@node WRITE FORMATS, , VECTOR, Variable Attributes +@section WRITE FORMATS +@vindex WRITE FORMATS + +@display +WRITE FORMATS var_list (fmt_spec). +@end display + +The WRITE FORMATS command sets the write formats for the specified +variables to the specified format specification. + +Syntax is identical to that of FORMATS (@pxref{FORMATS}), but the WRITE +FORMATS command sets only write formats, not print formats. + +@node Data Manipulation, Data Selection, Variable Attributes, Top +@chapter Data transformations + +The PSPP procedures examined in this chapter manipulate data and +prepare the active file for later analyses. They do not produce output, +as a rule. + +@menu +* AGGREGATE:: Summarize multiple cases into a single case. +* AUTORECODE:: Automatic recoding of variables. +* COMPUTE:: Assigning a variable a calculated value. +* COUNT:: Counting variables with particular values. +* FLIP:: Exchange variables with cases. +* IF:: Conditionally assigning a calculated value. +* RECODE:: Mapping values from one set to another. +* SORT CASES:: Sort the active file. +@end menu + +@node AGGREGATE, AUTORECODE, Data Manipulation, Data Manipulation +@section AGGREGATE +@vindex AGGREGATE + +@display +AGGREGATE + /BREAK=var_list + /PRESORTED + /OUTFILE=@{*,'filename'@} + /DOCUMENT + /MISSING=COLUMNWISE + /dest_vars=agr_func(src_vars, args@dots{})@dots{} +@end display + +The AGGREGATE command summarizes groups of cases into single cases. +Cases are divided into groups that have the same values for one or more +variables called @dfn{break variables}. Several functions are available +for summarizing case contents. + +BREAK is the only required subcommand (in addition, at least one +aggregation variable must be specified). Specify a list of variable +names. The values of these variables are used to divide the active file +into groups to be summarized. + +By default, the active file is sorted based on the break variables +before aggregation takes place. If the active file is already sorted, +specify PRESORTED to save time. + +The OUTFILE subcommand specifies a system file by file name string or +file handle (@pxref{FILE HANDLE}). The aggregated cases are sent to +this file. If OUTFILE is not specified, or if @samp{*} is specified, +then the aggregated cases replace the active file. + +Normally the aggregate file does not receive the documents from the +active file, even if the aggregate file replaces the active file. +Specify DOCUMENT to have the documents from the active file copied to +the aggregate file. + +At least one aggregation variable must be specified. Specify a list of +aggregation variables, an equals sign (@samp{=}), an aggregation +function name (see the list below), and a list of source variables in +parentheses. In addition, some aggregation functions expect additional +arguments in the parentheses following the source variable names. + +There must be exactly as many source variables as aggregation variables. +Each aggregation variable receives the results of applying the specified +aggregation function to the corresponding source variable. Most +aggregation functions may be applied to numeric and short and long +string variables. Others are restricted to numeric values; these are +marked as such in this list below. + +Any number of sets of aggregation variables may be specified. + +The available aggregation functions are as follows: + +@table @asis +@item SUM(var_name) +Sum. Limited to numeric values. +@item MEAN(var_name) +Arithmetic mean. Limited to numeric values. +@item SD(var_name) +Standard deviation of the mean. Limited to numeric values. +@item MAX(var_name) +Maximum value. +@item MIN(var_name) +Minimum value. +@item FGT(var_name, value) +@itemx PGT(var_name, value) +Fraction between 0 and 1, or percentage between 0 and 100, respectively, +of values greater than the specified constant. +@item FLT(var_name, value) +@itemx PLT(var_name, value) +Fraction or percentage, respectively, of values less than the specified +constant. +@item FIN(var_name, low, high) +@itemx PIN(var_name, low, high) +Fraction or percentage, respectively, of values within the specified +inclusive range of constants. +@item FOUT(var_name, low, high) +@itemx POUT(var_name, low, high) +Fraction or percentage, respectively, of values strictly outside the +specified range of constants. +@item N(var_name) +Number of non-missing values. +@item N +Number of cases aggregated to form this group. Don't supply a source +variable for this aggregation function. +@item NU(var_name) +Number of non-missing values. Each case is considered to have a weight +of 1, regardless of the current weighting variable (@pxref{WEIGHT}). +@item NU +Number of cases aggregated to form this group. Each case is considered +to have a weight of 1, regardless of the current weighting variable. +@item NMISS(var_name) +Number of missing values. +@item NUMISS(var_name) +Number of missing values. Each case is considered to have a weight of +1, regardless of the current weighting variable. +@item FIRST(var_name) +First value in this group. +@item LAST(var_name) +Last value in this group. +@end table + +When string values are compared by aggregation functions, they are done +in terms of internal character codes. On most modern computers, this is +a form of ASCII. + +In addition, there is a parallel set of aggregation functions having the +same names as those above, but with a dot after the last character (for +instance, @samp{SUM.}). These functions are the same as the above, +except that they cause user-missing values, which are normally excluded +from calculations, to be included. + +Normally, only a single case (2 for SD and SD.) need be non-missing in +each group in order for the aggregate variable to be non-missing. If +/MISSING=COLUMNWISE is specified, the behavior reverses: that is, a +single missing value is enough to make the aggregate variable become a +missing value. + +AGGREGATE ignores the current SPLIT FILE settings and causes them to be +canceled (@pxref{SPLIT FILE}). + +@node AUTORECODE, COMPUTE, AGGREGATE, Data Manipulation +@section AUTORECODE +@vindex AUTORECODE + +@display +AUTORECODE VARIABLES=src_vars INTO dest_vars + /DESCENDING + /PRINT +@end display + +The AUTORECODE procedure considers the @var{n} values that a variable +takes on and maps them onto values 1@dots{}@var{n} on a new numeric +variable. + +Subcommand VARIABLES is the only required subcommand and must come +first. Specify VARIABLES, an equals sign (@samp{=}), a list of source +variables, INTO, and a list of target variables. There must the same +number of source and target variables. The target variables must not +already exist. + +By default, increasing values of a source variable (for a string, this +is based on character code comparisons) are recoded to increasing values +of its target variable. To cause increasing values of a source variable +to be recoded to decreasing values of its target variable (@var{n} down +to 1), specify DESCENDING. + +PRINT is currently ignored. + +AUTORECODE is a procedure. It causes the data to be read. + +@node COMPUTE, COUNT, AUTORECODE, Data Manipulation +@section COMPUTE + +@display +COMPUTE var_name = expression. +@end display + +@code{COMPUTE} creates a variable with the name specified (if +necessary), then evaluates the given expression for every case and +assigns the result to the variable. @xref{Expressions}. + +Numeric variables created or computed by @code{COMPUTE} are assigned an +output width of 8 character with two decimal places (@code{F8.2}). +String variables created or computed by @code{COMPUTE} have the same +width as the existing variable or constant. + +COMPUTE is a transformation. It does not cause the active file to be +read. + +@node COUNT, FLIP, COMPUTE, Data Manipulation +@section COUNT + +@display +COUNT var_name = var@dots{} (value@dots{}). + +Each value takes one of the following forms: + number + string + num1 THRU num2 + MISSING + SYSMIS +In addition, num1 and num2 can be LO or LOWEST, or HI or HIGHEST, +respectively. +@end display + +@code{COUNT} creates or replaces a numeric @dfn{target} variable that +counts the occurrence of a @dfn{criterion} value or set of values over +one or more @dfn{test} variables for each case. + +The target variable values are always nonnegative integers. They are +never missing. The target variable is assigned an F8.2 output format. +@xref{Input/Output Formats}. Any variables, including long and short +string variables, may be test variables. + +User-missing values of test variables are treated just like any other +values. They are @strong{not} treated as system-missing values. +User-missing values that are criterion values or inside ranges of +criterion values are counted as any other values. However (for numeric +variables), keyword @code{MISSING} may be used to refer to all system- +and user-missing values. + + +@code{COUNT} target variables are assigned values in the order +specified. In the command @code{COUNT A=A B(1) /B=A B(2).}, the +following actions occur: + +@itemize @minus +@item +The number of occurrences of 1 between @code{A} and @code{B} is counted. + +@item +@code{A} is assigned this value. + +@item +The number of occurrences of 1 between @code{B} and the @strong{new} +value of @code{A} is counted. + +@item +@code{B} is assigned this value. +@end itemize + +Despite this ordering, all @code{COUNT} criterion variables must exist +before the procedure is executed---they may not be created as target +variables earlier in the command! Break such a command into two +separate commands. + +The examples below may help to clarify. + +@enumerate A +@item +Assuming @code{Q0}, @code{Q2}, @dots{}, @code{Q9} are numeric variables, +the following commands: + +@enumerate +@item +Count the number of times the value 1 occurs through these variables +for each case and assigns the count to variable @code{QCOUNT}. + +@item +Print out the total number of times the value 1 occurs throughout +@emph{all} cases using @code{DESCRIPTIVES}. @xref{DESCRIPTIVES}, for +details. +@end enumerate + +@example +COUNT QCOUNT=Q0 TO Q9(1). +DESCRIPTIVES QCOUNT /STATISTICS=SUM. +@end example + +@item +Given these same variables, the following commands: + +@enumerate +@item +Count the number of valid values of these variables for each case and +assigns the count to variable @code{QVALID}. + +@item +Multiplies each value of @code{QVALID} by 10 to obtain a percentage of +valid values, using @code{COMPUTE}. @xref{COMPUTE}, for details. + +@item +Print out the percentage of valid values across all cases, using +@code{DESCRIPTIVES}. @xref{DESCRIPTIVES}, for details. +@end enumerate + +@example +COUNT QVALID=Q0 TO Q9 (LO THRU HI). +COMPUTE QVALID=QVALID*10. +DESCRIPTIVES QVALID /STATISTICS=MEAN. +@end example +@end enumerate + +@node FLIP, IF, COUNT, Data Manipulation +@section FLIP +@vindex FLIP + +@display +FLIP /VARIABLES=var_list /NEWNAMES=var_name. +@end display + +The FLIP command transposes rows and columns in the active file. It +causes cases to be swapped with variables, and vice versa. + +There are no required subcommands. The VARIABLES subcommand specifies +variables that will be transformed into cases. Variables not specified +are discarded. By default, all variables are selected for +transposition. + +The variables specified by NEWNAMES, which must be a string variable, is +used to give names to the variables created by FLIP. If NEWNAMES is not +specified then the default is a variable named CASE_LBL, if it exists. +If it does not then the variables created by FLIP are named VAR000 +through VAR999, then VAR1000, VAR1001, and so on. + +When a NEWNAMES variable is available, the names must be canonicalized +before becoming variable names. Invalid characters are replaced by +letter @samp{V} in the first position, or by @samp{_} in subsequent +positions. If the name thus generated is not unique, then numeric +extensions are added, starting with 1, until a unique name is found or +there are no remaining possibilities. If the latter occurs then the +FLIP operation aborts. + +The resultant dictionary contains a CASE_LBL variable, which stores the +names of the variables in the dictionary before the transposition. If +the active file is subsequently transposed using FLIP, this variable can +be used to recreate the original variable names. + +@node IF, RECODE, FLIP, Data Manipulation +@section IF + +@display +Two possible syntaxes: + IF test_expr target_var=target_expr. + IF test_expr target_vec(target_index)=target_expr. +@end display + +The IF transformation conditionally assigns the value of a target +expression to a target variable, based on the truth of a test +expression. + +Specify a boolean-valued expression (@pxref{Expressions}) to be tested +following the IF keyword. This expression is calculated for each case. +If the value is true, then the value of target_expr is computed and +assigned to target_var. If the value is false or missing, nothing is +done. Numeric and short and long string variables may be used. The +type of target_expr must match the type of target_var. + +For numeric variables only, target_var need not exist before the IF +transformation is executed. In this case, target_var is assigned the +system-missing value if the IF condition is not true. String variables +must be declared before they can be used as targets for IF. + +In addition to ordinary variables, the target variable may be an element +of a vector. In this case, the vector index must be specified in +parentheses following the vector name. + +@node RECODE, SORT CASES, IF, Data Manipulation +@section RECODE + +@display +RECODE var_list (src_value@dots{}=dest_value)@dots{} [INTO var_list]. + +src_value may take the following forms: + number + string + num1 THRU num2 + MISSING + SYSMIS + ELSE +Open-ended ranges may be specified using LO or LOWEST for num1 +or HI or HIGHEST for num2. + +dest_value may take the following forms: + num + string + SYSMIS + COPY +@end display + +The RECODE command is used to translate data from one range of values to +another, using flexible user-specified mappings. Data may be remapped +in-place or copied to new variables. Numeric, short string, and long +string data can be recoded. + +Specify the list of source variables, followed by one or more mapping +specifications each enclosed in parentheses. If the data is to be +copied to new variables, specify INTO, then the list of target +variables. String target variables must already have been declared +using STRING or another transformation, but numeric target variables can +be created on the fly. There must be exactly as many target variables +as source variables. Each source variable is remapped into its +corresponding target variable. + +When INTO is not used, the input and output variables must be of the +same type. Otherwise, string values can be recoded into numeric values, +and vice versa. When this is done and there is no mapping for a +particular value, either a value consisting of all spaces or the +system-missing value is assigned, depending on variable type. + +Mappings are considered from left to right. The first src_value that +matches the value of the source variable causes the target variable to +receive the value indicated by the dest_value. Literal number, string, +and range src_value's should be self-explanatory. MISSING as a +src_value matches any user- or system-missing value. SYSMIS matches the +system missing value only. ELSE is a catch-all that matches anything. +It should be the last src_value specified. + +Numeric and string dest_value's should also be self-explanatory. COPY +causes the input values to be copied to the output. This is only value +if the source and target variables are of the same type. SYSMIS +indicates the system-missing value. + +If the source variables are strings and the target variables are +numeric, then there is one additional mapping available: (CONVERT), +which must be the last specified mapping. CONVERT causes a number +specified as a string to be converted to a numeric value. If the string +cannot be parsed as a number, then the system-missing value is assigned. + +Multiple recodings can be specified on the same RECODE command. +Introduce additional recodings with a slash (@samp{/}) in order to +separate them from the previous recodings. + +@node SORT CASES, , RECODE, Data Manipulation +@section SORT CASES +@vindex SORT CASES + +@display +SORT CASES BY var_list. +@end display + +SORT CASES sorts the active file by the values of one or more +variables. + +Specify BY and a list of variables to sort by. By default, variables +are sorted in ascending order. To override sort order, specify (D) or +(DOWN) after a list of variables to get descending order, or (A) or (UP) +for ascending order. These apply to the entire list of variables +preceding them. + +SORT CASES is a procedure. It causes the data to be read. + +SORT CASES will attempt to sort the entire active file in main memory. +If main memory is exhausted then it will use a merge sort algorithm that +involves writing and reading numerous temporary files. Environment +variables determine the temporary files' location. The first of +SPSSTMPDIR, SPSSXTMPDIR, or TMPDIR that is set determines the location. +Otherwise, if the compiler environment defined P_tmpdir, that is used. +Otherwise, under Unix-like OSes /tmp is used; under MS-DOS, the first of +TEMP, TMP, or root on the current drive is used; under other OSes, the +current directory. + +@node Data Selection, Conditionals and Looping, Data Manipulation, Top +@chapter Selecting data for analysis + +This chapter documents PSPP commands that temporarily or permanently +select data records from the active file for analysis. + +@menu +* FILTER:: Exclude cases based on a variable. +* N OF CASES:: Limit the size of the active file. +* PROCESS IF:: Temporarily excluding cases. +* SAMPLE:: Select a specified proportion of cases. +* SELECT IF:: Permanently delete selected cases. +* SPLIT FILE:: Do multiple analyses with one command. +* TEMPORARY:: Make transformations' effects temporary. +* WEIGHT:: Weight cases by a variable. +@end menu + +@node FILTER, N OF CASES, Data Selection, Data Selection +@section FILTER +@vindex FILTER + +@display +FILTER BY var_name. +FILTER OFF. +@end display + +The FILTER command allows a boolean-valued variable to be used to select +cases from the data stream for processing. + +In order to set up filtering, specify BY and a variable name. Keyword +BY is optional but recommended. Cases which have a zero or system- or +user-missing value are excluded from analysis, but not deleted from the +data stream. Cases with other values are analyzed. + +Use FILTER OFF to turn off case filtering. + +Filtering takes place immediately before cases pass to a procedure for +analysis. Only one filter variable may be active at once. Normally, +case filtering continues until it is explicitly turned off with FILTER +OFF. However, if FILTER is placed after TEMPORARY, then filtering stops +after execution of the next procedure or procedure-like command. + +@node N OF CASES, PROCESS IF, FILTER, Data Selection +@section N OF CASES +@vindex N OF CASES + +@display +N [OF CASES] num_of_cases [ESTIMATED]. +@end display + +Sometimes you may want to disregard cases of your input. The @code{N} +command can be used to do this. @code{N 100} tells PSPP to +disregard all cases after the first 100. + +If the value specified for @code{N} is greater than the number of cases +read in, the value is ignored. + +@code{N} does not discard cases or cause them not to be read in. It +just causes cases beyond the last one specified to be ignored by data +analysis commands. + +A later @code{N} command can increase or decrease the number of cases +selected. (To select all the cases without knowing how many there are, +specify a very high number: 100000 or whatever you think is large enough.) + +Transformation procedures performed after @code{N} is executed +@emph{do} cause cases to be discarded. + +The @code{SAMPLE}, @code{PROCESS IF}, and @code{SELECT IF} commands have +precedence over @code{N}---the same results are obtained by both of the +following fragments, given the same random number seeds: + +@example +@i{@dots{}set up, read in data@dots{}} +N 100. +SAMPLE .5. +@i{@dots{}analyze data@dots{}} + +@i{@dots{}set up, read in data@dots{}} +SAMPLE .5. +N 100. +@i{@dots{}analyze data@dots{}} +@end example + +Both fragments above first randomly sample approximately half of the +cases, then select the first 100 of those sampled. + +@code{N} with the @code{ESTIMATED} keyword can be used to give an +estimated number of cases before DATA LIST or another command to +read in data. (@code{ESTIMATED} never limits the number of cases +processed by procedures.) + +@node PROCESS IF, SAMPLE, N OF CASES, Data Selection +@section PROCESS IF +@vindex PROCESS IF + +@example +PROCESS IF expression. +@end example + +The PROCESS IF command is used to temporarily eliminate cases from the +data stream. Its effects are active only through the execution of the +next procedure or procedure-like command. + +Specify a boolean expression (@pxref{Expressions}). If the value of the +expression is true for a particular case, the case will be analyzed. If +the expression has a false or missing value, then the case will be +deleted from the data stream for this procedure only. + +Regardless of its placement relative to other commands, PROCESS IF +always takes effect immediately before data passes to the procedure. +Only one PROCESS IF command may be in effect at any given time. + +The effects of PROCESS IF are similar not identical to the effects of +executing TEMPORARY then SELECT IF (@pxref{SELECT IF}). + +Use of PROCESS IF is deprecated. It is included for compatibility with +old command files. New syntax files should use SELECT IF or FILTER +instead. + +@node SAMPLE, SELECT IF, PROCESS IF, Data Selection +@section SAMPLE +@vindex SAMPLE + +@display +SAMPLE num1 [FROM num2]. +@end display + +@code{SAMPLE} is used to randomly sample a proportion of the cases in +the active file. @code{SAMPLE} is temporary, affecting only the next +procedure, unless that is a data transformation, such as @code{SELECT IF} +or @code{RECODE}. + +The proportion to sample can be expressed as a single number between 0 +and 1. If @code{k} is the number specified, and @code{N} is the number +of currently-selected cases in the active file, then after +@code{SAMPLE @var{k}.}, there will be @code{k*N}, plus or minus one, cases +selected. + +The proportion to sample can also be specified in the style @code{SAMPLE +@var{m} FROM @var{N}}. With this style, cases are selected as follows: + +@enumerate +@item +If @var{N} is equal to the number of currently-selected cases in the +active file, exactly @var{m} cases will be selected. + +@item +If @var{N} is greater than the number of currently-selected cases in the +active file, an equivalent proportion of cases will be selected. + +@item +If @var{N} is less than the number of currently-selected cases in the +active, exactly @var{m} cases will be selected @emph{from the first +@var{N} cases in the active file.} +@end enumerate + +@code{SAMPLE}, @code{SELECT IF}, and @code{PROCESS IF} are performed in +the order specified by the syntax file. + +@code{SAMPLE} is ignored before @code{SORT CASES}. + +@code{SAMPLE} is always performed before @code{N OF CASES}, regardless +of ordering in the syntax file. @xref{N OF CASES}. + +The same values for @code{SAMPLE} may result in different samples. To +obtain the same sample, use the @code{SET} command to set the random +number seed to the same value before each @code{SAMPLE}. By default, +the random number seed is based on the system time. + +@node SELECT IF, SPLIT FILE, SAMPLE, Data Selection +@section SELECT IF +@vindex SELECT IF + +@display +SELECT IF expression. +@end display + +The SELECT IF command is used to select particular cases for analysis +based on the value of a boolean expression. Cases not selected are +permanently eliminated, unless TEMPORARY is in effect +(@pxref{TEMPORARY}). + +Specify a boolean expression (@pxref{Expressions}). If the value of the +expression is true for a particular case, the case will be analyzed. If +the expression has a false or missing value, then the case will be +deleted from the data stream. + +Always place SELECT IF commands as early in the command file as +possible. Cases that are deleted early can be processed more +efficiently in time and space. + +@node SPLIT FILE, TEMPORARY, SELECT IF, Data Selection +@section SPLIT FILE +@vindex SPLIT FILE + +@display +Two possible syntaxes: + SPLIT FILE BY var_list. + SPLIT FILE OFF. +@end display + +The SPLIT FILE command allows multiple sets of data present in one data +file to be analyzed separately using single statistical procedure +commands. + +Specify a list of variable names in order to analyze multiple sets of +data separately. Groups of cases having the same values for these +variables are analyzed by statistical procedure commands as one group. +An independent analysis is carried out for each group of cases, and the +variable values for the group are printed along with the analysis. + +Specify OFF in order to disable SPLIT FILE and resume analysis of the +entire active file as a single group of data. + +@node TEMPORARY, WEIGHT, SPLIT FILE, Data Selection +@section TEMPORARY +@vindex TEMPORARY + +@display +TEMPORARY. +@end display + +The TEMPORARY command is used to make the effects of transformations +following its execution temporary. These transformations will +affect only the execution of the next procedure or procedure-like +command. Their effects will not be saved to the active file. + +The only specification is the command name. + +TEMPORARY may not appear within a DO IF or LOOP construct. It may +appear only once between procedures and procedure-like commands. + +An example may help to clarify: + +@example +DATA LIST /X 1-2. +BEGIN DATA. + 2 + 4 +10 +15 +20 +24 +END DATA. +COMPUTE X=X/2. +TEMPORARY. +COMPUTE X=X+3. +DESCRIPTIVES X. +DESCRIPTIVES X. +@end example + +The data read by the first DESCRIPTIVES command are 4, 5, 8, +10.5, 13, 15. The data read by the first DESCRIPTIVES command are 1, 2, +5, 7.5, 10, 12. + +@node WEIGHT, , TEMPORARY, Data Selection +@section WEIGHT +@vindex WEIGHT + +@display +WEIGHT BY var_name. +WEIGHT OFF. +@end display + +WEIGHT can be used to assign cases varying weights in order to +change the frequency distribution of the active file. Execution of +WEIGHT is delayed until data have been read in. + +If a variable name is specified, WEIGHT causes the values of that +variable to be used as weighting factors for subsequent statistical +procedures. Use of keyword BY is optional but recommended. Weighting +variables must be numeric. Scratch variables may not be used for +weighting (@pxref{Scratch Variables}). + +When OFF is specified, subsequent statistical procedures will weight all +cases equally. + +Weighting values do not need to be integers. However, negative and +system- and user-missing values for the weighting variable are +interpreted as weighting factors of 0. + +WEIGHT does not cause cases in the active file to be replicated in +memory. + +@node Conditionals and Looping, Statistics, Data Selection, Top +@chapter Conditional and Looping Constructs +@cindex conditionals +@cindex loops +@cindex flow of control +@cindex control flow + +This chapter documents PSPP commands used for conditional execution, +looping, and flow of control. + +@menu +* BREAK:: Exit a loop. +* DO IF:: Conditionally execute a block of code. +* DO REPEAT:: Textually repeat a code block. +* LOOP:: Repeat a block of code. +@end menu + +@node BREAK, DO IF, Conditionals and Looping, Conditionals and Looping +@section BREAK +@vindex BREAK + +@display +BREAK. +@end display + +BREAK terminates execution of the innermost currently executing LOOP +construct. + +BREAK is allowed only inside a LOOP construct. @xref{LOOP}, for more +details. + +@node DO IF, DO REPEAT, BREAK, Conditionals and Looping +@section DO IF +@vindex DO IF + +@display +DO IF condition. + @dots{} +[ELSE IF condition. + @dots{} +]@dots{} +[ELSE. + @dots{}] +END IF. +@end display + +The DO IF command allows one of several sets of transformations to be +executed, depending on user-specified conditions. + +Specify a boolean expression. If the condition is true, then the block +of code following DO IF is executed. If the condition is missing, then +none of the code blocks is executed. If the condition is false, then +the boolean expressions on the first ELSE IF, if present, is tested in +turn, with the same rules applied. If all expressions evaluate to +false, then the ELSE code block is executed, if it is present. + +@node DO REPEAT, LOOP, DO IF, Conditionals and Looping +@section DO REPEAT +@vindex DO REPEAT + +@display +DO REPEAT repvar_name=expansion@dots{}. + @dots{} +END REPEAT [PRINT]. + +expansion takes one of the following forms: + var_list + num_or_range@dots{} + 'string'@dots{} + +num_or_range takes one of the following forms: + number + num1 TO num2 +@end display + +The DO REPEAT command causes a block of code to be repeated a number of +times with different variables, numbers, or strings textually +substituted into the block with each repetition. + +Specify a repeat variable name followed by an equals sign (@samp{=}) and +the list of replacements. Replacements can be a list of variables +(which may be existing variables or new variables or a combination +thereof), of numbers, or of strings. When new variable names are +specified, DO REPEAT creates them as numeric variables. When numbers +are specified, runs of integers may be indicated with TO notation, for +instance @samp{1 TO 5} and @samp{1 2 3 4 5} would be equivalent. There +is no equivalent notation for string values. + +Multiple repeat variables can be specified. When this is done, each +variable must have the same number of replacements. + +The code within DO REPEAT is repeated as many times as there are +replacements for each variable. The first time, the first value for +each repeat variable is substituted; the second time, the second value +for each repeat variable is substituted; and so on. + +Repeat variable substitutions work like macros. They take place +anywhere in a line that the repeat variable name occurs as a token, +including command and subcommand names. For this reason it is not a +good idea to select words commonly used in command and subcommand names +as repeat variable identifiers. + +If PRINT is specified on END REPEAT, the commands after substitutions +are made are printed to the listing file, prefixed by a plus sign +(@samp{+}). + +@node LOOP, , DO REPEAT, Conditionals and Looping +@section LOOP +@vindex LOOP + +@display +LOOP [index_var=start TO end [BY incr]] [IF condition]. + @dots{} +END LOOP [IF condition]. +@end display + +The LOOP command allows a group of commands to be iterated. A number of +termination options are offered. + +Specify index_var in order to make that variable count from one value to +another by a particular increment. index_var must be a pre-existing +numeric variable. start, end, and incr are numeric expressions +(@pxref{Expressions}.) + +During the first iteration, index_var is set to the value of start. +During each successive iteration, index_var is increased by the value of +incr. If end > start, then the loop terminates when index_var > end; +otherwise it terminates when index_var < end. If incr is not specified +then it defaults to +1 or -1 as appropriate. + +If end > start and incr < 0, or if end < start and incr > 0, then the +loop is never executed. index_var is nevertheless set to the value of +start. + +Modifying index_var within the loop is allowed, but it has no effect on +the value of index_var in the next iteration. + +Specify a boolean expression for the condition on the LOOP command to +cause the loop to be executed only if the condition is true. If the +condition is false or missing before the loop contents are executed the +first time, the loop contents are not executed at all. + +If index and condition clauses are both present on LOOP, the index +clause is always evaluated first. + +Specify a boolean expression for the condition on the END LOOP to cause +the loop to terminate if the condition is not true after the enclosed +code block is executed. The condition is evaluated at the end of the +loop, not at the beginning. + +If the index clause and both condition clauses are not present, then the +loop is executed MXLOOPS (@pxref{SET}) times or until BREAK +(@pxref{BREAK}) is executed. + +The BREAK command provides another way to terminate execution of a LOOP +construct. + +@node Statistics, Utilities, Conditionals and Looping, Top +@chapter Statistics + +This chapter documents the statistical procedures that PSPP supports so +far. + +@menu +* DESCRIPTIVES:: Descriptive statistics. +* FREQUENCIES:: Frequency tables. +* CROSSTABS:: Crosstabulation tables. +@end menu + +@node DESCRIPTIVES, FREQUENCIES, Statistics, Statistics +@section DESCRIPTIVES + +@display +DESCRIPTIVES + /VARIABLES=var_list + /MISSING=@{VARIABLE,LISTWISE@} @{INCLUDE,NOINCLUDE@} + /FORMAT=@{LABELS,NOLABELS@} @{NOINDEX,INDEX@} @{LINE,SERIAL@} + /SAVE + /STATISTICS=@{ALL,MEAN,SEMEAN,STDDEV,VARIANCE,KURTOSIS, + SKEWNESS,RANGE,MINIMUM,MAXIMUM,SUM,DEFAULT, + SESKEWNESS,SEKURTOSIS@} + /SORT=@{NONE,MEAN,SEMEAN,STDDEV,VARIANCE,KURTOSIS,SKEWNESS, + RANGE,MINIMUM,MAXIMUM,SUM,SESKEWNESS,SEKURTOSIS,NAME@} + @{A,D@} +@end display + +The DESCRIPTIVES procedure reads the active file and outputs descriptive +statistics requested by the user. In addition, it can optionally +compute Z-scores. + +The VARIABLES subcommand, which is required, specifies the list of +variables to be analyzed. Keyword VARIABLES is optional. + +All other subcommands are optional: + +The MISSING subcommand determines the handling of missing variables. If +INCLUDE is set, then user-missing values are included in the +calculations. If NOINCLUDE is set, which is the default, user-missing +values are excluded. If VARIABLE is set, then missing values are +excluded on a variable by variable basis; if LISTWISE is set, then +the entire case is excluded whenever any value in that case has a +system-missing or, if INCLUDE is set, user-missing value. + +The FORMAT subcommand affects the output format. Currently the +LABELS/NOLABELS and NOINDEX/INDEX settings is not used. When SERIAL is +set, both valid and missing number of cases are listed in the output; +when NOSERIAL is set, only valid cases are listed. + +The SAVE subcommand causes DESCRIPTIVES to calculate Z scores for all +the specified variables. The Z scores are saved to new variables. +Variable names are generated by trying first the original variable name +with Z prepended and truncated to a maximum of 8 characters, then the +names ZSC000 through ZSC999, STDZ00 through STDZ09, ZZZZ00 through +ZZZZ09, ZQZQ00 through ZQZQ09, in that sequence. In addition, Z score +variable names can be specified explicitly on VARIABLES in the variable +list by enclosing them in parentheses after each variable. + +The STATISTICS subcommand specifies the statistics to be displayed: + +@table @code +@item ALL +All of the statistics below. +@item MEAN +Arithmetic mean. +@item SEMEAN +Standard error of the mean. +@item STDDEV +Standard deviation. +@item VARIANCE +Variance. +@item KURTOSIS +Kurtosis and standard error of the kurtosis. +@item SKEWNESS +Skewness and standard error of the skewness. +@item RANGE +Range. +@item MINIMUM +Minimum value. +@item MAXIMUM +Maximum value. +@item SUM +Sum. +@item DEFAULT +Mean, standard deviation of the mean, minimum, maximum. +@item SEKURTOSIS +Standard error of the kurtosis. +@item SESKEWNESS +Standard error of the skewness. +@end table + +The SORT subcommand specifies how the statistics should be sorted. Most +of the possible values should be self-explanatory. NAME causes the +statistics to be sorted by name. By default, the statistics are listed +in the order that they are specified on the VARIABLES subcommand. The A +and D settings request an ascending or descending sort order, +respectively. + +@node FREQUENCIES, CROSSTABS, DESCRIPTIVES, Statistics +@section FREQUENCIES + +@display +FREQUENCIES + /VARIABLES=var_list + /FORMAT=@{TABLE,NOTABLE,LIMIT(limit)@} + @{STANDARD,CONDENSE,ONEPAGE[(onepage_limit)]@} + @{LABELS,NOLABELS@} + @{AVALUE,DVALUE,AFREQ,DFREQ@} + @{SINGLE,DOUBLE@} + @{OLDPAGE,NEWPAGE@} + /MISSING=@{EXCLUDE,INCLUDE@} + /STATISTICS=@{DEFAULT,MEAN,SEMEAN,MEDIAN,MODE,STDDEV,VARIANCE, + KURTOSIS,SKEWNESS,RANGE,MINIMUM,MAXIMUM,SUM, + SESKEWNESS,SEKURTOSIS,ALL,NONE@} + /NTILES=ntiles + /PERCENTILES=percent@dots{} + +(These options are not currently implemented.) + /BARCHART=@dots{} + /HISTOGRAM=@dots{} + /HBAR=@dots{} + /GROUPED=@dots{} + +(Integer mode.) + /VARIABLES=var_list (low,high)@dots{} +@end display + +FREQUENCIES causes the data to be read and frequency tables to be built +and output for specified variables. FREQUENCIES can also calculate and +display descriptive statistics (including median and mode) and +percentiles. + +In the future, FREQUENCIES will also support graphical output in the +form of bar charts and histograms. In addition, it will be able to +support percentiles for grouped data. (As a historical note, these +options were supported in a version of PSPP written years ago, but the +code has not survived.) + +The VARIABLES subcommand is the only required subcommand. Specify the +variables to be analyzed. In most cases, this is all that is required. +This is known as @dfn{general mode}. + +Occasionally, one may want to invoke a special mode called @dfn{integer +mode}. Normally, in general mode, PSPP will automatically determine +what values occur in the data. In integer mode, the user specifies the +range of values that the data assumes. To invoke this mode, specify a +range of data values in parentheses, separated by a comma. Data values +inside the range are truncated to the nearest integer, then assigned to +that value. If values occur outside this range, they are discarded. + +The FORMAT subcommand controls the output format. It has several +possible settings: + +@itemize @bullet +@item +TABLE, the default, causes a frequency table to be output for every +variable specified. NOTABLE prevents them from being output. LIMIT +with a numeric argument causes them to be output except when there are +more than the specified number of values in the table. + +@item +STANDARD frequency tables contain more complete information, but also to +take up more space on the printed page. CONDENSE frequency tables are +less informative but take up less space. ONEPAGE with a numeric +argument will output standard frequency tables if there are the +specified number of values or less, condensed tables otherwise. ONEPAGE +without an argument defaults to a threshold of 50 values. + +@item +LABELS causes value labels to be displayed in STANDARD frequency +tables. NOLABLES prevents this. + +@item +Normally frequency tables are sorted in ascending order by value. This +is AVALUE. DVALUE tables are sorted in descending order by value. +AFREQ and DFREQ tables are sorted in ascending and descending order, +respectively, by frequency count. + +@item +SINGLE spaced frequency tables are closely spaced. DOUBLE spaced +frequency tables have wider spacing. + +@item +OLDPAGE and NEWPAGE are not currently used. +@end itemize + +The MISSING subcommand controls the handling of user-missing values. +When EXCLUDE, the default, is set, user-missing values are not included +in frequency tables or statistics. When INCLUDE is set, user-missing +are included. System-missing values are never included in statistics, +but are listed in frequency tables. + +The available STATISTICS are the same as available in DESCRIPTIVES +(@pxref{DESCRIPTIVES}), with the addition of MEDIAN, the data's median +value, and MODE, the mode. (If there are multiple modes, the smallest +value is reported.) By default, the mean, standard deviation of the +mean, minimum, and maximum are reported for each variable. + +NTILES causes the specified quartiles to be reported. For instance, +@code{/NTILES=4} would cause quartiles to be reported. In addition, +particular percentiles can be requested with the PERCENTILES subcommand. + +@node CROSSTABS, , FREQUENCIES, Statistics +@section CROSSTABS + +@display +CROSSTABS + /TABLES=var_list BY var_list [BY var_list]@dots{} + /MISSING=@{TABLE,INCLUDE,REPORT@} + /WRITE=@{NONE,CELLS,ALL@} + /FORMAT=@{TABLES,NOTABLES@} + @{LABELS,NOLABELS,NOVALLABS@} + @{PIVOT,NOPIVOT@} + @{AVALUE,DVALUE@} + @{NOINDEX,INDEX@} + @{BOX,NOBOX@} + /CELLS=@{COUNT,ROW,COLUMN,TOTAL,EXPECTED,RESIDUAL,SRESIDUAL, + ASRESIDUAL,ALL,NONE@} + /STATISTICS=@{CHISQ,PHI,CC,LAMBDA,UC,BTAU,CTAU,RISK,GAMMA,D, + KAPPA,ETA,CORR,ALL,NONE@} + +(Integer mode.) + /VARIABLES=var_list (low,high)@dots{} +@end display + +CROSSTABS reads the active file and builds and displays crosstabulation +tables requested by the user. It can calculate several statistics for +each cell in the crosstabulation tables. In addition, a number of +statistics can be calculated for each table itself. + +The TABLES subcommand is used to specify the tables to be reported. Any +number of dimensions is permitted, and any number of variables per +dimension is allowed. The TABLES subcommand may be repeated as many +times as needed. This is the only required subcommand in @dfn{general +mode}. + +Occasionally, one may want to invoke a special mode called @dfn{integer +mode}. Normally, in general mode, PSPP will automatically determine +what values occur in the data. In integer mode, the user specifies the +range of values that the data assumes. To invoke this mode, specify the +VARIABLES subcommand, giving a range of data values in parentheses for +each variable to be used on the TABLES subcommand. Data values inside +the range are truncated to the nearest integer, then assigned to that +value. If values occur outside this range, they are discarded. When it +is present, the VARIABLES subcommand must precede the TABLES subcommand. + +The MISSING subcommand determines the handling of user-missing values. +When set to TABLE, the default, missing values are dropped on a table by +table basis. When set to INCLUDE, user-missing values are included in +tables and statistics. When set to REPORT, which is allowed only in +integer mode, user-missing values are included in tables but marked with +an @samp{M} (for ``missing'') and excluded from statistical +calculations. + +Currently the WRITE subcommand is not used. + +The FORMAT subcommand controls the characteristics of the +crosstabulation tables to be displayed. It has a number of possible +settings: + +@itemize @bullet +@item +TABLES, the default, causes crosstabulation tables to be output. +NOTABLES suppresses them. + +@item +LABELS, the default, allows variable labels and value labels to appear +in the output. NOLABELS suppresses them. NOVALLABS displays variable +labels but suppresses value labels. + +@item +PIVOT, the default, causes each TABLES subcommand to be displayed in a +pivot table format. NOPIVOT causes the old-style crosstabulation format +to be used. + +@item +AVALUE, the default, causes values to be sorted in ascending order. +DVALUE asserts a descending sort order. + +@item +INDEX/NOINDEX is currently ignored. + +@item +BOX/NOBOX is currently ignored. +@end itemize + +The CELLS subcommand controls the contents of each cell in the displayed +crosstabulation table. The possible settings are: + +@table @asis +@item COUNT +Frequency count. +@item ROW +Row percent. +@item COLUMN +Column percent. +@item TOTAL +Table percent. +@item EXPECTED +Expected value. +@item RESIDUAL +Residual. +@item SRESIDUAL +Standardized residual. +@item ASRESIDUAL +Adjusted standardized residual. +@item ALL +All of the above. +@item NONE +Suppress cells entirely. +@end table + +@samp{/CELLS} without any settings specified requests COUNT, ROW, +COLUMN, and TOTAL. If CELLS is not specified at all then only COUNT +will be selected. + +The STATISTICS subcommand selects statistics for computation: + +@table @asis +@item CHISQ +Pearson chi-square, likelihood ratio, Fisher's exact test, continuity +correction, linear-by-linear association. +@item PHI +Phi. +@item CC +Contingency coefficient. +@item LAMBDA +Lambda. +@item UC +Uncertainty coefficient. +@item BTAU +Tau-b. +@item CTAU +Tau-c. +@item RISK +Risk estimate. +@item GAMMA +Gamma. +@item D +Somers' D. +@item KAPPA +Cohen's Kappa. +@item ETA +Eta. +@item CORR +Spearman correlation, Pearson's r. +@item ALL +All of the above. +@item NONE +No statistics. +@end table + +Selected statistics are only calculated when appropriate for the +statistic. Certain statistics require tables of a particular size, and +some statistics are calculated only in integer mode. + +@samp{/STATISTICS} without any settings selects CHISQ. If the +STATISTICS subcommand is not given, no statistics are calculated. + +@strong{Please note:} Currently the implementation of CROSSTABS has the +followings bugs: + +@itemize @bullet +@item +Pearson's R (but not Spearman!) is off a little. +@item +T values for Spearman's R and Pearson's R are wrong. +@item +How to calculate significance of symmetric and directional measures? +@item +Asymmetric ASEs and T values for lambda are wrong. +@item +ASE of Goodman and Kruskal's tau is not calculated. +@item +ASE of symmetric somers' d is wrong. +@item +Approx. T of uncertainty coefficient is wrong. +@end itemize + +Fix for any of these deficiencies would be welcomed. + +@node Utilities, Not Implemented, Statistics, Top +@chapter Utilities + +Commands that don't fit any other category are placed here. + +Most of these commands are not affected by commands like IF and LOOP: +they take effect only once, unconditionally, at the time that they are +encountered in the input. + +@menu +* COMMENT:: Document your syntax file. +* DOCUMENT:: Document the active file. +* DISPLAY DOCUMENTS:: Display active file documents. +* DISPLAY FILE LABEL:: Display the active file label. +* DROP DOCUMENTS:: Remove documents from the active file. +* EXECUTE:: Execute pending transformations. +* FILE LABEL:: Set the active file's label. +* INCLUDE:: Include a file within the current one. +* QUIT:: Terminate the PSPP session. +* SET:: Adjust PSPP runtime parameters. +* SUBTITLE:: Provide a document subtitle. +* SYSFILE INFO:: Display the dictionary in a system file. +* TITLE:: Provide a document title. +@end menu + +@node COMMENT, DOCUMENT, Utilities, Utilities +@section COMMENT +@vindex COMMENT +@vindex * + +@display +Two possibles syntaxes: + COMMENT comment text @dots{} . + *comment text @dots{} . +@end display + +The COMMENT command is ignored. It is used to provide information to +the author and other readers of the PSPP syntax file. + +A COMMENT command can extend over any number of lines. Don't forget to +terminate it with a dot or a blank line! + +@node DOCUMENT, DISPLAY DOCUMENTS, COMMENT, Utilities +@section DOCUMENT +@vindex DOCUMENT + +@display +DOCUMENT documentary_text. +@end display + +The DOCUMENT command adds one or more lines of descriptive commentary to +the active file. Documents added in this way are saved to system files. +They can be viewed using SYSFILE INFO or DISPLAY DOCUMENTS. They can be +removed from the active file with DROP DOCUMENTS. + +Specify the documentary text following the DOCUMENT keyword. You can +extend the documentary text over as many lines as necessary. Lines are +truncated at 80 characters width. Don't forget to terminate the +DOCUMENT command with a dot or a blank line. + +@node DISPLAY DOCUMENTS, DISPLAY FILE LABEL, DOCUMENT, Utilities +@section DISPLAY DOCUMENTS +@vindex DISPLAY DOCUMENTS + +@display +DISPLAY DOCUMENTS. +@end display + +DISPLAY DOCUMENTS displays the documents in the active file. Each +document is preceded by a line giving the time and date that it was +added. @xref{DOCUMENT}. + +@node DISPLAY FILE LABEL, DROP DOCUMENTS, DISPLAY DOCUMENTS, Utilities +@section DISPLAY FILE LABEL +@vindex DISPLAY FILE LABEL + +@display +DISPLAY FILE LABEL. +@end display + +DISPLAY FILE LABEL displays the file label contained in the active file, +if any. @xref{FILE LABEL}. + +@node DROP DOCUMENTS, EXECUTE, DISPLAY FILE LABEL, Utilities +@section DROP DOCUMENTS +@vindex DROP DOCUMENTS + +@display +DROP DOCUMENTS. +@end display + +The DROP DOCUMENTS command removes all documents from the active file. +New documents can be added with the DOCUMENT utility (@pxref{DOCUMENT}). + +DROP DOCUMENTS only changes the active file. It does not modify any +system files stored on disk. + +@node EXECUTE, FILE LABEL, DROP DOCUMENTS, Utilities +@section EXECUTE +@vindex EXECUTE + +@display +EXECUTE. +@end display + +The EXECUTE utility causes the active file to be read and all pending +transformations to be executed. + +@node FILE LABEL, INCLUDE, EXECUTE, Utilities +@section FILE LABEL +@vindex FILE LABEL + +@display +FILE LABEL file_label. +@end display + +Use the FILE LABEL command to provide a title for the active file. This +title will be saved into system files and portable files that are +created during this PSPP run. + +It is not necessary to include quotes around file_label. If they are +included then they become part of the file label. + +@node INCLUDE, QUIT, FILE LABEL, Utilities +@section INCLUDE +@vindex INCLUDE +@vindex @@ + +@display +Two possible syntaxes: + INCLUDE 'filename'. + @@filename. +@end display + +The INCLUDE command causes the PSPP command processor to read an +additional command file as if it were included bodily in the current +command file. + +INCLUDE files may be nested to any depth, up to the limit of available +memory. + +@node QUIT, SET, INCLUDE, Utilities +@section QUIT +@vindex QUIT + +@display +Two possible syntaxes: + QUIT. + EXIT. +@end display + +The QUIT command terminates the current PSPP session and returns control +to the operating system. + +This command is not valid within a command file. + +@node SET, SUBTITLE, QUIT, Utilities +@section SET +@vindex SET + +@display +SET + +(data input) + /BLANKS=@{SYSMIS,'.',number@} + /DECIMAL=@{DOT,COMMA@} + /FORMAT=fmt_spec + +(program input) + /ENDCMD='.' + /NULLINE=@{ON,OFF@} + +(interaction) + /CPROMPT='cprompt_string' + /DPROMPT='dprompt_string' + /ERRORBREAK=@{OFF,ON@} + /MXERRS=max_errs + /MXWARNS=max_warnings + /PROMPT='prompt' + /VIEWLENGTH=@{MINIMUM,MEDIAN,MAXIMUM,n_lines@} + /VIEWWIDTH=n_characters + +(program execution) + /MEXPAND=@{ON,OFF@} + /MITERATE=max_iterations + /MNEST=max_nest + /MPRINT=@{ON,OFF@} + /MXLOOPS=max_loops + /SEED=@{RANDOM,seed_value@} + /UNDEFINED=@{WARN,NOWARN@} + +(data output) + /CC@{A,B,C,D,E@}=@{'npre,pre,suf,nsuf','npre.pre.suf.nsuf'@} + /DECIMAL=@{DOT,COMMA@} + /FORMAT=fmt_spec + +(output routing) + /ECHO=@{ON,OFF@} + /ERRORS=@{ON,OFF,TERMINAL,LISTING,BOTH,NONE@} + /INCLUDE=@{ON,OFF@} + /MESSAGES=@{ON,OFF,TERMINAL,LISTING,BOTH,NONE@} + /PRINTBACK=@{ON,OFF@} + /RESULTS=@{ON,OFF,TERMINAL,LISTING,BOTH,NONE@} + +(output activation) + /LISTING=@{ON,OFF@} + /PRINTER=@{ON,OFF@} + /SCREEN=@{ON,OFF@} + +(output driver options) + /HEADERS=@{NO,YES,BLANK@} + /LENGTH=@{NONE,length_in_lines@} + /LISTING=filename + /MORE=@{ON,OFF@} + /PAGER=@{OFF,"pager_name"@} + /WIDTH=@{NARROW,WIDTH,n_characters@} + +(logging) + /JOURNAL=@{ON,OFF@} [filename] + /LOG=@{ON,OFF@} [filename] + +(system files) + /COMPRESSION=@{ON,OFF@} + /SCOMPRESSION=@{ON,OFF@} + +(security) + /SAFER=ON + +(obsolete settings accepted for compatibility, but ignored) + /AUTOMENU=@{ON,OFF@} + /BEEP=@{ON,OFF@} + /BLOCK='c' + /BOXSTRING=@{'xxx','xxxxxxxxxxx'@} + /CASE=@{UPPER,UPLOW@} + /COLOR=@dots{} + /CPI=cpi_value + /DISK=@{ON,OFF@} + /EJECT=@{ON,OFF@} + /HELPWINDOWS=@{ON,OFF@} + /HIGHRES=@{ON,OFF@} + /HISTOGRAM='c' + /LOWRES=@{AUTO,ON,OFF@} + /LPI=lpi_value + /MENUS=@{STANDARD,EXTENDED@} + /MXMEMORY=max_memory + /PTRANSLATE=@{ON,OFF@} + /RCOLORS=@dots{} + /RUNREVIEW=@{AUTO,MANUAL@} + /SCRIPTTAB='c' + /TB1=@{'xxx','xxxxxxxxxxx'@} + /TBFONTS='string' + /WORKDEV=drive_letter + /WORKSPACE=workspace_size + /XSORT=@{YES,NO@} +@end display + +The SET command allows the user to adjust several parameters relating to +PSPP's execution. Since there are many subcommands to this command, its +subcommands will be examined in groups. + +As a general comment, ON and YES are considered synonymous, and +so are OFF and NO, when used as subcommand values. + +The data input subcommands affect the way that data is read from data +files. The data input subcommands are + +@table @asis +@item BLANKS +This is the value assigned to an item data item that is empty or +contains only whitespace. An argument of SYSMIS or '.' will cause the +system-missing value to be assigned to null items. This is the +default. Any real value may be assigned. + +@item DECIMAL +The default DOT setting causes the decimal point character to be +@samp{.}. A setting of COMMA causes the decimal point character to be +@samp{,}. + +@item FORMAT +Allows the default numeric input/output format to be specified. The +default is F8.2. @xref{Input/Output Formats}. +@end table + +Program input subcommands affect the way that programs are parsed when +they are typed interactively or run from a script. They are + +@table @asis +@item ENDCMD +This is a single character indicating the end of a command. The default +is @samp{.}. Don't change this. + +@item NULLINE +Whether a blank line is interpreted as ending the current command. The +default is ON. +@end table + +Interaction subcommands affect the way that PSPP interacts with an +online user. The interaction subcommands are + +@table @asis +@item CPROMPT +The command continuation prompt. The default is @samp{ > }. + +@item DPROMPT +Prompt used when expecting data input within BEGIN DATA (@pxref{BEGIN +DATA}). The default is @samp{data> }. + +@item ERRORBREAK +Whether an error causes PSPP to stop processing the current command +file after finishing the current command. The default is OFF. + +@item MXERRS +The maximum number of errors before PSPP halts processing of the current +command file. The default is 50. + +@item MXWARNS +The maximum number of warnings + errors before PSPP halts processing the +current command file. The default is 100. + +@item PROMPT +The command prompt. The default is @samp{PSPP> }. + +@item VIEWLENGTH +The length of the screen in lines. MINIMUM means 25 lines, MEDIAN and +MAXIMUM mean 43 lines. Otherwise specify the number of lines. Normally +PSPP should auto-detect your screen size so this shouldn't have to be +used. + +@item VIEWWIDTH +The width of the screen in characters. Normally 80 or 132. +@end table + +Program execution subcommands control the way that PSPP commands +execute. The program execution subcommands are + +@table @asis +@item MEXPAND +@itemx MITERATE +@itemx MNEST +@itemx MPRINT +Currently not used. + +@item MXLOOPS +The maximum number of iterations for an uncontrolled loop. + +@item SEED +The initial pseudo-random number seed. Set to a real number or to +RANDOM, which will obtain an initial seed from the current time of day. + +@item UNDEFINED +Currently not used. +@end table + +Data output subcommands affect the format of output data. These +subcommands are + +@table @asis +@item CCA +@itemx CCB +@itemx CCC +@itemx CCD +@itemx CCE +Set up custom currency formats. The argument is a string which must +contain exactly three commas or exactly three periods. If commas, then +the grouping character for the currency format is @samp{,}, and the +decimal point character is @samp{.}; if periods, then the situation is +reversed. + +The commas or periods divide the string into four fields, which are, in +order, the negative prefix, prefix, suffix, and negative suffix. When a +value is formatted using the custom currency format, the prefix precedes +the value formatted and the suffix follows it. In addition, if the +value is negative, the negative prefix precedes the prefix and the +negative suffix follows the suffix. + +@item DECIMAL +The default DOT setting causes the decimal point character to be +@samp{.}. A setting of COMMA causes the decimal point character to be +@samp{,}. + +@item FORMAT +Allows the default numeric input/output format to be specified. The +default is F8.2. @xref{Input/Output Formats}. +@end table + +Output routing subcommands affect where the output of transformations +and procedures is sent. These subcommands are + +@table @asis +@item ECHO + +If turned on, commands are written to the listing file as they are read +from command files. The default is OFF. + +@itemx ERRORS +@itemx INCLUDE +@itemx MESSAGES +@item PRINTBACK +@item RESULTS +Currently not used. +@end table + +Output activation subcommands affect whether output devices of +particular types are enabled. These subcommands are + +@table @asis +@item LISTING +Enable or disable listing devices. + +@item PRINTER +Enable or disable printer devices. + +@item SCREEN +Enable or disable screen devices. +@end table + +Output driver option subcommands affect output drivers' settings. These +subcommands are + +@table @asis +@item HEADERS +@itemx LENGTH +@itemx LISTING +@itemx MORE +@itemx PAGER +@itemx WIDTH +Currently not used. +@end table + +Logging subcommands affect logging of commands executed to external +files. These subcommands are + +@table @asis +@item JOURNAL +@item LOG +Not currently used. +@end table + +System file subcommands affect the default format of system files +produced by PSPP. These subcommands are + +@table @asis +@item COMPRESSION +Not currently used. + +@item SCOMPRESSION +Whether system files created by SAVE or XSAVE are compressed by default. +The default is ON. +@end table + +Security subcommands affect the operations that commands are allowed to +perform. The security subcommands are + +@table @asis +@item SAFER +When set, this setting cannot ever be reset, for obvious security +reasons. Setting this option disables the following operations: + +@itemize @bullet +@item +The ERASE command. +@item +The HOST command. +@item +Pipe filenames (filenames beginning or ending with @samp{|}). +@item +@end itemize + +Be aware that this setting does not guarantee safety (commands can still +overwrite files, for instance) but it is an improvement. +@end table + +@node SUBTITLE, TITLE, SET, Utilities +@section SUBTITLE +@vindex SUBTITLE + +@display +Two possible syntaxes: + SUBTITLE 'subtitle_string'. + SUBTITLE subtitle_string. +@end display + +The SUBTITLE command is used to provide a subtitle to a particular PSPP +run. This subtitle appears at the top of each output page below the +title, if titles are enabled on the output device. + +Specify a subtitle as a string in quotes. The alternate syntax that did +not require quotes is now obsolete. If it is used then the subtitle is +converted to all uppercase. + +@node TITLE, , SUBTITLE, Utilities +@section TITLE +@vindex TITLE + +@display +Two possible syntaxes: + TITLE 'title_string'. + TITLE title_string. +@end display + +The TITLE command is used to provide a title to a particular PSPP run. +This title appears at the top of each output page, if titles are enabled +on the output device. + +Specify a title as a string in quotes. The alternate syntax that did +not require quotes is now obsolete. If it is used then the title is +converted to all uppercase. + +@node Not Implemented, Data File Format, Utilities, Top +@chapter Not Implemented + +This chapter lists parts of the PSPP language that are not yet +implemented. + +The following transformations and utilities are not yet implemented, but +they will be supported in a later release. + +@itemize @bullet +@item +ADD FILES +@item +DEFINE +@item +FILE TYPE +@item +GET SAS +@item +GET TRANSLATE +@item +MCONVERT +@item +PRESERVE +@item +PROCEDURE OUTPUT +@item +RESTORE +@item +SAVE TRANSLATE +@item +SHOW +@item +UPDATE +@end itemize + +The following transformations and utilities are not implemented. There +are no plans to support them in future releases. Contributions to +implement them will still be accepted. + +@itemize @bullet +@item +EDIT +@item +GET DATABASE +@item +GET OSIRIS +@item +GET SCSS +@item +GSET +@item +HELP +@item +INFO +@item +INPUT MATRIX +@item +KEYED DATA LIST +@item +NUMBERED and UNNUMBERED +@item +OPTIONS +@item +REVIEW +@item +SAVE SCSS +@item +SPSS MANAGER +@item +STATISTICS +@end itemize + +@node Data File Format, Portable File Format, Not Implemented, Top +@chapter Data File Format + +PSPP necessarily uses the same format for system files as do the +products with which it is compatible. This chapter is a description of +that format. + +There are three data types used in system files: 32-bit integers, 64-bit +floating points, and 1-byte characters. In this document these will +simply be referred to as @code{int32}, @code{flt64}, and @code{char}, +the names that are used in the PSPP source code. Every field of type +@code{int32} or @code{flt64} is aligned on a 32-bit boundary. + +The endianness of data in PSPP system files is not specified. System +files output on a computer of a particular endianness will have the +endianness of that computer. However, PSPP can read files of either +endianness, regardless of its host computer's endianness. PSPP +translates endianness for both integer and floating point numbers. + +Floating point formats are also not specified. PSPP does not +translate between floating point formats. This is unlikely to be a +problem as all modern computer architectures use IEEE 754 format for +floating point representation. + +The PSPP system-missing value is represented by the largest possible +negative number in the floating point format; in C, this is most likely +@code{-DBL_MAX}. There are two other important values used in missing +values: @code{HIGHEST} and @code{LOWEST}. These are represented by the +largest possible positive number (probably @code{DBL_MAX}) and the +second-largest negative number. The latter must be determined in a +system-dependent manner; in IEEE 754 format it is represented by value +@code{0xffeffffffffffffe}. + +System files are divided into records. Each record begins with an +@code{int32} giving a numeric record type. Individual record types are +described below: + +@menu +* File Header Record:: +* Variable Record:: +* Value Label Record:: +* Value Label Variable Record:: +* Document Record:: +* Machine int32 Info Record:: +* Machine flt64 Info Record:: +* Miscellaneous Informational Records:: +* Dictionary Termination Record:: +* Data Record:: +@end menu + +@node File Header Record, Variable Record, Data File Format, Data File Format +@section File Header Record + +The file header is always the first record in the file. + +@example +struct sysfile_header + @{ + char rec_type[4]; + char prod_name[60]; + int32 layout_code; + int32 case_size; + int32 compressed; + int32 weight_index; + int32 ncases; + flt64 bias; + char creation_date[9]; + char creation_time[8]; + char file_label[64]; + char padding[3]; + @}; +@end example + +@table @code +@item char rec_type[4]; +Record type code. Always set to @samp{$FL2}. This is the only record +for which the record type is not of type @code{int32}. + +@item char prod_name[60]; +Product identification string. This always begins with the characters +@samp{@@(#) SPSS DATA FILE}. PSPP uses the remaining characters to +give its version and the operating system name; for example, @samp{GNU +pspp 0.1.4 - sparc-sun-solaris2.5.2}. The string is truncated if it +would be longer than 60 characters; otherwise it is padded on the right +with spaces. + +@item int32 layout_code; +Always set to 2. PSPP reads this value in order to determine the +file's endianness. + +@item int32 case_size; +Number of data elements per case. This is the number of variables, +except that long string variables add extra data elements (one for every +8 characters after the first 8). + +@item int32 compressed; +Set to 1 if the data in the file is compressed, 0 otherwise. + +@item int32 weight_index; +If one of the variables in the data set is used as a weighting variable, +set to the index of that variable. Otherwise, set to 0. + +@item int32 ncases; +Set to the number of cases in the file if it is known, or -1 otherwise. + +In the general case it is not possible to determine the number of cases +that will be output to a system file at the time that the header is +written. The way that this is dealt with is by writing the entire +system file, including the header, then seeking back to the beginning of +the file and writing just the @code{ncases} field. For `files' in which +this is not valid, the seek operation fails. In this case, +@code{ncases} remains -1. + +@item flt64 bias; +Compression bias. Always set to 100. The significance of this value is +that only numbers between @code{(1 - bias)} and @code{(251 - bias)} can +be compressed. + +@item char creation_date[9]; +Set to the date of creation of the system file, in @samp{dd mmm yy} +format, with the month as standard English abbreviations, using an +initial capital letter and following with lowercase. If the date is not +available then this field is arbitrarily set to @samp{01 Jan 70}. + +@item char creation_time[8]; +Set to the time of creation of the system file, in @samp{hh:mm:ss} +format and using 24-hour time. If the time is not available then this +field is arbitrarily set to @samp{00:00:00}. + +@item char file_label[64]; +Set the the file label declared by the user, if any. Padded on the +right with spaces. + +@item char padding[3]; +Ignored padding bytes to make the structure a multiple of 32 bits in +length. Set to zeros. +@end table + +@node Variable Record, Value Label Record, File Header Record, Data File Format +@section Variable Record + +Immediately following the header must come the variable records. There +must be one variable record for every variable and every 8 characters in +a long string beyond the first 8; i.e., there must be exactly as many +variable records as the value specified for @code{case_size} in the file +header record. + +@example +struct sysfile_variable + @{ + int32 rec_type; + int32 type; + int32 has_var_label; + int32 n_missing_values; + int32 print; + int32 write; + char name[8]; + + /* The following two fields are present + only if has_var_label is 1. */ + int32 label_len; + char label[/* variable length */]; + + /* The following field is present only + if n_missing_values is not 0. */ + flt64 missing_values[/* variable length*/]; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type code. Always set to 2. + +@item int32 type; +Variable type code. Set to 0 for a numeric variable. For a short +string variable or the first part of a long string variable, this is set +to the width of the string. For the second and subsequent parts of a +long string variable, set to -1, and the remaining fields in the +structure are ignored. + +@item int32 has_var_label; +If this variable has a variable label, set to 1; otherwise, set to 0. + +@item int32 n_missing_values; +If the variable has no missing values, set to 0. If the variable has +one, two, or three discrete missing values, set to 1, 2, or 3, +respectively. If the variable has a range for missing variables, set to +-2; if the variable has a range for missing variables plus a single +discrete value, set to -3. + +@item int32 print; +Print format for this variable. See below. + +@item int32 write; +Write format for this variable. See below. + +@item char name[8]; +Variable name. The variable name must begin with a capital letter or +the at-sign (@samp{@@}). Subsequent characters may also be octothorpes +(@samp{#}), dollar signs (@samp{$}), underscores (@samp{_}), or full +stops (@samp{.}). The variable name is padded on the right with spaces. + +@item int32 label_len; +This field is present only if @code{has_var_label} is set to 1. It is +set to the length, in characters, of the variable label, which must be a +number between 0 and 120. + +@item char label[/* variable length */]; +This field is present only if @code{has_var_label} is set to 1. It has +length @code{label_len}, rounded up to the nearest multiple of 32 bits. +The first @code{label_len} characters are the variable's variable label. + +@item flt64 missing_values[/* variable length */]; +This field is present only if @code{n_missing_values} is not 0. It has +the same number of elements as the absolute value of +@code{n_missing_values}. For discrete missing values, each element +represents one missing value. When a range is present, the first +element denotes the minimum value in the range, and the second element +denotes the maximum value in the range. When a range plus a value are +present, the third element denotes the additional discrete missing +value. HIGHEST and LOWEST are indicated as described in the chapter +introduction. +@end table + +The @code{print} and @code{write} members of sysfile_variable are output +formats coded into @code{int32} types. The LSB (least-significant byte) +of the @code{int32} represents the number of decimal places, and the +next two bytes in order of increasing significance represent field width +and format type, respectively. The MSB (most-significant byte) is not +used and should be set to zero. + +Format types are defined as follows: +@table @asis +@item 0 +Not used. +@item 1 +@code{A} +@item 2 +@code{AHEX} +@item 3 +@code{COMMA} +@item 4 +@code{DOLLAR} +@item 5 +@code{F} +@item 6 +@code{IB} +@item 7 +@code{PIBHEX} +@item 8 +@code{P} +@item 9 +@code{PIB} +@item 10 +@code{PK} +@item 11 +@code{RB} +@item 12 +@code{RBHEX} +@item 13 +Not used. +@item 14 +Not used. +@item 15 +@code{Z} +@item 16 +@code{N} +@item 17 +@code{E} +@item 18 +Not used. +@item 19 +Not used. +@item 20 +@code{DATE} +@item 21 +@code{TIME} +@item 22 +@code{DATETIME} +@item 23 +@code{ADATE} +@item 24 +@code{JDATE} +@item 25 +@code{DTIME} +@item 26 +@code{WKDAY} +@item 27 +@code{MONTH} +@item 28 +@code{MOYR} +@item 29 +@code{QYR} +@item 30 +@code{WKYR} +@item 31 +@code{PCT} +@item 32 +@code{DOT} +@item 33 +@code{CCA} +@item 34 +@code{CCB} +@item 35 +@code{CCC} +@item 36 +@code{CCD} +@item 37 +@code{CCE} +@item 38 +@code{EDATE} +@item 39 +@code{SDATE} +@end table + +@node Value Label Record, Value Label Variable Record, Variable Record, Data File Format +@section Value Label Record + +Value label records must follow the variable records and must precede +the header termination record. Other than this, they may appear +anywhere in the system file. Every value label record must be +immediately followed by a label variable record, described below. + +Value label records begin with @code{rec_type}, an @code{int32} value +set to the record type of 3. This is followed by @code{count}, an +@code{int32} value set to the number of value labels present in this +record. + +These two fields are followed by a series of @code{count} tuples. Each +tuple is divided into two fields, the value and the label. The first of +these, the value, is composed of a 64-bit value, which is either a +@code{flt64} value or up to 8 characters (padded on the right to 8 +bytes) denoting a short string value. Whether the value is a +@code{flt64} or a character string is not defined inside the value label +record. + +The second field in the tuple, the label, has variable length. The +first @code{char} is a count of the number of characters in the value +label. The remainder of the field is the label itself. The field is +padded on the right to a multiple of 64 bits in length. + +@node Value Label Variable Record, Document Record, Value Label Record, Data File Format +@section Value Label Variable Record + +Every value label variable record must be immediately preceded by a +value label record, described above. + +@example +struct sysfile_value_label_variable + @{ + int32 rec_type; + int32 count; + int32 vars[/* variable length */]; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 4. + +@item int32 count; +Number of variables that the associated value labels from the value +label record are to be applied. + +@item int32 vars[/* variable length]; +A list of variables to which to apply the value labels. There are +@code{count} elements. +@end table + +@node Document Record, Machine int32 Info Record, Value Label Variable Record, Data File Format +@section Document Record + +There must be no more than one document record per system file. +Document records must follow the variable records and precede the +dictionary termination record. + +@example +struct sysfile_document + @{ + int32 rec_type; + int32 n_lines; + char lines[/* variable length */][80]; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 6. + +@item int32 n_lines; +Number of lines of documents present. + +@item char lines[/* variable length */][80]; +Document lines. The number of elements is defined by @code{n_lines}. +Lines shorter than 80 characters are padded on the right with spaces. +@end table + +@node Machine int32 Info Record, Machine flt64 Info Record, Document Record, Data File Format +@section Machine @code{int32} Info Record + +There must be no more than one machine @code{int32} info record per +system file. Machine @code{int32} info records must follow the variable +records and precede the dictionary termination record. + +@example +struct sysfile_machine_int32_info + @{ + /* Header. */ + int32 rec_type; + int32 subtype; + int32 size; + int32 count; + + /* Data. */ + int32 version_major; + int32 version_minor; + int32 version_revision; + int32 machine_code; + int32 floating_point_rep; + int32 compression_code; + int32 endianness; + int32 character_code; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 7. + +@item int32 subtype; +Record subtype. Always set to 3. + +@item int32 size; +Size of each piece of data in the data part, in bytes. Always set to 4. + +@item int32 count; +Number of pieces of data in the data part. Always set to 8. + +@item int32 version_major; +PSPP major version number. In version @var{x}.@var{y}.@var{z}, this +is @var{x}. + +@item int32 version_minor; +PSPP minor version number. In version @var{x}.@var{y}.@var{z}, this +is @var{y}. + +@item int32 version_revision; +PSPP version revision number. In version @var{x}.@var{y}.@var{z}, +this is @var{z}. + +@item int32 machine_code; +Machine code. PSPP always set this field to value to -1, but other +values may appear. + +@item int32 floating_point_rep; +Floating point representation code. For IEEE 754 systems this is 1. +IBM 370 sets this to 2, and DEC VAX E to 3. + +@item int32 compression_code; +Compression code. Always set to 1. + +@item int32 endianness; +Machine endianness. 1 indicates big-endian, 2 indicates little-endian. + +@item int32 character_code; +Character code. 1 indicates EBCDIC, 2 indicates 7-bit ASCII, 3 +indicates 8-bit ASCII, 4 indicates DEC Kanji. +@end table + +@node Machine flt64 Info Record, Miscellaneous Informational Records, Machine int32 Info Record, Data File Format +@section Machine @code{flt64} Info Record + +There must be no more than one machine @code{flt64} info record per +system file. Machine @code{flt64} info records must follow the variable +records and precede the dictionary termination record. + +@example +struct sysfile_machine_flt64_info + @{ + /* Header. */ + int32 rec_type; + int32 subtype; + int32 size; + int32 count; + + /* Data. */ + flt64 sysmis; + flt64 highest; + flt64 lowest; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 3. + +@item int32 subtype; +Record subtype. Always set to 4. + +@item int32 size; +Size of each piece of data in the data part, in bytes. Always set to 4. + +@item int32 count; +Number of pieces of data in the data part. Always set to 3. + +@item flt64 sysmis; +The system missing value. + +@item flt64 highest; +The value used for HIGHEST in missing values. + +@item flt64 lowest; +The value used for LOWEST in missing values. +@end table + +@node Miscellaneous Informational Records, Dictionary Termination Record, Machine flt64 Info Record, Data File Format +@section Miscellaneous Informational Records + +Miscellaneous informational records must follow the variable records and +precede the dictionary termination record. + +Miscellaneous informational records are ignored by PSPP when reading +system files. They are not written by PSPP when writing system files. + +@example +struct sysfile_misc_info + @{ + /* Header. */ + int32 rec_type; + int32 subtype; + int32 size; + int32 count; + + /* Data. */ + char data[/* variable length */]; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 3. + +@item int32 subtype; +Record subtype. May take any value. + +@item int32 size; +Size of each piece of data in the data part. Should have the value 4 or +8, for @code{int32} and @code{flt64}, respectively. + +@item int32 count; +Number of pieces of data in the data part. + +@item char data[/* variable length */]; +Arbitrary data. There must be @code{size} times @code{count} bytes of +data. +@end table + +@node Dictionary Termination Record, Data Record, Miscellaneous Informational Records, Data File Format +@section Dictionary Termination Record + +The dictionary termination record must follow all other records, except +for the actual cases, which it must precede. There must be exactly one +dictionary termination record in every system file. + +@example +struct sysfile_dict_term + @{ + int32 rec_type; + int32 filler; + @}; +@end example + +@table @code +@item int32 rec_type; +Record type. Always set to 999. + +@item int32 filler; +Ignored padding. Should be set to 0. +@end table + +@node Data Record, , Dictionary Termination Record, Data File Format +@section Data Record + +Data records must follow all other records in the data file. There must +be at least one data record in every system file. + +The format of data records varies depending on whether the data is +compressed. Regardless, the data is arranged in a series of 8-byte +elements. + +When data is not compressed, Every case is composed of @code{case_size} +of these 8-byte elements, where @code{case_size} comes from the file +header record (@pxref{File Header Record}). Each element corresponds to +the variable declared in the respective variable record (@pxref{Variable +Record}). Numeric values are given in @code{flt64} format; string +values are literal characters string, padded on the right when +necessary. + +Compressed data is arranged in the following manner: the first 8-byte +element in the data section is divided into a series of 1-byte command +codes. These codes have meanings as described below: + +@table @asis +@item 0 +Ignored. If the program writing the system file accumulates compressed +data in blocks of fixed length, 0 bytes can be used to pad out extra +bytes remaining at the end of a fixed-size block. + +@item 1 through 251 +These values indicate that the corresponding numeric variable has the +value @code{(@var{code} - @var{bias})} for the case being read, where +@var{code} is the value of the compression code and @var{bias} is the +variable @code{compression_bias} from the file header. For example, +code 105 with bias 100.0 (the normal value) indicates a numeric variable +of value 5. + +@item 252 +End of file. This code may or may not appear at the end of the data +stream. PSPP always outputs this code but its use is not required. + +@item 253 +This value indicates that the numeric or string value is not +compressible. The value is stored in the 8-byte element following the +current block of command bytes. If this value appears twice in a block +of command bytes, then it indicates the second element following the +command bytes, and so on. + +@item 254 +Used to indicate a string value that is all spaces. + +@item 255 +Used to indicate the system-missing value. +@end table + +When the end of the first 8-byte element of command bytes is reached, +any blocks of non-compressible values are skipped, and the next element +of command bytes is read and interpreted, until the end of the file is +reached. + +@node Portable File Format, q2c Input Format, Data File Format, Top +@chapter Portable File Format + +These days, most computers use the same internal data formats for +integer and floating-point data, if one ignores little differences like +big- versus little-endian byte ordering. However, occasionally it is +necessary to exchange data between systems with incompatible data +formats. This is what portable files are designed to do. + +@strong{Please note:} Although all of the following information is +correct, as far as the author has been able to ascertain, it is gleaned +from examination of ASCII-formatted portable files only, so some of it +may be incorrect in the general case. + +@menu +* Portable File Characters:: +* Portable File Structure:: +* Portable File Header:: +* Version and Date Info Record:: +* Identification Records:: +* Variable Count Record:: +* Variable Records:: +* Value Label Records:: +* Portable File Data:: +@end menu + +@node Portable File Characters, Portable File Structure, Portable File Format, Portable File Format +@section Portable File Characters + +Portable files are arranged as a series of lines of exactly 80 +characters each. Each line is terminated by a carriage-return, +line-feed sequence (henceforth, ``newline''). Newlines are not +delimiters: they are only used to avoid line-length limitations existing +on some operating systems. + +The file must be terminated with a @samp{Z} character. In addition, if +the final line in the file does not have exactly 80 characters, then it +is padded on the right with @samp{Z} characters. (The file contents may +be in any character set; the file contains a description of its own +character set, as explained in the next section. Therefore, the +@samp{Z} character is not necessarily an ASCII @samp{Z}.) + +For the rest of the description of the portable file format, newlines +and the trailing @samp{Z}s will be ignored, as if they did not exist, +because they are not an important part of understanding the file +contents. + +@node Portable File Structure, Portable File Header, Portable File Characters, Portable File Format +@section Portable File Structure + +Every portable file consists of the following records, in sequence: + +@itemize @bullet + +@item +File header. + +@item +Version and date info. + +@item +Product identification. + +@item +Subproduct identification (optional). + +@item +Variable count. + +@item +Variables. Each variable record may optionally be followed by a +missing value record and a variable label record. + +@item +Value labels (optional). + +@item +Data. +@end itemize + +Most records are identified by a single-character tag code. The file +header and version info record do not have a tag. + +Other than these single-character codes, there are three types of fields +in a portable file: floating-point, integer, and string. Floating-point +fields have the following format: + +@itemize @bullet + +@item +Zero or more leading spaces. + +@item +Optional asterisk (@samp{*}), which indicates a missing value. The +asterisk must be followed by a single character, generally a period +(@samp{.}), but it appears that other characters may also be possible. +This completes the specification of a missing value. + +@item +Optional minus sign (@samp{-}) to indicate a negative number. + +@item +A whole number, consisting of one or more base-30 digits: @samp{0} +through @samp{9} plus capital letters @samp{A} through @samp{T}. + +@item +A fraction, consisting of a radix point (@samp{.}) followed by one or +more base-30 digits (optional). + +@item +An exponent, consisting of a plus or minus sign (@samp{+} or @samp{-}) +followed by one or more base-30 digits (optional). + +@item +A forward slash (@samp{/}). +@end itemize + +Integer fields take form identical to floating-point fields, but they +may not contain a fraction. + +String fields take the form of a integer field having value @var{n}, +followed by exactly @var{n} characters, which are the string content. + +@node Portable File Header, Version and Date Info Record, Portable File Structure, Portable File Format +@section Portable File Header + +Every portable file begins with a 464-byte header, consisting of a +200-byte collection of vanity splash strings, followed by a 256-byte +character set translation table, followed by an 8-byte tag string. + +The 200-byte segment is divided into five 40-byte sections, each of +which represents the string @code{ASCII SPSS PORT FILE} in a different +character set encoding. (If the file is encoded in EBCDIC then the +string is actually @code{EBCDIC SPSS PORT FILE}, and so on.) These +strings are padded on the right with spaces in their own character set. + +It appears that these strings exist only to inform those who might view +the file on a screen, and that they are not parsed by SPSS products. +Thus, they can be safely ignored. For those interested, the strings are +supposed to be in the following character sets, in the specified order: +EBCDIC, 7-bit ASCII, CDC 6-bit ASCII, 6-bit ASCII, Honeywell 6-bit +ASCII. + +The 256-byte segment describes a mapping from the character set used in +the portable file to an arbitrary character set having characters at the +following positions: + +@table @asis +@item 0--60 + +Control characters. Not important enough to describe in full here. + +@item 61--63 + +Reserved. + +@item 64--73 + +Digits @samp{0} through @samp{9}. + +@item 74--99 + +Capital letters @samp{A} through @samp{Z}. + +@item 100--125 + +Lowercase letters @samp{a} through @samp{z}. + +@item 126 + +Space. + +@item 127--130 + +Symbols @code{.<(+} + +@item 131 + +Solid vertical pipe. + +@item 132--142 + +Symbols @code{&[]!$*);^-/} + +@item 143 + +Broken vertical pipe. + +@item 144--150 + +Symbols @code{,%_>}?@code{`:} @c @code{?} is an inverted question mark + +@item 151 + +British pound symbol. + +@item 152--155 + +Symbols @code{@@'="}. + +@item 156 + +Less than or equal symbol. + +@item 157 + +Empty box. + +@item 158 + +Plus or minus. + +@item 159 + +Filled box. + +@item 160 + +Degree symbol. + +@item 161 + +Dagger. + +@item 162 + +Symbol @samp{~}. + +@item 163 + +En dash. + +@item 164 + +Lower left corner box draw. + +@item 165 + +Upper left corner box draw. + +@item 166 + +Greater than or equal symbol. + +@item 167--176 + +Superscript @samp{0} through @samp{9}. + +@item 177 + +Lower right corner box draw. + +@item 178 + +Upper right corner box draw. + +@item 179 + +Not equal symbol. + +@item 180 + +Em dash. + +@item 181 + +Superscript @samp{(}. + +@item 182 + +Superscript @samp{)}. + +@item 183 + +Horizontal dagger (?). + +@item 184--186 + +Symbols @samp{@{@}\}. +@item 187 + +Cents symbol. + +@item 188 + +Centered dot, or bullet. + +@item 189--255 + +Reserved. +@end table + +Symbols that are not defined in a particular character set are set to +the same value as symbol 64; i.e., to @samp{0}. + +The 8-byte tag string consists of the exact characters @code{SPSSPORT} +in the portable file's character set, which can be used to verify that +the file is indeed a portable file. + +@node Version and Date Info Record, Identification Records, Portable File Header, Portable File Format +@section Version and Date Info Record + +This record does not have a tag code. It has the following structure: + +@itemize @bullet +@item +A single character identifying the file format version. The letter A +represents version 0, and so on. + +@item +An 8-character string field giving the file creation date in the format +YYYYMMDD. + +@item +A 6-character string field giving the file creation time in the format +HHMMSS. +@end itemize + +@node Identification Records, Variable Count Record, Version and Date Info Record, Portable File Format +@section Identification Records + +The product identification record has tag code @samp{1}. It consists of +a single string field giving the name of the product that wrote the +portable file. + +The subproduct identification record has tag code @samp{3}. It +consists of a single string field giving additional information on the +product that wrote the portable file. + +@node Variable Count Record, Variable Records, Identification Records, Portable File Format +@section Variable Count Record + +The variable count record has tag code @samp{4}. It consists of two +integer fields. The first contains the number of variables in the file +dictionary. The purpose of the second is unknown; it contains the value +161 in all portable files examined so far. + +@node Variable Records, Value Label Records, Variable Count Record, Portable File Format +@section Variable Records + +Each variable record represents a single variable. Variable records +have tag code @samp{7}. They have the following structure: + +@itemize @bullet + +@item +Width (integer). This is 0 for a numeric variable, and a number between 1 +and 255 for a string variable. + +@item +Name (string). 1--8 characters long. Must be in all capitals. + +@item +Print format. This is a set of three integer fields: + +@itemize @minus + +@item +Format type (@pxref{Variable Record}). + +@item +Format width. 1--40. + +@item +Number of decimal places. 1--40. +@end itemize + +@item +Write format. Same structure as the print format described above. +@end itemize + +Each variable record can optionally be followed by a missing value +record, which has tag code @samp{8}. A missing value record has one +field, the missing value itself (a floating-point or string, as +appropriate). Up to three of these missing value records can be used. + +There is also a record for missing value ranges, which has tag code +@samp{B}. It is followed by two fields representing the range, which +are floating-point or string as appropriate. If a missing value range +is present, it may be followed by a single missing value record. + +Tag codes @samp{9} and @samp{A} represent @code{LO THRU @var{x}} and +@code{@var{x} THRU HI} ranges, respectively. Each is followed by a +single field representing @var{x}. If one of the ranges is present, it +may be followed by a single missing value record. + +In addition, each variable record can optionally be followed by a +variable label record, which has tag code @samp{C}. A variable label +record has one field, the variable label itself (string). + +@node Value Label Records, Portable File Data, Variable Records, Portable File Format +@section Value Label Records + +Value label records have tag code @samp{D}. They have the following +format: + +@itemize @bullet +@item +Variable count (integer). + +@item +List of variables (strings). The variable count specifies the number in +the list. Variables are specified by their names. All variables must +be of the same type (numeric or string). + +@item +Label count (integer). + +@item +List of (value, label) tuples. The label count specifies the number of +tuples. Each tuple consists of a value, which is numeric or string as +appropriate to the variables, followed by a label (string). +@end itemize + +@node Portable File Data, , Value Label Records, Portable File Format +@section Portable File Data + +The data record has tag code @samp{F}. There is only one tag for all +the data; thus, all the data must follow the dictionary. The data is +terminated by the end-of-file marker @samp{Z}, which is not valid as the +beginning of a data element. + +Data elements are output in the same order as the variable records +describing them. String variables are output as string fields, and +numeric variables are output as floating-point fields. + +@node q2c Input Format, Bugs, Portable File Format, Top +@chapter @code{q2c} Input Format + +PSPP statistical procedures have a bizarre and somewhat irregular +syntax. Despite this, a parser generator has been written that +adequately addresses many of the possibilities and tries to provide +hooks for the exceptional cases. This parser generator is named +@code{q2c}. + +@menu +* Invoking q2c:: q2c command-line syntax. +* q2c Input Structure:: High-level layout of the input file. +* Grammar Rules:: Syntax of the grammar rules. +@end menu + +@node Invoking q2c, q2c Input Structure, q2c Input Format, q2c Input Format +@section Invoking q2c + +@example +q2c @var{input.q} @var{output.c} +@end example + +@code{q2c} translates a @samp{.q} file into a @samp{.c} file. It takes +exactly two command-line arguments, which are the input file name and +output file name, respectively. @code{q2c} does not accept any +command-line options. + +@node q2c Input Structure, Grammar Rules, Invoking q2c, q2c Input Format +@section @code{q2c} Input Structure + +@code{q2c} input files are divided into two sections: the grammar rules +and the supporting code. The @dfn{grammar rules}, which make up the +first part of the input, are used to define the syntax of the +statistical procedure to be parsed. The @dfn{supporting code}, +following the grammar rules, are copied largely unchanged to the output +file, except for certain escapes. + +The most important lines in the grammar rules are used for defining +procedure syntax. These lines can be prefixed with a dollar sign +(@samp{$}), which prevents Emacs' CC-mode from munging them. Besides +this, a bang (@samp{!}) at the beginning of a line causes the line, +minus the bang, to be written verbatim to the output file (useful for +comments). As a third special case, any line that begins with the exact +characters @code{/* *INDENT} is ignored and not written to the output. +This allows @code{.q} files to be processed through @code{indent} +without being munged. + +The syntax of the grammar rules themselves is given in the following +sections. + +The supporting code is passed into the output file largely unchanged. +However, the following escapes are supported. Each escape must appear +on a line by itself. + +@table @code +@item /* (header) */ + +Expands to a series of C @code{#include} directives which include the +headers that are required for the parser generated by @code{q2c}. + +@item /* (decls @var{scope}) */ + +Expands to C variable and data type declarations for the variables and +@code{enum}s input and output by the @code{q2c} parser. @var{scope} +must be either @code{local} or @code{global}. @code{local} causes the +declarations to be output as function locals. @code{global} causes them +to be declared as @code{static} module variables; thus, @code{global} is +a bit of a misnomer. + +@item /* (parser) */ + +Expands to the entire parser. Must be enclosed within a C function. + +@item /* (free) */ + +Expands to a set of calls to the @code{free} function for variables +declared by the parser. Only needs to be invoked if subcommands of type +@code{string} are used in the grammar rules. +@end table + +@node Grammar Rules, , q2c Input Structure, q2c Input Format +@section Grammar Rules + +The grammar rules describe the format of the syntax that the parser +generated by @code{q2c} will understand. The way that the grammar rules +are included in @code{q2c} input file are described above. + +The grammar rules are divided into tokens of the following types: + +@table @asis +@item Identifier (@code{ID}) + +An identifier token is a sequence of letters, digits, and underscores +(@samp{_}). Identifiers are @emph{not} case-sensitive. + +@item String (@code{STRING}) + +String tokens are initiated by a double-quote character (@samp{"}) and +consist of all the characters between that double quote and the next +double quote, which must be on the same line as the first. Within a +string, a backslash can be used as a ``literal escape''. The only +reasons to use a literal escape are to include a double quote or a +backslash within a string. + +@item Special character + +Other characters, other than whitespace, constitute tokens in +themselves. + +@end table + +The syntax of the grammar rules is as follows: + +@example +grammar-rules ::= ID : subcommands . +subcommands ::= subcommand + ::= subcommands ; subcommand +@end example + +The syntax begins with an ID or STRING token that gives the name of the +procedure to be parsed. The rest of the syntax consists of subcommands +separated by semicolons (@samp{;}) and terminated with a full stop +(@samp{.}). + +@example +subcommand ::= sbc-options ID sbc-defn +sbc-options ::= + ::= sbc-option + ::= sbc-options sbc-options +sbc-option ::= * + ::= + +sbc-defn ::= opt-prefix = specifiers + ::= [ ID ] = array-sbc + ::= opt-prefix = sbc-special-form +opt-prefix ::= + ::= ( ID ) +@end example + +Each subcommand can be prefixed with one or more option characters. An +asterisk (@samp{*}) is used to indicate the default subcommand; the +keyword used for the default subcommand can be omitted in the PSPP +syntax file. A plus sign (@samp{+}) is used to indicate that a +subcommand can appear more than once; if it is not present then that +subcommand can appear no more than once. + +The subcommand name appears after the option characters. + +There are three forms of subcommands. The first and most common form +simply gives an equals sign (@samp{=}) and a list of specifiers, which +can each be set to a single setting. The second form declares an array, +which is a set of flags that can be individually turned on by the user. +There are also several special forms that do not take a list of +specifiers. + +Arrays require an additional @code{ID} argument. This is used as a +prefix, prepended to the variable names constructed from the +specifiers. The other forms also allow an optional prefix to be +specified. + +@example +array-sbc ::= alternatives + ::= array-sbc , alternatives +alternatives ::= ID + ::= alternatives | ID +@end example + +An array subcommand is a set of Boolean values that can independently be +turned on by the user, listed separated by commas (@samp{,}). If an value has more +than one name then these names are separated by pipes (@samp{|}). + +@example +specifiers ::= specifier + ::= specifiers , specifier +specifier ::= opt-id : settings +opt-id ::= + ::= ID +@end example + +Ordinary subcommands (other than arrays and special forms) require a +list of specifiers. Each specifier has an optional name and a list of +settings. If the name is given then a correspondingly named variable +will be used to store the user's choice of setting. If no name is given +then there is no way to tell which setting the user picked; in this case +the settings should probably have values attached. + +@example +settings ::= setting + ::= settings / setting +setting ::= setting-options ID setting-value +setting-options ::= + ::= * + ::= ! + ::= * ! +@end example + +Individual settings are separated by forward slashes (@samp{/}). Each +setting can be as little as an @code{ID} token, but options and values +can optionally be included. The @samp{*} option means that, for this +setting, the @code{ID} can be omitted. The @samp{!} option means that +this option is the default for its specifier. + +@example +setting-value ::= + ::= ( setting-value-2 ) + ::= setting-value-2 +setting-value-2 ::= setting-value-options setting-value-type : ID + setting-value-restriction +setting-value-options ::= + ::= * +setting-value-type ::= N + ::= D +setting-value-restriction ::= + ::= , STRING +@end example + +Settings may have values. If the value must be enclosed in parentheses, +then enclose the value declaration in parentheses. Declare the setting +type as @samp{n} or @samp{d} for integer or floating point type, +respectively. The given @code{ID} is used to construct a variable name. +If option @samp{*} is given, then the value is optional; otherwise it +must be specified whenever the corresponding setting is specified. A +``restriction'' can also be specified which is a string giving a C +expression limiting the valid range of the value. The special escape +@code{%s} should be used within the restriction to refer to the +setting's value variable. + +@example +sbc-special-form ::= VAR + ::= VARLIST varlist-options + ::= INTEGER opt-list + ::= DOUBLE opt-list + ::= PINT + ::= STRING @r{(the literal word STRING)} string-options + ::= CUSTOM +varlist-options ::= + ::= ( STRING ) +opt-list ::= + ::= LIST +string-options ::= + ::= ( STRING STRING ) +@end example + +The special forms are of the following types: + +@table @code +@item VAR + +A single variable name. + +@item VARLIST + +A list of variables. If given, the string can be used to provide +@code{PV_@var{*}} options to the call to @code{parse_variables}. + +@item INTEGER + +A single integer value. + +@item INTEGER LIST + +A list of integers separated by spaces or commas. + +@item DOUBLE + +A single floating-point value. + +@item DOUBLE LIST + +A list of floating-point values. + +@item PINT + +A single positive integer value. + +@item STRING + +A string value. If the options are given then the first string is an +expression giving a restriction on the value of the string; the second +string is an error message to display when the restriction is violated. + +@item CUSTOM + +A custom function is used to parse this subcommand. The function must +have prototype @code{int custom_@var{name} (void)}. It should return 0 +on failure (when it has already issued an appropriate diagnostic), 1 on +success, or 2 if it fails and the calling function should issue a syntax +error on behalf of the custom handler. + +@end table + +@node Bugs, Function Index, q2c Input Format, Top +@chapter Bugs + +@quotation +As of fvwm 0.99 there were exactly 39.342 unidentified bugs. Identified +bugs have mostly been fixed, though. Since then 9.34 bugs have been +fixed. Assuming that there are at least 10 unidentified bugs for every +identified one, that leaves us with 39.342 - 9.34 + 10 * 9.34 = 123.422 +unidentified bugs. If we follow this to its logical conclusion we +will have an infinite number of unidentified bugs before the number of +bugs can start to diminish, at which point the program will be +bug-free. Since this is a computer program infinity = 3.4028e+38 if you +don't insist on double-precision. At the current rate of bug discovery +we should expect to achieve this point in 3.37e+27 years. I guess I +better plan on passing this thing on to my children@enddots{} + +---Robert Nation, @cite{fvwm manpage}. +@end quotation + +@menu +* Known bugs:: Pointers to other files. +* Contacting the Author:: Where to send the bug reports. +@end menu + +@node Known bugs, Contacting the Author, Bugs, Bugs +@section Known bugs + +This is the list of known bugs in PSPP. In addition, @xref{Not +Implemented}, and @xref{Functions Not Implemented}, for lists of bugs +due to features not implemented. For known bugs in individual language +features, see the documentation for that feature. + +@itemize @bullet +@item +Nothing has yet been tested exhaustively. Be cautious using PSPP to +make important decisions. + +@item +@code{make check} fails on some systems that don't like the syntax. I'm +not sure why. If someone could make an attempt to track this down, it +would be appreciated. + +@item +PostScript driver bugs: + +@itemize @minus +@item +Does not support driver arguments `max-fonts-simult' or +`optimize-text-size'. + +@item +Minor problems with font-encodings. + +@item +Fails to align fonts along their baselines. + +@item +Does not support certain bizarre line intersections--should +never crop up in practice. + +@item +Does not gracefully substitute for existing fonts whose +encodings are missing. + +@item +Does not perform italic correction or left italic correction +on font changes. + +@item +Encapsulated PostScript is unimplemented. +@end itemize + +@item +ASCII driver bugs: + +@itemize @minus +Does not support `infinite length' or `infinite width' paper. +@end itemize +@end itemize + +See below for information on reporting bugs not listed here. + +@node Contacting the Author, , Known bugs, Bugs +@section Contacting the Author + +The author can be contacted at e-mail address +@ifinfo +. +@end ifinfo +@iftex +@code{}. +@end iftex + +PSPP bug reports should be sent to +@ifinfo +. +@end ifinfo +@iftex +@code{}. +@end iftex + +@node Function Index, Concept Index, Bugs, Top +@chapter Function Index +@printindex fn + +@node Concept Index, Command Index, Function Index, Top +@chapter Concept Index +@printindex cp + +@node Command Index, , Concept Index, Top +@chapter Command Index +@printindex vr + +@contents +@bye + +@c Local Variables: +@c compile-command: "makeinfo pspp.texi" +@c End: diff --git a/doc/texinfo.tex b/doc/texinfo.tex new file mode 100644 index 00000000..4c03dfac --- /dev/null +++ b/doc/texinfo.tex @@ -0,0 +1,4424 @@ +%% TeX macros to handle texinfo files + +% Copyright (C) 1985, 86, 88, 90, 91, 92, 93, 1994 Free Software Foundation, Inc. + +%This texinfo.tex file is free software; you can redistribute it and/or +%modify it under the terms of the GNU General Public License as +%published by the Free Software Foundation; either version 2, or (at +%your option) any later version. + +%This texinfo.tex file is distributed in the hope that it will be +%useful, but WITHOUT ANY WARRANTY; without even the implied warranty +%of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +%General Public License for more details. + +%You should have received a copy of the GNU General Public License +%along with this texinfo.tex file; see the file COPYING. If not, write +%to the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, +%USA. + + +%In other words, you are welcome to use, share and improve this program. +%You are forbidden to forbid anyone else to use, share and improve +%what you give them. Help stamp out software-hoarding! + + +% Send bug reports to bug-texinfo@prep.ai.mit.edu. +% Please include a *precise* test case in each bug report. + + +% Make it possible to create a .fmt file just by loading this file: +% if the underlying format is not loaded, start by loading it now. +% Added by gildea November 1993. +\expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi + +% This automatically updates the version number based on RCS. +\def\deftexinfoversion$#1: #2 ${\def\texinfoversion{#2}} +\deftexinfoversion$Revision: 1.1 $ +\message{Loading texinfo package [Version \texinfoversion]:} + +% If in a .fmt file, print the version number +% and turn on active characters that we couldn't do earlier because +% they might have appeared in the input file name. +\everyjob{\message{[Texinfo version \texinfoversion]}\message{} + \catcode`+=\active \catcode`\_=\active} + +% Save some parts of plain tex whose names we will redefine. + +\let\ptextilde=\~ +\let\ptexlbrace=\{ +\let\ptexrbrace=\} +\let\ptexdots=\dots +\let\ptexdot=\. +\let\ptexstar=\* +\let\ptexend=\end +\let\ptexbullet=\bullet +\let\ptexb=\b +\let\ptexc=\c +\let\ptexi=\i +\let\ptext=\t +\let\ptexl=\l +\let\ptexL=\L + +% Be sure we're in horizontal mode when doing a tie, since we make space +% equivalent to this in @example-like environments. Otherwise, a space +% at the beginning of a line will start with \penalty -- and +% since \penalty is valid in vertical mode, we'd end up putting the +% penalty on the vertical list instead of in the new paragraph. +{\catcode`@ = 11 + \gdef\tie{\leavevmode\penalty\@M\ } +} +\let\~ = \tie % And make it available as @~. + +\message{Basics,} +\chardef\other=12 + +% If this character appears in an error message or help string, it +% starts a new line in the output. +\newlinechar = `^^J + +% Set up fixed words for English. +\ifx\putwordChapter\undefined{\gdef\putwordChapter{Chapter}}\fi% +\def\putwordInfo{Info}% +\ifx\putwordSee\undefined{\gdef\putwordSee{See}}\fi% +\ifx\putwordsee\undefined{\gdef\putwordsee{see}}\fi% +\ifx\putwordfile\undefined{\gdef\putwordfile{file}}\fi% +\ifx\putwordpage\undefined{\gdef\putwordpage{page}}\fi% +\ifx\putwordsection\undefined{\gdef\putwordsection{section}}\fi% +\ifx\putwordSection\undefined{\gdef\putwordSection{Section}}\fi% +\ifx\putwordTableofContents\undefined{\gdef\putwordTableofContents{Table of Contents}}\fi% +\ifx\putwordShortContents\undefined{\gdef\putwordShortContents{Short Contents}}\fi% +\ifx\putwordAppendix\undefined{\gdef\putwordAppendix{Appendix}}\fi% + +% Ignore a token. +% +\def\gobble#1{} + +\hyphenation{ap-pen-dix} +\hyphenation{mini-buf-fer mini-buf-fers} +\hyphenation{eshell} + +% Margin to add to right of even pages, to left of odd pages. +\newdimen \bindingoffset \bindingoffset=0pt +\newdimen \normaloffset \normaloffset=\hoffset +\newdimen\pagewidth \newdimen\pageheight +\pagewidth=\hsize \pageheight=\vsize + +% Sometimes it is convenient to have everything in the transcript file +% and nothing on the terminal. We don't just call \tracingall here, +% since that produces some useless output on the terminal. +% +\def\gloggingall{\begingroup \globaldefs = 1 \loggingall \endgroup}% +\def\loggingall{\tracingcommands2 \tracingstats2 + \tracingpages1 \tracingoutput1 \tracinglostchars1 + \tracingmacros2 \tracingparagraphs1 \tracingrestores1 + \showboxbreadth\maxdimen\showboxdepth\maxdimen +}% + +%---------------------Begin change----------------------- +% +%%%% For @cropmarks command. +% Dimensions to add cropmarks at corners Added by P. A. MacKay, 12 Nov. 1986 +% +\newdimen\cornerlong \newdimen\cornerthick +\newdimen \topandbottommargin +\newdimen \outerhsize \newdimen \outervsize +\cornerlong=1pc\cornerthick=.3pt % These set size of cropmarks +\outerhsize=7in +%\outervsize=9.5in +% Alternative @smallbook page size is 9.25in +\outervsize=9.25in +\topandbottommargin=.75in +% +%---------------------End change----------------------- + +% \onepageout takes a vbox as an argument. Note that \pagecontents +% does insertions itself, but you have to call it yourself. +\chardef\PAGE=255 \output={\onepageout{\pagecontents\PAGE}} +\def\onepageout#1{\hoffset=\normaloffset +\ifodd\pageno \advance\hoffset by \bindingoffset +\else \advance\hoffset by -\bindingoffset\fi +{\escapechar=`\\\relax % makes sure backslash is used in output files. +\shipout\vbox{{\let\hsize=\pagewidth \makeheadline} \pagebody{#1}% +{\let\hsize=\pagewidth \makefootline}}}% +\advancepageno \ifnum\outputpenalty>-20000 \else\dosupereject\fi} + +%%%% For @cropmarks command %%%% + +% Here is a modification of the main output routine for Near East Publications +% This provides right-angle cropmarks at all four corners. +% The contents of the page are centerlined into the cropmarks, +% and any desired binding offset is added as an \hskip on either +% site of the centerlined box. (P. A. MacKay, 12 November, 1986) +% +\def\croppageout#1{\hoffset=0pt % make sure this doesn't mess things up +{\escapechar=`\\\relax % makes sure backslash is used in output files. + \shipout + \vbox to \outervsize{\hsize=\outerhsize + \vbox{\line{\ewtop\hfill\ewtop}} + \nointerlineskip + \line{\vbox{\moveleft\cornerthick\nstop} + \hfill + \vbox{\moveright\cornerthick\nstop}} + \vskip \topandbottommargin + \centerline{\ifodd\pageno\hskip\bindingoffset\fi + \vbox{ + {\let\hsize=\pagewidth \makeheadline} + \pagebody{#1} + {\let\hsize=\pagewidth \makefootline}} + \ifodd\pageno\else\hskip\bindingoffset\fi} + \vskip \topandbottommargin plus1fill minus1fill + \boxmaxdepth\cornerthick + \line{\vbox{\moveleft\cornerthick\nsbot} + \hfill + \vbox{\moveright\cornerthick\nsbot}} + \nointerlineskip + \vbox{\line{\ewbot\hfill\ewbot}} + }} + \advancepageno + \ifnum\outputpenalty>-20000 \else\dosupereject\fi} +% +% Do @cropmarks to get crop marks +\def\cropmarks{\let\onepageout=\croppageout } + +\newinsert\margin \dimen\margin=\maxdimen + +\def\pagebody#1{\vbox to\pageheight{\boxmaxdepth=\maxdepth #1}} +{\catcode`\@ =11 +\gdef\pagecontents#1{\ifvoid\topins\else\unvbox\topins\fi +% marginal hacks, juha@viisa.uucp (Juha Takala) +\ifvoid\margin\else % marginal info is present + \rlap{\kern\hsize\vbox to\z@{\kern1pt\box\margin \vss}}\fi +\dimen@=\dp#1 \unvbox#1 +\ifvoid\footins\else\vskip\skip\footins\footnoterule \unvbox\footins\fi +\ifr@ggedbottom \kern-\dimen@ \vfil \fi} +} + +% +% Here are the rules for the cropmarks. Note that they are +% offset so that the space between them is truly \outerhsize or \outervsize +% (P. A. MacKay, 12 November, 1986) +% +\def\ewtop{\vrule height\cornerthick depth0pt width\cornerlong} +\def\nstop{\vbox + {\hrule height\cornerthick depth\cornerlong width\cornerthick}} +\def\ewbot{\vrule height0pt depth\cornerthick width\cornerlong} +\def\nsbot{\vbox + {\hrule height\cornerlong depth\cornerthick width\cornerthick}} + +% Parse an argument, then pass it to #1. The argument is the rest of +% the input line (except we remove a trailing comment). #1 should be a +% macro which expects an ordinary undelimited TeX argument. +% +\def\parsearg#1{% + \let\next = #1% + \begingroup + \obeylines + \futurelet\temp\parseargx +} + +% If the next token is an obeyed space (from an @example environment or +% the like), remove it and recurse. Otherwise, we're done. +\def\parseargx{% + % \obeyedspace is defined far below, after the definition of \sepspaces. + \ifx\obeyedspace\temp + \expandafter\parseargdiscardspace + \else + \expandafter\parseargline + \fi +} + +% Remove a single space (as the delimiter token to the macro call). +{\obeyspaces % + \gdef\parseargdiscardspace {\futurelet\temp\parseargx}} + +{\obeylines % + \gdef\parseargline#1^^M{% + \endgroup % End of the group started in \parsearg. + % + % First remove any @c comment, then any @comment. + % Result of each macro is put in \toks0. + \argremovec #1\c\relax % + \expandafter\argremovecomment \the\toks0 \comment\relax % + % + % Call the caller's macro, saved as \next in \parsearg. + \expandafter\next\expandafter{\the\toks0}% + }% +} + +% Since all \c{,omment} does is throw away the argument, we can let TeX +% do that for us. The \relax here is matched by the \relax in the call +% in \parseargline; it could be more or less anything, its purpose is +% just to delimit the argument to the \c. +\def\argremovec#1\c#2\relax{\toks0 = {#1}} +\def\argremovecomment#1\comment#2\relax{\toks0 = {#1}} + +% \argremovec{,omment} might leave us with trailing spaces, though; e.g., +% @end itemize @c foo +% will have two active spaces as part of the argument with the +% `itemize'. Here we remove all active spaces from #1, and assign the +% result to \toks0. +% +% This loses if there are any *other* active characters besides spaces +% in the argument -- _ ^ +, for example -- since they get expanded. +% Fortunately, Texinfo does not define any such commands. (If it ever +% does, the catcode of the characters in questionwill have to be changed +% here.) But this means we cannot call \removeactivespaces as part of +% \argremovec{,omment}, since @c uses \parsearg, and thus the argument +% that \parsearg gets might well have any character at all in it. +% +\def\removeactivespaces#1{% + \begingroup + \ignoreactivespaces + \edef\temp{#1}% + \global\toks0 = \expandafter{\temp}% + \endgroup +} + +% Change the active space to expand to nothing. +% +\begingroup + \obeyspaces + \gdef\ignoreactivespaces{\obeyspaces\let =\empty} +\endgroup + + +\def\flushcr{\ifx\par\lisppar \def\next##1{}\else \let\next=\relax \fi \next} + +%% These are used to keep @begin/@end levels from running away +%% Call \inENV within environments (after a \begingroup) +\newif\ifENV \ENVfalse \def\inENV{\ifENV\relax\else\ENVtrue\fi} +\def\ENVcheck{% +\ifENV\errmessage{Still within an environment. Type Return to continue.} +\endgroup\fi} % This is not perfect, but it should reduce lossage + +% @begin foo is the same as @foo, for now. +\newhelp\EMsimple{Type to continue.} + +\outer\def\begin{\parsearg\beginxxx} + +\def\beginxxx #1{% +\expandafter\ifx\csname #1\endcsname\relax +{\errhelp=\EMsimple \errmessage{Undefined command @begin #1}}\else +\csname #1\endcsname\fi} + +% @end foo executes the definition of \Efoo. +% +\def\end{\parsearg\endxxx} +\def\endxxx #1{% + \removeactivespaces{#1}% + \edef\endthing{\the\toks0}% + % + \expandafter\ifx\csname E\endthing\endcsname\relax + \expandafter\ifx\csname \endthing\endcsname\relax + % There's no \foo, i.e., no ``environment'' foo. + \errhelp = \EMsimple + \errmessage{Undefined command `@end \endthing'}% + \else + \unmatchedenderror\endthing + \fi + \else + % Everything's ok; the right environment has been started. + \csname E\endthing\endcsname + \fi +} + +% There is an environment #1, but it hasn't been started. Give an error. +% +\def\unmatchedenderror#1{% + \errhelp = \EMsimple + \errmessage{This `@end #1' doesn't have a matching `@#1'}% +} + +% Define the control sequence \E#1 to give an unmatched @end error. +% +\def\defineunmatchedend#1{% + \expandafter\def\csname E#1\endcsname{\unmatchedenderror{#1}}% +} + + +% Single-spacing is done by various environments (specifically, in +% \nonfillstart and \quotations). +\newskip\singlespaceskip \singlespaceskip = 12.5pt +\def\singlespace{% + % Why was this kern here? It messes up equalizing space above and below + % environments. --karl, 6may93 + %{\advance \baselineskip by -\singlespaceskip + %\kern \baselineskip}% + \setleading \singlespaceskip +} + +%% Simple single-character @ commands + +% @@ prints an @ +% Kludge this until the fonts are right (grr). +\def\@{{\tt \char '100}} + +% This is turned off because it was never documented +% and you can use @w{...} around a quote to suppress ligatures. +%% Define @` and @' to be the same as ` and ' +%% but suppressing ligatures. +%\def\`{{`}} +%\def\'{{'}} + +% Used to generate quoted braces. + +\def\mylbrace {{\tt \char '173}} +\def\myrbrace {{\tt \char '175}} +\let\{=\mylbrace +\let\}=\myrbrace + +% @: forces normal size whitespace following. +\def\:{\spacefactor=1000 } + +% @* forces a line break. +\def\*{\hfil\break\hbox{}\ignorespaces} + +% @. is an end-of-sentence period. +\def\.{.\spacefactor=3000 } + +% @enddots{} is an end-of-sentence ellipsis. +\gdef\enddots{$\mathinner{\ldotp\ldotp\ldotp\ldotp}$\spacefactor=3000} + +% @! is an end-of-sentence bang. +\gdef\!{!\spacefactor=3000 } + +% @? is an end-of-sentence query. +\gdef\?{?\spacefactor=3000 } + +% @w prevents a word break. Without the \leavevmode, @w at the +% beginning of a paragraph, when TeX is still in vertical mode, would +% produce a whole line of output instead of starting the paragraph. +\def\w#1{\leavevmode\hbox{#1}} + +% @group ... @end group forces ... to be all on one page, by enclosing +% it in a TeX vbox. We use \vtop instead of \vbox to construct the box +% to keep its height that of a normal line. According to the rules for +% \topskip (p.114 of the TeXbook), the glue inserted is +% max (\topskip - \ht (first item), 0). If that height is large, +% therefore, no glue is inserted, and the space between the headline and +% the text is small, which looks bad. +% +\def\group{\begingroup + \ifnum\catcode13=\active \else + \errhelp = \groupinvalidhelp + \errmessage{@group invalid in context where filling is enabled}% + \fi + % + % The \vtop we start below produces a box with normal height and large + % depth; thus, TeX puts \baselineskip glue before it, and (when the + % next line of text is done) \lineskip glue after it. (See p.82 of + % the TeXbook.) Thus, space below is not quite equal to space + % above. But it's pretty close. + \def\Egroup{% + \egroup % End the \vtop. + \endgroup % End the \group. + }% + % + \vtop\bgroup + % We have to put a strut on the last line in case the @group is in + % the midst of an example, rather than completely enclosing it. + % Otherwise, the interline space between the last line of the group + % and the first line afterwards is too small. But we can't put the + % strut in \Egroup, since there it would be on a line by itself. + % Hence this just inserts a strut at the beginning of each line. + \everypar = {\strut}% + % + % Since we have a strut on every line, we don't need any of TeX's + % normal interline spacing. + \offinterlineskip + % + % OK, but now we have to do something about blank + % lines in the input in @example-like environments, which normally + % just turn into \lisppar, which will insert no space now that we've + % turned off the interline space. Simplest is to make them be an + % empty paragraph. + \ifx\par\lisppar + \edef\par{\leavevmode \par}% + % + % Reset ^^M's definition to new definition of \par. + \obeylines + \fi + % + % Do @comment since we are called inside an environment such as + % @example, where each end-of-line in the input causes an + % end-of-line in the output. We don't want the end-of-line after + % the `@group' to put extra space in the output. Since @group + % should appear on a line by itself (according to the Texinfo + % manual), we don't worry about eating any user text. + \comment +} +% +% TeX puts in an \escapechar (i.e., `@') at the beginning of the help +% message, so this ends up printing `@group can only ...'. +% +\newhelp\groupinvalidhelp{% +group can only be used in environments such as @example,^^J% +where each line of input produces a line of output.} + +% @need space-in-mils +% forces a page break if there is not space-in-mils remaining. + +\newdimen\mil \mil=0.001in + +\def\need{\parsearg\needx} + +% Old definition--didn't work. +%\def\needx #1{\par % +%% This method tries to make TeX break the page naturally +%% if the depth of the box does not fit. +%{\baselineskip=0pt% +%\vtop to #1\mil{\vfil}\kern -#1\mil\penalty 10000 +%\prevdepth=-1000pt +%}} + +\def\needx#1{% + % Go into vertical mode, so we don't make a big box in the middle of a + % paragraph. + \par + % + % Don't add any leading before our big empty box, but allow a page + % break, since the best break might be right here. + \allowbreak + \nointerlineskip + \vtop to #1\mil{\vfil}% + % + % TeX does not even consider page breaks if a penalty added to the + % main vertical list is 10000 or more. But in order to see if the + % empty box we just added fits on the page, we must make it consider + % page breaks. On the other hand, we don't want to actually break the + % page after the empty box. So we use a penalty of 9999. + % + % There is an extremely small chance that TeX will actually break the + % page at this \penalty, if there are no other feasible breakpoints in + % sight. (If the user is using lots of big @group commands, which + % almost-but-not-quite fill up a page, TeX will have a hard time doing + % good page breaking, for example.) However, I could not construct an + % example where a page broke at this \penalty; if it happens in a real + % document, then we can reconsider our strategy. + \penalty9999 + % + % Back up by the size of the box, whether we did a page break or not. + \kern -#1\mil + % + % Do not allow a page break right after this kern. + \nobreak +} + +% @br forces paragraph break + +\let\br = \par + +% @dots{} output some dots + +\def\dots{$\ldots$} + +% @page forces the start of a new page + +\def\page{\par\vfill\supereject} + +% @exdent text.... +% outputs text on separate line in roman font, starting at standard page margin + +% This records the amount of indent in the innermost environment. +% That's how much \exdent should take out. +\newskip\exdentamount + +% This defn is used inside fill environments such as @defun. +\def\exdent{\parsearg\exdentyyy} +\def\exdentyyy #1{{\hfil\break\hbox{\kern -\exdentamount{\rm#1}}\hfil\break}} + +% This defn is used inside nofill environments such as @example. +\def\nofillexdent{\parsearg\nofillexdentyyy} +\def\nofillexdentyyy #1{{\advance \leftskip by -\exdentamount +\leftline{\hskip\leftskip{\rm#1}}}} + +%\hbox{{\rm#1}}\hfil\break}} + +% @include file insert text of that file as input. + +\def\include{\parsearg\includezzz} +%Use \input\thisfile to avoid blank after \input, which may be an active +%char (in which case the blank would become the \input argument). +%The grouping keeps the value of \thisfile correct even when @include +%is nested. +\def\includezzz #1{\begingroup +\def\thisfile{#1}\input\thisfile +\endgroup} + +\def\thisfile{} + +% @center line outputs that line, centered + +\def\center{\parsearg\centerzzz} +\def\centerzzz #1{{\advance\hsize by -\leftskip +\advance\hsize by -\rightskip +\centerline{#1}}} + +% @sp n outputs n lines of vertical space + +\def\sp{\parsearg\spxxx} +\def\spxxx #1{\par \vskip #1\baselineskip} + +% @comment ...line which is ignored... +% @c is the same as @comment +% @ignore ... @end ignore is another way to write a comment + +\def\comment{\catcode 64=\other \catcode 123=\other \catcode 125=\other% +\parsearg \commentxxx} + +\def\commentxxx #1{\catcode 64=0 \catcode 123=1 \catcode 125=2 } + +\let\c=\comment + +% Prevent errors for section commands. +% Used in @ignore and in failing conditionals. +\def\ignoresections{% +\let\chapter=\relax +\let\unnumbered=\relax +\let\top=\relax +\let\unnumberedsec=\relax +\let\unnumberedsection=\relax +\let\unnumberedsubsec=\relax +\let\unnumberedsubsection=\relax +\let\unnumberedsubsubsec=\relax +\let\unnumberedsubsubsection=\relax +\let\section=\relax +\let\subsec=\relax +\let\subsubsec=\relax +\let\subsection=\relax +\let\subsubsection=\relax +\let\appendix=\relax +\let\appendixsec=\relax +\let\appendixsection=\relax +\let\appendixsubsec=\relax +\let\appendixsubsection=\relax +\let\appendixsubsubsec=\relax +\let\appendixsubsubsection=\relax +\let\contents=\relax +\let\smallbook=\relax +\let\titlepage=\relax +} + +% Used in nested conditionals, where we have to parse the Texinfo source +% and so want to turn off most commands, in case they are used +% incorrectly. +% +\def\ignoremorecommands{% + \let\defcv = \relax + \let\deffn = \relax + \let\deffnx = \relax + \let\defindex = \relax + \let\defivar = \relax + \let\defmac = \relax + \let\defmethod = \relax + \let\defop = \relax + \let\defopt = \relax + \let\defspec = \relax + \let\deftp = \relax + \let\deftypefn = \relax + \let\deftypefun = \relax + \let\deftypevar = \relax + \let\deftypevr = \relax + \let\defun = \relax + \let\defvar = \relax + \let\defvr = \relax + \let\ref = \relax + \let\xref = \relax + \let\printindex = \relax + \let\pxref = \relax + \let\settitle = \relax + \let\include = \relax + \let\lowersections = \relax + \let\down = \relax + \let\raisesections = \relax + \let\up = \relax + \let\set = \relax + \let\clear = \relax + \let\item = \relax + \let\message = \relax +} + +% Ignore @ignore ... @end ignore. +% +\def\ignore{\doignore{ignore}} + +% Also ignore @ifinfo, @ifhtml, @html, @menu, and @direntry text. +% +\def\ifinfo{\doignore{ifinfo}} +\def\ifhtml{\doignore{ifhtml}} +\def\html{\doignore{html}} +\def\menu{\doignore{menu}} +\def\direntry{\doignore{direntry}} + +% Ignore text until a line `@end #1'. +% +\def\doignore#1{\begingroup + % Don't complain about control sequences we have declared \outer. + \ignoresections + % + % Define a command to swallow text until we reach `@end #1'. + \long\def\doignoretext##1\end #1{\enddoignore}% + % + % Make sure that spaces turn into tokens that match what \doignoretext wants. + \catcode32 = 10 + % + % And now expand that command. + \doignoretext +} + +% What we do to finish off ignored text. +% +\def\enddoignore{\endgroup\ignorespaces}% + +\newif\ifwarnedobs\warnedobsfalse +\def\obstexwarn{% + \ifwarnedobs\relax\else + % We need to warn folks that they may have trouble with TeX 3.0. + % This uses \immediate\write16 rather than \message to get newlines. + \immediate\write16{} + \immediate\write16{***WARNING*** for users of Unix TeX 3.0!} + \immediate\write16{This manual trips a bug in TeX version 3.0 (tex hangs).} + \immediate\write16{If you are running another version of TeX, relax.} + \immediate\write16{If you are running Unix TeX 3.0, kill this TeX process.} + \immediate\write16{ Then upgrade your TeX installation if you can.} + \immediate\write16{If you are stuck with version 3.0, run the} + \immediate\write16{ script ``tex3patch'' from the Texinfo distribution} + \immediate\write16{ to use a workaround.} + \immediate\write16{} + \warnedobstrue + \fi +} + +% **In TeX 3.0, setting text in \nullfont hangs tex. For a +% workaround (which requires the file ``dummy.tfm'' to be installed), +% uncomment the following line: +%%%%%\font\nullfont=dummy\let\obstexwarn=\relax + +% Ignore text, except that we keep track of conditional commands for +% purposes of nesting, up to an `@end #1' command. +% +\def\nestedignore#1{% + \obstexwarn + % We must actually expand the ignored text to look for the @end + % command, so that nested ignore constructs work. Thus, we put the + % text into a \vbox and then do nothing with the result. To minimize + % the change of memory overflow, we follow the approach outlined on + % page 401 of the TeXbook: make the current font be a dummy font. + % + \setbox0 = \vbox\bgroup + % Don't complain about control sequences we have declared \outer. + \ignoresections + % + % Define `@end #1' to end the box, which will in turn undefine the + % @end command again. + \expandafter\def\csname E#1\endcsname{\egroup\ignorespaces}% + % + % We are going to be parsing Texinfo commands. Most cause no + % trouble when they are used incorrectly, but some commands do + % complicated argument parsing or otherwise get confused, so we + % undefine them. + % + % We can't do anything about stray @-signs, unfortunately; + % they'll produce `undefined control sequence' errors. + \ignoremorecommands + % + % Set the current font to be \nullfont, a TeX primitive, and define + % all the font commands to also use \nullfont. We don't use + % dummy.tfm, as suggested in the TeXbook, because not all sites + % might have that installed. Therefore, math mode will still + % produce output, but that should be an extremely small amount of + % stuff compared to the main input. + % + \nullfont + \let\tenrm = \nullfont \let\tenit = \nullfont \let\tensl = \nullfont + \let\tenbf = \nullfont \let\tentt = \nullfont \let\smallcaps = \nullfont + \let\tensf = \nullfont + % Similarly for index fonts (mostly for their use in + % smallexample) + \let\indrm = \nullfont \let\indit = \nullfont \let\indsl = \nullfont + \let\indbf = \nullfont \let\indtt = \nullfont \let\indsc = \nullfont + \let\indsf = \nullfont + % + % Don't complain when characters are missing from the fonts. + \tracinglostchars = 0 + % + % Don't bother to do space factor calculations. + \frenchspacing + % + % Don't report underfull hboxes. + \hbadness = 10000 + % + % Do minimal line-breaking. + \pretolerance = 10000 + % + % Do not execute instructions in @tex + \def\tex{\doignore{tex}} +} + +% @set VAR sets the variable VAR to an empty value. +% @set VAR REST-OF-LINE sets VAR to the value REST-OF-LINE. +% +% Since we want to separate VAR from REST-OF-LINE (which might be +% empty), we can't just use \parsearg; we have to insert a space of our +% own to delimit the rest of the line, and then take it out again if we +% didn't need it. +% +\def\set{\parsearg\setxxx} +\def\setxxx#1{\setyyy#1 \endsetyyy} +\def\setyyy#1 #2\endsetyyy{% + \def\temp{#2}% + \ifx\temp\empty \global\expandafter\let\csname SET#1\endcsname = \empty + \else \setzzz{#1}#2\endsetzzz % Remove the trailing space \setxxx inserted. + \fi +} +% Can't use \xdef to pre-expand #2 and save some time, since \temp or +% \next or other control sequences that we've defined might get us into +% an infinite loop. Consider `@set foo @cite{bar}'. +\def\setzzz#1#2 \endsetzzz{\expandafter\gdef\csname SET#1\endcsname{#2}} + +% @clear VAR clears (i.e., unsets) the variable VAR. +% +\def\clear{\parsearg\clearxxx} +\def\clearxxx#1{\global\expandafter\let\csname SET#1\endcsname=\relax} + +% @value{foo} gets the text saved in variable foo. +% +\def\value#1{\expandafter + \ifx\csname SET#1\endcsname\relax + {\{No value for ``#1''\}} + \else \csname SET#1\endcsname \fi} + +% @ifset VAR ... @end ifset reads the `...' iff VAR has been defined +% with @set. +% +\def\ifset{\parsearg\ifsetxxx} +\def\ifsetxxx #1{% + \expandafter\ifx\csname SET#1\endcsname\relax + \expandafter\ifsetfail + \else + \expandafter\ifsetsucceed + \fi +} +\def\ifsetsucceed{\conditionalsucceed{ifset}} +\def\ifsetfail{\nestedignore{ifset}} +\defineunmatchedend{ifset} + +% @ifclear VAR ... @end ifclear reads the `...' iff VAR has never been +% defined with @set, or has been undefined with @clear. +% +\def\ifclear{\parsearg\ifclearxxx} +\def\ifclearxxx #1{% + \expandafter\ifx\csname SET#1\endcsname\relax + \expandafter\ifclearsucceed + \else + \expandafter\ifclearfail + \fi +} +\def\ifclearsucceed{\conditionalsucceed{ifclear}} +\def\ifclearfail{\nestedignore{ifclear}} +\defineunmatchedend{ifclear} + +% @iftex always succeeds; we read the text following, through @end +% iftex). But `@end iftex' should be valid only after an @iftex. +% +\def\iftex{\conditionalsucceed{iftex}} +\defineunmatchedend{iftex} + +% We can't just want to start a group at @iftex (for example) and end it +% at @end iftex, since then @set commands inside the conditional have no +% effect (they'd get reverted at the end of the group). So we must +% define \Eiftex to redefine itself to be its previous value. (We can't +% just define it to fail again with an ``unmatched end'' error, since +% the @ifset might be nested.) +% +\def\conditionalsucceed#1{% + \edef\temp{% + % Remember the current value of \E#1. + \let\nece{prevE#1} = \nece{E#1}% + % + % At the `@end #1', redefine \E#1 to be its previous value. + \def\nece{E#1}{\let\nece{E#1} = \nece{prevE#1}}% + }% + \temp +} + +% We need to expand lots of \csname's, but we don't want to expand the +% control sequences after we've constructed them. +% +\def\nece#1{\expandafter\noexpand\csname#1\endcsname} + +% @asis just yields its argument. Used with @table, for example. +% +\def\asis#1{#1} + +% @math means output in math mode. +% We don't use $'s directly in the definition of \math because control +% sequences like \math are expanded when the toc file is written. Then, +% we read the toc file back, the $'s will be normal characters (as they +% should be, according to the definition of Texinfo). So we must use a +% control sequence to switch into and out of math mode. +% +% This isn't quite enough for @math to work properly in indices, but it +% seems unlikely it will ever be needed there. +% +\let\implicitmath = $ +\def\math#1{\implicitmath #1\implicitmath} + +% @bullet and @minus need the same treatment as @math, just above. +\def\bullet{\implicitmath\ptexbullet\implicitmath} +\def\minus{\implicitmath-\implicitmath} + +\def\node{\ENVcheck\parsearg\nodezzz} +\def\nodezzz#1{\nodexxx [#1,]} +\def\nodexxx[#1,#2]{\gdef\lastnode{#1}} +\let\nwnode=\node +\let\lastnode=\relax + +\def\donoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\setref{\lastnode}\fi +\global\let\lastnode=\relax} + +\def\unnumbnoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\unnumbsetref{\lastnode}\fi +\global\let\lastnode=\relax} + +\def\appendixnoderef{\ifx\lastnode\relax\else +\expandafter\expandafter\expandafter\appendixsetref{\lastnode}\fi +\global\let\lastnode=\relax} + +\let\refill=\relax + +% @setfilename is done at the beginning of every texinfo file. +% So open here the files we need to have open while reading the input. +% This makes it possible to make a .fmt file for texinfo. +\def\setfilename{% + \readauxfile + \opencontents + \openindices + \fixbackslash % Turn off hack to swallow `\input texinfo'. + \global\let\setfilename=\comment % Ignore extra @setfilename cmds. + \comment % Ignore the actual filename. +} + +\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend} + +\def\inforef #1{\inforefzzz #1,,,,**} +\def\inforefzzz #1,#2,#3,#4**{\putwordSee{} \putwordInfo{} \putwordfile{} \file{\ignorespaces #3{}}, + node \samp{\ignorespaces#1{}}} + +\message{fonts,} + +% Font-change commands. + +% Texinfo supports the sans serif font style, which plain TeX does not. +% So we set up a \sf analogous to plain's \rm, etc. +\newfam\sffam +\def\sf{\fam=\sffam \tensf} +\let\li = \sf % Sometimes we call it \li, not \sf. + +%% Try out Computer Modern fonts at \magstephalf +\let\mainmagstep=\magstephalf + +% Set the font macro #1 to the font named #2, adding on the +% specified font prefix (normally `cm'). +\def\setfont#1#2{\font#1=\fontprefix#2} + +% Use cm as the default font prefix. +% To specify the font prefix, you must define \fontprefix +% before you read in texinfo.tex. +\ifx\fontprefix\undefined +\def\fontprefix{cm} +\fi + +\ifx\bigger\relax +\let\mainmagstep=\magstep1 +\setfont\textrm{r12} +\setfont\texttt{tt12} +\else +\setfont\textrm{r10 scaled \mainmagstep} +\setfont\texttt{tt10 scaled \mainmagstep} +\fi +% Instead of cmb10, you many want to use cmbx10. +% cmbx10 is a prettier font on its own, but cmb10 +% looks better when embedded in a line with cmr10. +\setfont\textbf{b10 scaled \mainmagstep} +\setfont\textit{ti10 scaled \mainmagstep} +\setfont\textsl{sl10 scaled \mainmagstep} +\setfont\textsf{ss10 scaled \mainmagstep} +\setfont\textsc{csc10 scaled \mainmagstep} +\font\texti=cmmi10 scaled \mainmagstep +\font\textsy=cmsy10 scaled \mainmagstep + +% A few fonts for @defun, etc. +\setfont\defbf{bx10 scaled \magstep1} %was 1314 +\setfont\deftt{tt10 scaled \magstep1} +\def\df{\let\tentt=\deftt \let\tenbf = \defbf \bf} + +% Fonts for indices and small examples. +% We actually use the slanted font rather than the italic, +% because texinfo normally uses the slanted fonts for that. +% Do not make many font distinctions in general in the index, since they +% aren't very useful. +\setfont\ninett{tt9} +\setfont\indrm{r9} +\setfont\indit{sl9} +\let\indsl=\indit +\let\indtt=\ninett +\let\indsf=\indrm +\let\indbf=\indrm +\setfont\indsc{csc10 at 9pt} +\font\indi=cmmi9 +\font\indsy=cmsy9 + +% Fonts for headings +\setfont\chaprm{bx12 scaled \magstep2} +\setfont\chapit{ti12 scaled \magstep2} +\setfont\chapsl{sl12 scaled \magstep2} +\setfont\chaptt{tt12 scaled \magstep2} +\setfont\chapsf{ss12 scaled \magstep2} +\let\chapbf=\chaprm +\setfont\chapsc{csc10 scaled\magstep3} +\font\chapi=cmmi12 scaled \magstep2 +\font\chapsy=cmsy10 scaled \magstep3 + +\setfont\secrm{bx12 scaled \magstep1} +\setfont\secit{ti12 scaled \magstep1} +\setfont\secsl{sl12 scaled \magstep1} +\setfont\sectt{tt12 scaled \magstep1} +\setfont\secsf{ss12 scaled \magstep1} +\setfont\secbf{bx12 scaled \magstep1} +\setfont\secsc{csc10 scaled\magstep2} +\font\seci=cmmi12 scaled \magstep1 +\font\secsy=cmsy10 scaled \magstep2 + +% \setfont\ssecrm{bx10 scaled \magstep1} % This size an font looked bad. +% \setfont\ssecit{cmti10 scaled \magstep1} % The letters were too crowded. +% \setfont\ssecsl{sl10 scaled \magstep1} +% \setfont\ssectt{tt10 scaled \magstep1} +% \setfont\ssecsf{ss10 scaled \magstep1} + +%\setfont\ssecrm{b10 scaled 1315} % Note the use of cmb rather than cmbx. +%\setfont\ssecit{ti10 scaled 1315} % Also, the size is a little larger than +%\setfont\ssecsl{sl10 scaled 1315} % being scaled magstep1. +%\setfont\ssectt{tt10 scaled 1315} +%\setfont\ssecsf{ss10 scaled 1315} + +%\let\ssecbf=\ssecrm + +\setfont\ssecrm{bx12 scaled \magstephalf} +\setfont\ssecit{ti12 scaled \magstephalf} +\setfont\ssecsl{sl12 scaled \magstephalf} +\setfont\ssectt{tt12 scaled \magstephalf} +\setfont\ssecsf{ss12 scaled \magstephalf} +\setfont\ssecbf{bx12 scaled \magstephalf} +\setfont\ssecsc{csc10 scaled \magstep1} +\font\sseci=cmmi12 scaled \magstephalf +\font\ssecsy=cmsy10 scaled \magstep1 +% The smallcaps and symbol fonts should actually be scaled \magstep1.5, +% but that is not a standard magnification. + +% Fonts for title page: +\setfont\titlerm{bx12 scaled \magstep3} +\let\authorrm = \secrm + +% In order for the font changes to affect most math symbols and letters, +% we have to define the \textfont of the standard families. Since +% texinfo doesn't allow for producing subscripts and superscripts, we +% don't bother to reset \scriptfont and \scriptscriptfont (which would +% also require loading a lot more fonts). +% +\def\resetmathfonts{% + \textfont0 = \tenrm \textfont1 = \teni \textfont2 = \tensy + \textfont\itfam = \tenit \textfont\slfam = \tensl \textfont\bffam = \tenbf + \textfont\ttfam = \tentt \textfont\sffam = \tensf +} + + +% The font-changing commands redefine the meanings of \tenSTYLE, instead +% of just \STYLE. We do this so that font changes will continue to work +% in math mode, where it is the current \fam that is relevant in most +% cases, not the current. Plain TeX does, for example, +% \def\bf{\fam=\bffam \tenbf} By redefining \tenbf, we obviate the need +% to redefine \bf itself. +\def\textfonts{% + \let\tenrm=\textrm \let\tenit=\textit \let\tensl=\textsl + \let\tenbf=\textbf \let\tentt=\texttt \let\smallcaps=\textsc + \let\tensf=\textsf \let\teni=\texti \let\tensy=\textsy + \resetmathfonts} +\def\chapfonts{% + \let\tenrm=\chaprm \let\tenit=\chapit \let\tensl=\chapsl + \let\tenbf=\chapbf \let\tentt=\chaptt \let\smallcaps=\chapsc + \let\tensf=\chapsf \let\teni=\chapi \let\tensy=\chapsy + \resetmathfonts} +\def\secfonts{% + \let\tenrm=\secrm \let\tenit=\secit \let\tensl=\secsl + \let\tenbf=\secbf \let\tentt=\sectt \let\smallcaps=\secsc + \let\tensf=\secsf \let\teni=\seci \let\tensy=\secsy + \resetmathfonts} +\def\subsecfonts{% + \let\tenrm=\ssecrm \let\tenit=\ssecit \let\tensl=\ssecsl + \let\tenbf=\ssecbf \let\tentt=\ssectt \let\smallcaps=\ssecsc + \let\tensf=\ssecsf \let\teni=\sseci \let\tensy=\ssecsy + \resetmathfonts} +\def\indexfonts{% + \let\tenrm=\indrm \let\tenit=\indit \let\tensl=\indsl + \let\tenbf=\indbf \let\tentt=\indtt \let\smallcaps=\indsc + \let\tensf=\indsf \let\teni=\indi \let\tensy=\indsy + \resetmathfonts} + +% Set up the default fonts, so we can use them for creating boxes. +% +\textfonts + +% Count depth in font-changes, for error checks +\newcount\fontdepth \fontdepth=0 + +% Fonts for short table of contents. +\setfont\shortcontrm{r12} +\setfont\shortcontbf{bx12} +\setfont\shortcontsl{sl12} + +%% Add scribe-like font environments, plus @l for inline lisp (usually sans +%% serif) and @ii for TeX italic + +% \smartitalic{ARG} outputs arg in italics, followed by an italic correction +% unless the following character is such as not to need one. +\def\smartitalicx{\ifx\next,\else\ifx\next-\else\ifx\next.\else\/\fi\fi\fi} +\def\smartitalic#1{{\sl #1}\futurelet\next\smartitalicx} + +\let\i=\smartitalic +\let\var=\smartitalic +\let\dfn=\smartitalic +\let\emph=\smartitalic +\let\cite=\smartitalic + +\def\b#1{{\bf #1}} +\let\strong=\b + +% We can't just use \exhyphenpenalty, because that only has effect at +% the end of a paragraph. Restore normal hyphenation at the end of the +% group within which \nohyphenation is presumably called. +% +\def\nohyphenation{\hyphenchar\font = -1 \aftergroup\restorehyphenation} +\def\restorehyphenation{\hyphenchar\font = `- } + +\def\t#1{% + {\tt \nohyphenation \rawbackslash \frenchspacing #1}% + \null +} +\let\ttfont = \t +%\def\samp #1{`{\tt \rawbackslash \frenchspacing #1}'\null} +\def\samp #1{`\tclose{#1}'\null} +\def\key #1{{\tt \nohyphenation \uppercase{#1}}\null} +\def\ctrl #1{{\tt \rawbackslash \hat}#1} + +\let\file=\samp + +% @code is a modification of @t, +% which makes spaces the same size as normal in the surrounding text. +\def\tclose#1{% + {% + % Change normal interword space to be same as for the current font. + \spaceskip = \fontdimen2\font + % + % Switch to typewriter. + \tt + % + % But `\ ' produces the large typewriter interword space. + \def\ {{\spaceskip = 0pt{} }}% + % + % Turn off hyphenation. + \nohyphenation + % + \rawbackslash + \frenchspacing + #1% + }% + \null +} + +% We *must* turn on hyphenation at `-' and `_' in \code. +% Otherwise, it is too hard to avoid overful hboxes +% in the Emacs manual, the Library manual, etc. + +% Unfortunately, TeX uses one parameter (\hyphenchar) to control +% both hyphenation at - and hyphenation within words. +% We must therefore turn them both off (\tclose does that) +% and arrange explicitly to hyphenate an a dash. +% -- rms. +{ +\catcode`\-=\active +\catcode`\_=\active +\global\def\code{\begingroup \catcode`\-=\active \let-\codedash \catcode`\_=\active \let_\codeunder \codex} +% The following is used by \doprintindex to insure that long function names +% wrap around. It is necessary for - and _ to be active before the index is +% read from the file, as \entry parses the arguments long before \code is +% ever called. -- mycroft +\global\def\indexbreaks{\catcode`\-=\active \let-\realdash \catcode`\_=\active \let_\realunder} +} +\def\realdash{-} +\def\realunder{_} +\def\codedash{-\discretionary{}{}{}} +\def\codeunder{\normalunderscore\discretionary{}{}{}} +\def\codex #1{\tclose{#1}\endgroup} + +%\let\exp=\tclose %Was temporary + +% @kbd is like @code, except that if the argument is just one @key command, +% then @kbd has no effect. + +\def\xkey{\key} +\def\kbdfoo#1#2#3\par{\def\one{#1}\def\three{#3}\def\threex{??}% +\ifx\one\xkey\ifx\threex\three \key{#2}% +\else\tclose{\look}\fi +\else\tclose{\look}\fi} + +% Typeset a dimension, e.g., `in' or `pt'. The only reason for the +% argument is to make the input look right: @dmn{pt} instead of +% @dmn{}pt. +% +\def\dmn#1{\thinspace #1} + +\def\kbd#1{\def\look{#1}\expandafter\kbdfoo\look??\par} + +\def\l#1{{\li #1}\null} % + +\def\r#1{{\rm #1}} % roman font +% Use of \lowercase was suggested. +\def\sc#1{{\smallcaps#1}} % smallcaps font +\def\ii#1{{\it #1}} % italic font + +\message{page headings,} + +\newskip\titlepagetopglue \titlepagetopglue = 1.5in +\newskip\titlepagebottomglue \titlepagebottomglue = 2pc + +% First the title page. Must do @settitle before @titlepage. +\def\titlefont#1{{\titlerm #1}} + +\newif\ifseenauthor +\newif\iffinishedtitlepage + +\def\shorttitlepage{\parsearg\shorttitlepagezzz} +\def\shorttitlepagezzz #1{\begingroup\hbox{}\vskip 1.5in \chaprm \centerline{#1}% + \endgroup\page\hbox{}\page} + +\def\titlepage{\begingroup \parindent=0pt \textfonts + \let\subtitlerm=\tenrm +% I deinstalled the following change because \cmr12 is undefined. +% This change was not in the ChangeLog anyway. --rms. +% \let\subtitlerm=\cmr12 + \def\subtitlefont{\subtitlerm \normalbaselineskip = 13pt \normalbaselines}% + % + \def\authorfont{\authorrm \normalbaselineskip = 16pt \normalbaselines}% + % + % Leave some space at the very top of the page. + \vglue\titlepagetopglue + % + % Now you can print the title using @title. + \def\title{\parsearg\titlezzz}% + \def\titlezzz##1{\leftline{\titlefont{##1}} + % print a rule at the page bottom also. + \finishedtitlepagefalse + \vskip4pt \hrule height 4pt width \hsize \vskip4pt}% + % No rule at page bottom unless we print one at the top with @title. + \finishedtitlepagetrue + % + % Now you can put text using @subtitle. + \def\subtitle{\parsearg\subtitlezzz}% + \def\subtitlezzz##1{{\subtitlefont \rightline{##1}}}% + % + % @author should come last, but may come many times. + \def\author{\parsearg\authorzzz}% + \def\authorzzz##1{\ifseenauthor\else\vskip 0pt plus 1filll\seenauthortrue\fi + {\authorfont \leftline{##1}}}% + % + % Most title ``pages'' are actually two pages long, with space + % at the top of the second. We don't want the ragged left on the second. + \let\oldpage = \page + \def\page{% + \iffinishedtitlepage\else + \finishtitlepage + \fi + \oldpage + \let\page = \oldpage + \hbox{}}% +% \def\page{\oldpage \hbox{}} +} + +\def\Etitlepage{% + \iffinishedtitlepage\else + \finishtitlepage + \fi + % It is important to do the page break before ending the group, + % because the headline and footline are only empty inside the group. + % If we use the new definition of \page, we always get a blank page + % after the title page, which we certainly don't want. + \oldpage + \endgroup + \HEADINGSon +} + +\def\finishtitlepage{% + \vskip4pt \hrule height 2pt width \hsize + \vskip\titlepagebottomglue + \finishedtitlepagetrue +} + +%%% Set up page headings and footings. + +\let\thispage=\folio + +\newtoks \evenheadline % Token sequence for heading line of even pages +\newtoks \oddheadline % Token sequence for heading line of odd pages +\newtoks \evenfootline % Token sequence for footing line of even pages +\newtoks \oddfootline % Token sequence for footing line of odd pages + +% Now make Tex use those variables +\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline + \else \the\evenheadline \fi}} +\footline={{\textfonts\rm \ifodd\pageno \the\oddfootline + \else \the\evenfootline \fi}\HEADINGShook} +\let\HEADINGShook=\relax + +% Commands to set those variables. +% For example, this is what @headings on does +% @evenheading @thistitle|@thispage|@thischapter +% @oddheading @thischapter|@thispage|@thistitle +% @evenfooting @thisfile|| +% @oddfooting ||@thisfile + +\def\evenheading{\parsearg\evenheadingxxx} +\def\oddheading{\parsearg\oddheadingxxx} +\def\everyheading{\parsearg\everyheadingxxx} + +\def\evenfooting{\parsearg\evenfootingxxx} +\def\oddfooting{\parsearg\oddfootingxxx} +\def\everyfooting{\parsearg\everyfootingxxx} + +{\catcode`\@=0 % + +\gdef\evenheadingxxx #1{\evenheadingyyy #1@|@|@|@|\finish} +\gdef\evenheadingyyy #1@|#2@|#3@|#4\finish{% +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\oddheadingxxx #1{\oddheadingyyy #1@|@|@|@|\finish} +\gdef\oddheadingyyy #1@|#2@|#3@|#4\finish{% +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\everyheadingxxx #1{\everyheadingyyy #1@|@|@|@|\finish} +\gdef\everyheadingyyy #1@|#2@|#3@|#4\finish{% +\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}} +\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\evenfootingxxx #1{\evenfootingyyy #1@|@|@|@|\finish} +\gdef\evenfootingyyy #1@|#2@|#3@|#4\finish{% +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\oddfootingxxx #1{\oddfootingyyy #1@|@|@|@|\finish} +\gdef\oddfootingyyy #1@|#2@|#3@|#4\finish{% +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + +\gdef\everyfootingxxx #1{\everyfootingyyy #1@|@|@|@|\finish} +\gdef\everyfootingyyy #1@|#2@|#3@|#4\finish{% +\global\evenfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}} +\global\oddfootline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} +% +}% unbind the catcode of @. + +% @headings double turns headings on for double-sided printing. +% @headings single turns headings on for single-sided printing. +% @headings off turns them off. +% @headings on same as @headings double, retained for compatibility. +% @headings after turns on double-sided headings after this page. +% @headings doubleafter turns on double-sided headings after this page. +% @headings singleafter turns on single-sided headings after this page. +% By default, they are off. + +\def\headings #1 {\csname HEADINGS#1\endcsname} + +\def\HEADINGSoff{ +\global\evenheadline={\hfil} \global\evenfootline={\hfil} +\global\oddheadline={\hfil} \global\oddfootline={\hfil}} +\HEADINGSoff +% When we turn headings on, set the page number to 1. +% For double-sided printing, put current file name in lower left corner, +% chapter name on inside top of right hand pages, document +% title on inside top of left hand pages, and page numbers on outside top +% edge of all pages. +\def\HEADINGSdouble{ +%\pagealignmacro +\global\pageno=1 +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\folio\hfil\thistitle}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} +% For single-sided printing, chapter title goes across top left of page, +% page number on top right. +\def\HEADINGSsingle{ +%\pagealignmacro +\global\pageno=1 +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} +\def\HEADINGSon{\HEADINGSdouble} + +\def\HEADINGSafter{\let\HEADINGShook=\HEADINGSdoublex} +\let\HEADINGSdoubleafter=\HEADINGSafter +\def\HEADINGSdoublex{% +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\folio\hfil\thistitle}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} + +\def\HEADINGSsingleafter{\let\HEADINGShook=\HEADINGSsinglex} +\def\HEADINGSsinglex{% +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +} + +% Subroutines used in generating headings +% Produces Day Month Year style of output. +\def\today{\number\day\space +\ifcase\month\or +January\or February\or March\or April\or May\or June\or +July\or August\or September\or October\or November\or December\fi +\space\number\year} + +% Use this if you want the Month Day, Year style of output. +%\def\today{\ifcase\month\or +%January\or February\or March\or April\or May\or June\or +%July\or August\or September\or October\or November\or December\fi +%\space\number\day, \number\year} + +% @settitle line... specifies the title of the document, for headings +% It generates no output of its own + +\def\thistitle{No Title} +\def\settitle{\parsearg\settitlezzz} +\def\settitlezzz #1{\gdef\thistitle{#1}} + +\message{tables,} + +% @tabs -- simple alignment + +% These don't work. For one thing, \+ is defined as outer. +% So these macros cannot even be defined. + +%\def\tabs{\parsearg\tabszzz} +%\def\tabszzz #1{\settabs\+#1\cr} +%\def\tabline{\parsearg\tablinezzz} +%\def\tablinezzz #1{\+#1\cr} +%\def\&{&} + +% Tables -- @table, @ftable, @vtable, @item(x), @kitem(x), @xitem(x). + +% default indentation of table text +\newdimen\tableindent \tableindent=.8in +% default indentation of @itemize and @enumerate text +\newdimen\itemindent \itemindent=.3in +% margin between end of table item and start of table text. +\newdimen\itemmargin \itemmargin=.1in + +% used internally for \itemindent minus \itemmargin +\newdimen\itemmax + +% Note @table, @vtable, and @vtable define @item, @itemx, etc., with +% these defs. +% They also define \itemindex +% to index the item name in whatever manner is desired (perhaps none). + +\newif\ifitemxneedsnegativevskip + +\def\itemxpar{\par\ifitemxneedsnegativevskip\vskip-\parskip\nobreak\fi} + +\def\internalBitem{\smallbreak \parsearg\itemzzz} +\def\internalBitemx{\itemxpar \parsearg\itemzzz} + +\def\internalBxitem "#1"{\def\xitemsubtopix{#1} \smallbreak \parsearg\xitemzzz} +\def\internalBxitemx "#1"{\def\xitemsubtopix{#1} \itemxpar \parsearg\xitemzzz} + +\def\internalBkitem{\smallbreak \parsearg\kitemzzz} +\def\internalBkitemx{\itemxpar \parsearg\kitemzzz} + +\def\kitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \lastfunction}}% + \itemzzz {#1}} + +\def\xitemzzz #1{\dosubind {kw}{\code{#1}}{for {\bf \xitemsubtopic}}% + \itemzzz {#1}} + +\def\itemzzz #1{\begingroup % + \advance\hsize by -\rightskip + \advance\hsize by -\tableindent + \setbox0=\hbox{\itemfont{#1}}% + \itemindex{#1}% + \nobreak % This prevents a break before @itemx. + % + % Be sure we are not still in the middle of a paragraph. + %{\parskip = 0in + %\par + %}% + % + % If the item text does not fit in the space we have, put it on a line + % by itself, and do not allow a page break either before or after that + % line. We do not start a paragraph here because then if the next + % command is, e.g., @kindex, the whatsit would get put into the + % horizontal list on a line by itself, resulting in extra blank space. + \ifdim \wd0>\itemmax + % + % Make this a paragraph so we get the \parskip glue and wrapping, + % but leave it ragged-right. + \begingroup + \advance\leftskip by-\tableindent + \advance\hsize by\tableindent + \advance\rightskip by0pt plus1fil + \leavevmode\unhbox0\par + \endgroup + % + % We're going to be starting a paragraph, but we don't want the + % \parskip glue -- logically it's part of the @item we just started. + \nobreak \vskip-\parskip + % + % Stop a page break at the \parskip glue coming up. Unfortunately + % we can't prevent a possible page break at the following + % \baselineskip glue. + \nobreak + \endgroup + \itemxneedsnegativevskipfalse + \else + % The item text fits into the space. Start a paragraph, so that the + % following text (if any) will end up on the same line. Since that + % text will be indented by \tableindent, we make the item text be in + % a zero-width box. + \noindent + \rlap{\hskip -\tableindent\box0}\ignorespaces% + \endgroup% + \itemxneedsnegativevskiptrue% + \fi +} + +\def\item{\errmessage{@item while not in a table}} +\def\itemx{\errmessage{@itemx while not in a table}} +\def\kitem{\errmessage{@kitem while not in a table}} +\def\kitemx{\errmessage{@kitemx while not in a table}} +\def\xitem{\errmessage{@xitem while not in a table}} +\def\xitemx{\errmessage{@xitemx while not in a table}} + +%% Contains a kludge to get @end[description] to work +\def\description{\tablez{\dontindex}{1}{}{}{}{}} + +\def\table{\begingroup\inENV\obeylines\obeyspaces\tablex} +{\obeylines\obeyspaces% +\gdef\tablex #1^^M{% +\tabley\dontindex#1 \endtabley}} + +\def\ftable{\begingroup\inENV\obeylines\obeyspaces\ftablex} +{\obeylines\obeyspaces% +\gdef\ftablex #1^^M{% +\tabley\fnitemindex#1 \endtabley +\def\Eftable{\endgraf\afterenvbreak\endgroup}% +\let\Etable=\relax}} + +\def\vtable{\begingroup\inENV\obeylines\obeyspaces\vtablex} +{\obeylines\obeyspaces% +\gdef\vtablex #1^^M{% +\tabley\vritemindex#1 \endtabley +\def\Evtable{\endgraf\afterenvbreak\endgroup}% +\let\Etable=\relax}} + +\def\dontindex #1{} +\def\fnitemindex #1{\doind {fn}{\code{#1}}}% +\def\vritemindex #1{\doind {vr}{\code{#1}}}% + +{\obeyspaces % +\gdef\tabley#1#2 #3 #4 #5 #6 #7\endtabley{\endgroup% +\tablez{#1}{#2}{#3}{#4}{#5}{#6}}} + +\def\tablez #1#2#3#4#5#6{% +\aboveenvbreak % +\begingroup % +\def\Edescription{\Etable}% Neccessary kludge. +\let\itemindex=#1% +\ifnum 0#3>0 \advance \leftskip by #3\mil \fi % +\ifnum 0#4>0 \tableindent=#4\mil \fi % +\ifnum 0#5>0 \advance \rightskip by #5\mil \fi % +\def\itemfont{#2}% +\itemmax=\tableindent % +\advance \itemmax by -\itemmargin % +\advance \leftskip by \tableindent % +\exdentamount=\tableindent +\parindent = 0pt +\parskip = \smallskipamount +\ifdim \parskip=0pt \parskip=2pt \fi% +\def\Etable{\endgraf\afterenvbreak\endgroup}% +\let\item = \internalBitem % +\let\itemx = \internalBitemx % +\let\kitem = \internalBkitem % +\let\kitemx = \internalBkitemx % +\let\xitem = \internalBxitem % +\let\xitemx = \internalBxitemx % +} + +% This is the counter used by @enumerate, which is really @itemize + +\newcount \itemno + +\def\itemize{\parsearg\itemizezzz} + +\def\itemizezzz #1{% + \begingroup % ended by the @end itemsize + \itemizey {#1}{\Eitemize} +} + +\def\itemizey #1#2{% +\aboveenvbreak % +\itemmax=\itemindent % +\advance \itemmax by -\itemmargin % +\advance \leftskip by \itemindent % +\exdentamount=\itemindent +\parindent = 0pt % +\parskip = \smallskipamount % +\ifdim \parskip=0pt \parskip=2pt \fi% +\def#2{\endgraf\afterenvbreak\endgroup}% +\def\itemcontents{#1}% +\let\item=\itemizeitem} + +% Set sfcode to normal for the chars that usually have another value. +% These are `.?!:;,' +\def\frenchspacing{\sfcode46=1000 \sfcode63=1000 \sfcode33=1000 + \sfcode58=1000 \sfcode59=1000 \sfcode44=1000 } + +% \splitoff TOKENS\endmark defines \first to be the first token in +% TOKENS, and \rest to be the remainder. +% +\def\splitoff#1#2\endmark{\def\first{#1}\def\rest{#2}}% + +% Allow an optional argument of an uppercase letter, lowercase letter, +% or number, to specify the first label in the enumerated list. No +% argument is the same as `1'. +% +\def\enumerate{\parsearg\enumeratezzz} +\def\enumeratezzz #1{\enumeratey #1 \endenumeratey} +\def\enumeratey #1 #2\endenumeratey{% + \begingroup % ended by the @end enumerate + % + % If we were given no argument, pretend we were given `1'. + \def\thearg{#1}% + \ifx\thearg\empty \def\thearg{1}\fi + % + % Detect if the argument is a single token. If so, it might be a + % letter. Otherwise, the only valid thing it can be is a number. + % (We will always have one token, because of the test we just made. + % This is a good thing, since \splitoff doesn't work given nothing at + % all -- the first parameter is undelimited.) + \expandafter\splitoff\thearg\endmark + \ifx\rest\empty + % Only one token in the argument. It could still be anything. + % A ``lowercase letter'' is one whose \lccode is nonzero. + % An ``uppercase letter'' is one whose \lccode is both nonzero, and + % not equal to itself. + % Otherwise, we assume it's a number. + % + % We need the \relax at the end of the \ifnum lines to stop TeX from + % continuing to look for a . + % + \ifnum\lccode\expandafter`\thearg=0\relax + \numericenumerate % a number (we hope) + \else + % It's a letter. + \ifnum\lccode\expandafter`\thearg=\expandafter`\thearg\relax + \lowercaseenumerate % lowercase letter + \else + \uppercaseenumerate % uppercase letter + \fi + \fi + \else + % Multiple tokens in the argument. We hope it's a number. + \numericenumerate + \fi +} + +% An @enumerate whose labels are integers. The starting integer is +% given in \thearg. +% +\def\numericenumerate{% + \itemno = \thearg + \startenumeration{\the\itemno}% +} + +% The starting (lowercase) letter is in \thearg. +\def\lowercaseenumerate{% + \itemno = \expandafter`\thearg + \startenumeration{% + % Be sure we're not beyond the end of the alphabet. + \ifnum\itemno=0 + \errmessage{No more lowercase letters in @enumerate; get a bigger + alphabet}% + \fi + \char\lccode\itemno + }% +} + +% The starting (uppercase) letter is in \thearg. +\def\uppercaseenumerate{% + \itemno = \expandafter`\thearg + \startenumeration{% + % Be sure we're not beyond the end of the alphabet. + \ifnum\itemno=0 + \errmessage{No more uppercase letters in @enumerate; get a bigger + alphabet} + \fi + \char\uccode\itemno + }% +} + +% Call itemizey, adding a period to the first argument and supplying the +% common last two arguments. Also subtract one from the initial value in +% \itemno, since @item increments \itemno. +% +\def\startenumeration#1{% + \advance\itemno by -1 + \itemizey{#1.}\Eenumerate\flushcr +} + +% @alphaenumerate and @capsenumerate are abbreviations for giving an arg +% to @enumerate. +% +\def\alphaenumerate{\enumerate{a}} +\def\capsenumerate{\enumerate{A}} +\def\Ealphaenumerate{\Eenumerate} +\def\Ecapsenumerate{\Eenumerate} + +% Definition of @item while inside @itemize. + +\def\itemizeitem{% +\advance\itemno by 1 +{\let\par=\endgraf \smallbreak}% +\ifhmode \errmessage{\in hmode at itemizeitem}\fi +{\parskip=0in \hskip 0pt +\hbox to 0pt{\hss \itemcontents\hskip \itemmargin}% +\vadjust{\penalty 1200}}% +\flushcr} + +% @multitable macros +% Amy Hendrickson, 8/18/94 +% +% @multitable ... @endmultitable will make as many columns as desired. +% Contents of each column will wrap at width given in preamble. Width +% can be specified either with sample text given in a template line, +% or in percent of \hsize, the current width of text on page. + +% Table can continue over pages but will only break between lines. + +% To make preamble: +% +% Either define widths of columns in terms of percent of \hsize: +% @multitable @percentofhsize .2 .3 .5 +% @item ... +% +% Numbers following @percentofhsize are the percent of the total +% current hsize to be used for each column. You may use as many +% columns as desired. + +% Or use a template: +% @multitable {Column 1 template} {Column 2 template} {Column 3 template} +% @item ... +% using the widest term desired in each column. + + +% Each new table line starts with @item, each subsequent new column +% starts with @tab. Empty columns may be produced by supplying @tab's +% with nothing between them for as many times as empty columns are needed, +% ie, @tab@tab@tab will produce two empty columns. + +% @item, @tab, @multicolumn or @endmulticolumn do not need to be on their +% own lines, but it will not hurt if they are. + +% Sample multitable: + +% @multitable {Column 1 template} {Column 2 template} {Column 3 template} +% @item first col stuff @tab second col stuff @tab third col +% @item +% first col stuff +% @tab +% second col stuff +% @tab +% third col +% @item first col stuff @tab second col stuff +% @tab Many paragraphs of text may be used in any column. +% +% They will wrap at the width determined by the template. +% @item@tab@tab This will be in third column. +% @endmultitable + +% Default dimensions may be reset by user. +% @intableparskip will set vertical space between paragraphs in table. +% @intableparindent will set paragraph indent in table. +% @spacebetweencols will set horizontal space to be left between columns. +% @spacebetweenlines will set vertical space to be left between lines. + +%%%% +% Dimensions + +\newdimen\intableparskip +\newdimen\intableparindent +\newdimen\spacebetweencols +\newdimen\spacebetweenlines +\intableparskip=0pt +\intableparindent=6pt +\spacebetweencols=12pt +\spacebetweenlines=12pt + +%%%% +% Macros used to set up halign preamble: +\let\endsetuptable\relax +\def\xendsetuptable{\endsetuptable} +\let\percentofhsize\relax +\def\xpercentofhsize{\percentofhsize} +\newif\ifsetpercent + +\newcount\colcount +\def\setuptable#1{\def\firstarg{#1}% +\ifx\firstarg\xendsetuptable\let\go\relax% +\else + \ifx\firstarg\xpercentofhsize\global\setpercenttrue% + \else + \ifsetpercent + \if#1.\else% + \global\advance\colcount by1 % + \expandafter\xdef\csname col\the\colcount\endcsname{.#1\hsize}% + \fi + \else + \global\advance\colcount by1 + \setbox0=\hbox{#1}% + \expandafter\xdef\csname col\the\colcount\endcsname{\the\wd0}% + \fi% + \fi% + \let\go\setuptable% +\fi\go} +%%%% +% multitable syntax +\def\tab{&} + +%%%% +% @multitable ... @endmultitable definitions: + +\def\multitable#1\item{\bgroup +\let\item\cr +\tolerance=9500 +\hbadness=9500 +\parskip=\intableparskip +\parindent=\intableparindent +\overfullrule=0pt +\global\colcount=0\relax% +\def\Emultitable{\global\setpercentfalse\global\everycr{}\cr\egroup\egroup}% + % To parse everything between @multitable and @item : +\def\one{#1}\expandafter\setuptable\one\endsetuptable + % Need to reset this to 0 after \setuptable. +\global\colcount=0\relax% + % + % This preamble sets up a generic column definition, which will + % be used as many times as user calls for columns. + % \vtop will set a single line and will also let text wrap and + % continue for many paragraphs if desired. +\halign\bgroup&\global\advance\colcount by 1\relax% +\vtop{\hsize=\expandafter\csname col\the\colcount\endcsname + % In order to keep entries from bumping into each other + % we will add a \leftskip of \spacebetweencols to all columns after + % the first one. + % If a template has been used, we will add \spacebetweencols + % to the width of each template entry. + % If user has set preamble in terms of percent of \hsize + % we will use that dimension as the width of the column, and + % the \leftskip will keep entries from bumping into each other. + % Table will start at left margin and final column will justify at + % right margin. +\ifnum\colcount=1 +\else + \ifsetpercent + \else + % If user has set preamble in terms of percent of \hsize + % we will advance \hsize by \spacebetweencols + \advance\hsize by \spacebetweencols + \fi + % In either case we will make \leftskip=\spacebetweencols: +\leftskip=\spacebetweencols +\fi +\noindent##}\cr% + % \everycr will reset column counter, \colcount, at the end of + % each line. Every column entry will cause \colcount to advance by one. + % The table preamble + % looks at the current \colcount to find the correct column width. +\global\everycr{\noalign{\nointerlineskip\vskip\spacebetweenlines +\filbreak%% keeps underfull box messages off when table breaks over pages. +\global\colcount=0\relax}}} + +\message{indexing,} +% Index generation facilities + +% Define \newwrite to be identical to plain tex's \newwrite +% except not \outer, so it can be used within \newindex. +{\catcode`\@=11 +\gdef\newwrite{\alloc@7\write\chardef\sixt@@n}} + +% \newindex {foo} defines an index named foo. +% It automatically defines \fooindex such that +% \fooindex ...rest of line... puts an entry in the index foo. +% It also defines \fooindfile to be the number of the output channel for +% the file that accumulates this index. The file's extension is foo. +% The name of an index should be no more than 2 characters long +% for the sake of vms. + +\def\newindex #1{ +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file +\openout \csname#1indfile\endcsname \jobname.#1 % Open the file +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\doindex {#1}} +} + +% @defindex foo == \newindex{foo} + +\def\defindex{\parsearg\newindex} + +% Define @defcodeindex, like @defindex except put all entries in @code. + +\def\newcodeindex #1{ +\expandafter\newwrite \csname#1indfile\endcsname% Define number for output file +\openout \csname#1indfile\endcsname \jobname.#1 % Open the file +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\docodeindex {#1}} +} + +\def\defcodeindex{\parsearg\newcodeindex} + +% @synindex foo bar makes index foo feed into index bar. +% Do this instead of @defindex foo if you don't want it as a separate index. +\def\synindex #1 #2 {% +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname +\expandafter\let\csname#1indfile\endcsname=\synindexfoo +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\doindex {#2}}% +} + +% @syncodeindex foo bar similar, but put all entries made for index foo +% inside @code. +\def\syncodeindex #1 #2 {% +\expandafter\let\expandafter\synindexfoo\expandafter=\csname#2indfile\endcsname +\expandafter\let\csname#1indfile\endcsname=\synindexfoo +\expandafter\xdef\csname#1index\endcsname{% % Define \xxxindex +\noexpand\docodeindex {#2}}% +} + +% Define \doindex, the driver for all \fooindex macros. +% Argument #1 is generated by the calling \fooindex macro, +% and it is "foo", the name of the index. + +% \doindex just uses \parsearg; it calls \doind for the actual work. +% This is because \doind is more useful to call from other macros. + +% There is also \dosubind {index}{topic}{subtopic} +% which makes an entry in a two-level index such as the operation index. + +\def\doindex#1{\edef\indexname{#1}\parsearg\singleindexer} +\def\singleindexer #1{\doind{\indexname}{#1}} + +% like the previous two, but they put @code around the argument. +\def\docodeindex#1{\edef\indexname{#1}\parsearg\singlecodeindexer} +\def\singlecodeindexer #1{\doind{\indexname}{\code{#1}}} + +\def\indexdummies{% +% Take care of the plain tex accent commands. +\def\"{\realbackslash "}% +\def\`{\realbackslash `}% +\def\'{\realbackslash '}% +\def\^{\realbackslash ^}% +\def\~{\realbackslash ~}% +\def\={\realbackslash =}% +\def\b{\realbackslash b}% +\def\c{\realbackslash c}% +\def\d{\realbackslash d}% +\def\u{\realbackslash u}% +\def\v{\realbackslash v}% +\def\H{\realbackslash H}% +% Take care of the plain tex special European modified letters. +\def\oe{\realbackslash oe}% +\def\ae{\realbackslash ae}% +\def\aa{\realbackslash aa}% +\def\OE{\realbackslash OE}% +\def\AE{\realbackslash AE}% +\def\AA{\realbackslash AA}% +\def\o{\realbackslash o}% +\def\O{\realbackslash O}% +\def\l{\realbackslash l}% +\def\L{\realbackslash L}% +\def\ss{\realbackslash ss}% +% Take care of texinfo commands likely to appear in an index entry. +\def\_{{\realbackslash _}}% +\def\w{\realbackslash w }% +\def\bf{\realbackslash bf }% +\def\rm{\realbackslash rm }% +\def\sl{\realbackslash sl }% +\def\sf{\realbackslash sf}% +\def\tt{\realbackslash tt}% +\def\gtr{\realbackslash gtr}% +\def\less{\realbackslash less}% +\def\hat{\realbackslash hat}% +\def\char{\realbackslash char}% +\def\TeX{\realbackslash TeX}% +\def\dots{\realbackslash dots }% +\def\copyright{\realbackslash copyright }% +\def\tclose##1{\realbackslash tclose {##1}}% +\def\code##1{\realbackslash code {##1}}% +\def\samp##1{\realbackslash samp {##1}}% +\def\t##1{\realbackslash r {##1}}% +\def\r##1{\realbackslash r {##1}}% +\def\i##1{\realbackslash i {##1}}% +\def\b##1{\realbackslash b {##1}}% +\def\cite##1{\realbackslash cite {##1}}% +\def\key##1{\realbackslash key {##1}}% +\def\file##1{\realbackslash file {##1}}% +\def\var##1{\realbackslash var {##1}}% +\def\kbd##1{\realbackslash kbd {##1}}% +\def\dfn##1{\realbackslash dfn {##1}}% +\def\emph##1{\realbackslash emph {##1}}% +} + +% \indexnofonts no-ops all font-change commands. +% This is used when outputting the strings to sort the index by. +\def\indexdummyfont#1{#1} +\def\indexdummytex{TeX} +\def\indexdummydots{...} + +\def\indexnofonts{% +% Just ignore accents. +\let\"=\indexdummyfont +\let\`=\indexdummyfont +\let\'=\indexdummyfont +\let\^=\indexdummyfont +\let\~=\indexdummyfont +\let\==\indexdummyfont +\let\b=\indexdummyfont +\let\c=\indexdummyfont +\let\d=\indexdummyfont +\let\u=\indexdummyfont +\let\v=\indexdummyfont +\let\H=\indexdummyfont +% Take care of the plain tex special European modified letters. +\def\oe{oe}% +\def\ae{ae}% +\def\aa{aa}% +\def\OE{OE}% +\def\AE{AE}% +\def\AA{AA}% +\def\o{o}% +\def\O{O}% +\def\l{l}% +\def\L{L}% +\def\ss{ss}% +\let\w=\indexdummyfont +\let\t=\indexdummyfont +\let\r=\indexdummyfont +\let\i=\indexdummyfont +\let\b=\indexdummyfont +\let\emph=\indexdummyfont +\let\strong=\indexdummyfont +\let\cite=\indexdummyfont +\let\sc=\indexdummyfont +%Don't no-op \tt, since it isn't a user-level command +% and is used in the definitions of the active chars like <, >, |... +%\let\tt=\indexdummyfont +\let\tclose=\indexdummyfont +\let\code=\indexdummyfont +\let\file=\indexdummyfont +\let\samp=\indexdummyfont +\let\kbd=\indexdummyfont +\let\key=\indexdummyfont +\let\var=\indexdummyfont +\let\TeX=\indexdummytex +\let\dots=\indexdummydots +} + +% To define \realbackslash, we must make \ not be an escape. +% We must first make another character (@) an escape +% so we do not become unable to do a definition. + +{\catcode`\@=0 \catcode`\\=\other +@gdef@realbackslash{\}} + +\let\indexbackslash=0 %overridden during \printindex. + +\let\SETmarginindex=\relax %initialize! +% workhorse for all \fooindexes +% #1 is name of index, #2 is stuff to put there +\def\doind #1#2{% +% Put the index entry in the margin if desired. +\ifx\SETmarginindex\relax\else% +\insert\margin{\hbox{\vrule height8pt depth3pt width0pt #2}}% +\fi% +{\count10=\lastpenalty % +{\indexdummies % Must do this here, since \bf, etc expand at this stage +\escapechar=`\\% +{\let\folio=0% Expand all macros now EXCEPT \folio +\def\rawbackslashxx{\indexbackslash}% \indexbackslash isn't defined now +% so it will be output as is; and it will print as backslash in the indx. +% +% Now process the index-string once, with all font commands turned off, +% to get the string to sort the index by. +{\indexnofonts +\xdef\temp1{#2}% +}% +% Now produce the complete index entry. We process the index-string again, +% this time with font commands expanded, to get what to print in the index. +\edef\temp{% +\write \csname#1indfile\endcsname{% +\realbackslash entry {\temp1}{\folio}{#2}}}% +\temp }% +}\penalty\count10}} + +\def\dosubind #1#2#3{% +{\count10=\lastpenalty % +{\indexdummies % Must do this here, since \bf, etc expand at this stage +\escapechar=`\\% +{\let\folio=0% +\def\rawbackslashxx{\indexbackslash}% +% +% Now process the index-string once, with all font commands turned off, +% to get the string to sort the index by. +{\indexnofonts +\xdef\temp1{#2 #3}% +}% +% Now produce the complete index entry. We process the index-string again, +% this time with font commands expanded, to get what to print in the index. +\edef\temp{% +\write \csname#1indfile\endcsname{% +\realbackslash entry {\temp1}{\folio}{#2}{#3}}}% +\temp }% +}\penalty\count10}} + +% The index entry written in the file actually looks like +% \entry {sortstring}{page}{topic} +% or +% \entry {sortstring}{page}{topic}{subtopic} +% The texindex program reads in these files and writes files +% containing these kinds of lines: +% \initial {c} +% before the first topic whose initial is c +% \entry {topic}{pagelist} +% for a topic that is used without subtopics +% \primary {topic} +% for the beginning of a topic that is used with subtopics +% \secondary {subtopic}{pagelist} +% for each subtopic. + +% Define the user-accessible indexing commands +% @findex, @vindex, @kindex, @cindex. + +\def\findex {\fnindex} +\def\kindex {\kyindex} +\def\cindex {\cpindex} +\def\vindex {\vrindex} +\def\tindex {\tpindex} +\def\pindex {\pgindex} + +\def\cindexsub {\begingroup\obeylines\cindexsub} +{\obeylines % +\gdef\cindexsub "#1" #2^^M{\endgroup % +\dosubind{cp}{#2}{#1}}} + +% Define the macros used in formatting output of the sorted index material. + +% This is what you call to cause a particular index to get printed. +% Write +% @unnumbered Function Index +% @printindex fn + +\def\printindex{\parsearg\doprintindex} + +\def\doprintindex#1{% + \tex + \dobreak \chapheadingskip {10000} + \catcode`\%=\other\catcode`\&=\other\catcode`\#=\other + \catcode`\$=\other + \catcode`\~=\other + \indexbreaks + % + % The following don't help, since the chars were translated + % when the raw index was written, and their fonts were discarded + % due to \indexnofonts. + %\catcode`\"=\active + %\catcode`\^=\active + %\catcode`\_=\active + %\catcode`\|=\active + %\catcode`\<=\active + %\catcode`\>=\active + % % + \def\indexbackslash{\rawbackslashxx} + \indexfonts\rm \tolerance=9500 \advance\baselineskip -1pt + \begindoublecolumns + % + % See if the index file exists and is nonempty. + \openin 1 \jobname.#1s + \ifeof 1 + % \enddoublecolumns gets confused if there is no text in the index, + % and it loses the chapter title and the aux file entries for the + % index. The easiest way to prevent this problem is to make sure + % there is some text. + (Index is nonexistent) + \else + % + % If the index file exists but is empty, then \openin leaves \ifeof + % false. We have to make TeX try to read something from the file, so + % it can discover if there is anything in it. + \read 1 to \temp + \ifeof 1 + (Index is empty) + \else + \input \jobname.#1s + \fi + \fi + \closein 1 + \enddoublecolumns + \Etex +} + +% These macros are used by the sorted index file itself. +% Change them to control the appearance of the index. + +% Same as \bigskipamount except no shrink. +% \balancecolumns gets confused if there is any shrink. +\newskip\initialskipamount \initialskipamount 12pt plus4pt + +\def\initial #1{% +{\let\tentt=\sectt \let\tt=\sectt \let\sf=\sectt +\ifdim\lastskip<\initialskipamount +\removelastskip \penalty-200 \vskip \initialskipamount\fi +\line{\secbf#1\hfill}\kern 2pt\penalty10000}} + +% This typesets a paragraph consisting of #1, dot leaders, and then #2 +% flush to the right margin. It is used for index and table of contents +% entries. The paragraph is indented by \leftskip. +% +\def\entry #1#2{\begingroup + % + % Start a new paragraph if necessary, so our assignments below can't + % affect previous text. + \par + % + % Do not fill out the last line with white space. + \parfillskip = 0in + % + % No extra space above this paragraph. + \parskip = 0in + % + % Do not prefer a separate line ending with a hyphen to fewer lines. + \finalhyphendemerits = 0 + % + % \hangindent is only relevant when the entry text and page number + % don't both fit on one line. In that case, bob suggests starting the + % dots pretty far over on the line. Unfortunately, a large + % indentation looks wrong when the entry text itself is broken across + % lines. So we use a small indentation and put up with long leaders. + % + % \hangafter is reset to 1 (which is the value we want) at the start + % of each paragraph, so we need not do anything with that. + \hangindent=2em + % + % When the entry text needs to be broken, just fill out the first line + % with blank space. + \rightskip = 0pt plus1fil + % + % Start a ``paragraph'' for the index entry so the line breaking + % parameters we've set above will have an effect. + \noindent + % + % Insert the text of the index entry. TeX will do line-breaking on it. + #1% + % The following is kluged to not output a line of dots in the index if + % there are no page numbers. The next person who breaks this will be + % cursed by a Unix daemon. + \def\tempa{{\rm }}% + \def\tempb{#2}% + \edef\tempc{\tempa}% + \edef\tempd{\tempb}% + \ifx\tempc\tempd\ \else% + % + % If we must, put the page number on a line of its own, and fill out + % this line with blank space. (The \hfil is overwhelmed with the + % fill leaders glue in \indexdotfill if the page number does fit.) + \hfil\penalty50 + \null\nobreak\indexdotfill % Have leaders before the page number. + % + % The `\ ' here is removed by the implicit \unskip that TeX does as + % part of (the primitive) \par. Without it, a spurious underfull + % \hbox ensues. + \ #2% The page number ends the paragraph. + \fi% + \par +\endgroup} + +% Like \dotfill except takes at least 1 em. +\def\indexdotfill{\cleaders + \hbox{$\mathsurround=0pt \mkern1.5mu ${\it .}$ \mkern1.5mu$}\hskip 1em plus 1fill} + +\def\primary #1{\line{#1\hfil}} + +\newskip\secondaryindent \secondaryindent=0.5cm + +\def\secondary #1#2{ +{\parfillskip=0in \parskip=0in +\hangindent =1in \hangafter=1 +\noindent\hskip\secondaryindent\hbox{#1}\indexdotfill #2\par +}} + +%% Define two-column mode, which is used in indexes. +%% Adapted from the TeXbook, page 416. +\catcode `\@=11 + +\newbox\partialpage + +\newdimen\doublecolumnhsize + +\def\begindoublecolumns{\begingroup + % Grab any single-column material above us. + \output = {\global\setbox\partialpage + =\vbox{\unvbox255\kern -\topskip \kern \baselineskip}}% + \eject + % + % Now switch to the double-column output routine. + \output={\doublecolumnout}% + % + % Change the page size parameters. We could do this once outside this + % routine, in each of @smallbook, @afourpaper, and the default 8.5x11 + % format, but then we repeat the same computation. Repeating a couple + % of assignments once per index is clearly meaningless for the + % execution time, so we may as well do it once. + % + % First we halve the line length, less a little for the gutter between + % the columns. We compute the gutter based on the line length, so it + % changes automatically with the paper format. The magic constant + % below is chosen so that the gutter has the same value (well, +- < + % 1pt) as it did when we hard-coded it. + % + % We put the result in a separate register, \doublecolumhsize, so we + % can restore it in \pagesofar, after \hsize itself has (potentially) + % been clobbered. + % + \doublecolumnhsize = \hsize + \advance\doublecolumnhsize by -.04154\hsize + \divide\doublecolumnhsize by 2 + \hsize = \doublecolumnhsize + % + % Double the \vsize as well. (We don't need a separate register here, + % since nobody clobbers \vsize.) + \vsize = 2\vsize + \doublecolumnpagegoal +} + +\def\enddoublecolumns{\eject \endgroup \pagegoal=\vsize \unvbox\partialpage} + +\def\doublecolumnsplit{\splittopskip=\topskip \splitmaxdepth=\maxdepth + \global\dimen@=\pageheight \global\advance\dimen@ by-\ht\partialpage + \global\setbox1=\vsplit255 to\dimen@ \global\setbox0=\vbox{\unvbox1} + \global\setbox3=\vsplit255 to\dimen@ \global\setbox2=\vbox{\unvbox3} + \ifdim\ht0>\dimen@ \setbox255=\vbox{\unvbox0\unvbox2} \global\setbox255=\copy5 \fi + \ifdim\ht2>\dimen@ \setbox255=\vbox{\unvbox0\unvbox2} \global\setbox255=\copy5 \fi +} +\def\doublecolumnpagegoal{% + \dimen@=\vsize \advance\dimen@ by-2\ht\partialpage \global\pagegoal=\dimen@ +} +\def\pagesofar{\unvbox\partialpage % + \hsize=\doublecolumnhsize % have to restore this since output routine + \wd0=\hsize \wd2=\hsize \hbox to\pagewidth{\box0\hfil\box2}} +\def\doublecolumnout{% + \setbox5=\copy255 + {\vbadness=10000 \doublecolumnsplit} + \ifvbox255 + \setbox0=\vtop to\dimen@{\unvbox0} + \setbox2=\vtop to\dimen@{\unvbox2} + \onepageout\pagesofar \unvbox255 \penalty\outputpenalty + \else + \setbox0=\vbox{\unvbox5} + \ifvbox0 + \dimen@=\ht0 \advance\dimen@ by\topskip \advance\dimen@ by-\baselineskip + \divide\dimen@ by2 \splittopskip=\topskip \splitmaxdepth=\maxdepth + {\vbadness=10000 + \loop \global\setbox5=\copy0 + \setbox1=\vsplit5 to\dimen@ + \setbox3=\vsplit5 to\dimen@ + \ifvbox5 \global\advance\dimen@ by1pt \repeat + \setbox0=\vbox to\dimen@{\unvbox1} + \setbox2=\vbox to\dimen@{\unvbox3} + \global\setbox\partialpage=\vbox{\pagesofar} + \doublecolumnpagegoal + } + \fi + \fi +} + +\catcode `\@=\other +\message{sectioning,} +% Define chapters, sections, etc. + +\newcount \chapno +\newcount \secno \secno=0 +\newcount \subsecno \subsecno=0 +\newcount \subsubsecno \subsubsecno=0 + +% This counter is funny since it counts through charcodes of letters A, B, ... +\newcount \appendixno \appendixno = `\@ +\def\appendixletter{\char\the\appendixno} + +\newwrite \contentsfile +% This is called from \setfilename. +\def\opencontents{\openout \contentsfile = \jobname.toc} + +% Each @chapter defines this as the name of the chapter. +% page headings and footings can use it. @section does likewise + +\def\thischapter{} \def\thissection{} +\def\seccheck#1{\if \pageno<0 % +\errmessage{@#1 not allowed after generating table of contents}\fi +% +} + +\def\chapternofonts{% +\let\rawbackslash=\relax% +\let\frenchspacing=\relax% +\def\result{\realbackslash result} +\def\equiv{\realbackslash equiv} +\def\expansion{\realbackslash expansion} +\def\print{\realbackslash print} +\def\TeX{\realbackslash TeX} +\def\dots{\realbackslash dots} +\def\copyright{\realbackslash copyright} +\def\tt{\realbackslash tt} +\def\bf{\realbackslash bf } +\def\w{\realbackslash w} +\def\less{\realbackslash less} +\def\gtr{\realbackslash gtr} +\def\hat{\realbackslash hat} +\def\char{\realbackslash char} +\def\tclose##1{\realbackslash tclose {##1}} +\def\code##1{\realbackslash code {##1}} +\def\samp##1{\realbackslash samp {##1}} +\def\r##1{\realbackslash r {##1}} +\def\b##1{\realbackslash b {##1}} +\def\key##1{\realbackslash key {##1}} +\def\file##1{\realbackslash file {##1}} +\def\kbd##1{\realbackslash kbd {##1}} +% These are redefined because @smartitalic wouldn't work inside xdef. +\def\i##1{\realbackslash i {##1}} +\def\cite##1{\realbackslash cite {##1}} +\def\var##1{\realbackslash var {##1}} +\def\emph##1{\realbackslash emph {##1}} +\def\dfn##1{\realbackslash dfn {##1}} +} + +\newcount\absseclevel % used to calculate proper heading level +\newcount\secbase\secbase=0 % @raise/lowersections modify this count + +% @raisesections: treat @section as chapter, @subsection as section, etc. +\def\raisesections{\global\advance\secbase by -1} +\let\up=\raisesections % original BFox name + +% @lowersections: treat @chapter as section, @section as subsection, etc. +\def\lowersections{\global\advance\secbase by 1} +\let\down=\lowersections % original BFox name + +% Choose a numbered-heading macro +% #1 is heading level if unmodified by @raisesections or @lowersections +% #2 is text for heading +\def\numhead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 +\ifcase\absseclevel + \chapterzzz{#2} +\or + \seczzz{#2} +\or + \numberedsubseczzz{#2} +\or + \numberedsubsubseczzz{#2} +\else + \ifnum \absseclevel<0 + \chapterzzz{#2} + \else + \numberedsubsubseczzz{#2} + \fi +\fi +} + +% like \numhead, but chooses appendix heading levels +\def\apphead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 +\ifcase\absseclevel + \appendixzzz{#2} +\or + \appendixsectionzzz{#2} +\or + \appendixsubseczzz{#2} +\or + \appendixsubsubseczzz{#2} +\else + \ifnum \absseclevel<0 + \appendixzzz{#2} + \else + \appendixsubsubseczzz{#2} + \fi +\fi +} + +% like \numhead, but chooses numberless heading levels +\def\unnmhead#1#2{\absseclevel=\secbase\advance\absseclevel by #1 +\ifcase\absseclevel + \unnumberedzzz{#2} +\or + \unnumberedseczzz{#2} +\or + \unnumberedsubseczzz{#2} +\or + \unnumberedsubsubseczzz{#2} +\else + \ifnum \absseclevel<0 + \unnumberedzzz{#2} + \else + \unnumberedsubsubseczzz{#2} + \fi +\fi +} + + +\def\thischaptername{No Chapter Title} +\outer\def\chapter{\parsearg\chapteryyy} +\def\chapteryyy #1{\numhead0{#1}} % normally numhead0 calls chapterzzz +\def\chapterzzz #1{\seccheck{chapter}% +\secno=0 \subsecno=0 \subsubsecno=0 +\global\advance \chapno by 1 \message{\putwordChapter \the\chapno}% +\chapmacro {#1}{\the\chapno}% +\gdef\thissection{#1}% +\gdef\thischaptername{#1}% +% We don't substitute the actual chapter name into \thischapter +% because we don't want its macros evaluated now. +\xdef\thischapter{\putwordChapter{} \the\chapno: \noexpand\thischaptername}% +{\chapternofonts% +\edef\temp{{\realbackslash chapentry {#1}{\the\chapno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\global\let\section = \numberedsec +\global\let\subsection = \numberedsubsec +\global\let\subsubsection = \numberedsubsubsec +}} + +\outer\def\appendix{\parsearg\appendixyyy} +\def\appendixyyy #1{\apphead0{#1}} % normally apphead0 calls appendixzzz +\def\appendixzzz #1{\seccheck{appendix}% +\secno=0 \subsecno=0 \subsubsecno=0 +\global\advance \appendixno by 1 \message{Appendix \appendixletter}% +\chapmacro {#1}{\putwordAppendix{} \appendixletter}% +\gdef\thissection{#1}% +\gdef\thischaptername{#1}% +\xdef\thischapter{\putwordAppendix{} \appendixletter: \noexpand\thischaptername}% +{\chapternofonts% +\edef\temp{{\realbackslash chapentry + {#1}{\putwordAppendix{} \appendixletter}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\global\let\section = \appendixsec +\global\let\subsection = \appendixsubsec +\global\let\subsubsection = \appendixsubsubsec +}} + +\outer\def\top{\parsearg\unnumberedyyy} +\outer\def\unnumbered{\parsearg\unnumberedyyy} +\def\unnumberedyyy #1{\unnmhead0{#1}} % normally unnmhead0 calls unnumberedzzz +\def\unnumberedzzz #1{\seccheck{unnumbered}% +\secno=0 \subsecno=0 \subsubsecno=0 +% +% This used to be simply \message{#1}, but TeX fully expands the +% argument to \message. Therefore, if #1 contained @-commands, TeX +% expanded them. For example, in `@unnumbered The @cite{Book}', TeX +% expanded @cite (which turns out to cause errors because \cite is meant +% to be executed, not expanded). +% +% Anyway, we don't want the fully-expanded definition of @cite to appear +% as a result of the \message, we just want `@cite' itself. We use +% \the to achieve this: TeX expands \the only once, +% simply yielding the contents of the . +\toks0 = {#1}\message{(\the\toks0)}% +% +\unnumbchapmacro {#1}% +\gdef\thischapter{#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbchapentry {#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\global\let\section = \unnumberedsec +\global\let\subsection = \unnumberedsubsec +\global\let\subsubsection = \unnumberedsubsubsec +}} + +\outer\def\numberedsec{\parsearg\secyyy} +\def\secyyy #1{\numhead1{#1}} % normally calls seczzz +\def\seczzz #1{\seccheck{section}% +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % +\gdef\thissection{#1}\secheading {#1}{\the\chapno}{\the\secno}% +{\chapternofonts% +\edef\temp{{\realbackslash secentry % +{#1}{\the\chapno}{\the\secno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appenixsection{\parsearg\appendixsecyyy} +\outer\def\appendixsec{\parsearg\appendixsecyyy} +\def\appendixsecyyy #1{\apphead1{#1}} % normally calls appendixsectionzzz +\def\appendixsectionzzz #1{\seccheck{appendixsection}% +\subsecno=0 \subsubsecno=0 \global\advance \secno by 1 % +\gdef\thissection{#1}\secheading {#1}{\appendixletter}{\the\secno}% +{\chapternofonts% +\edef\temp{{\realbackslash secentry % +{#1}{\appendixletter}{\the\secno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsec{\parsearg\unnumberedsecyyy} +\def\unnumberedsecyyy #1{\unnmhead1{#1}} % normally calls unnumberedseczzz +\def\unnumberedseczzz #1{\seccheck{unnumberedsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +\outer\def\numberedsubsec{\parsearg\numberedsubsecyyy} +\def\numberedsubsecyyy #1{\numhead2{#1}} % normally calls numberedsubseczzz +\def\numberedsubseczzz #1{\seccheck{subsection}% +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % +\subsecheading {#1}{\the\chapno}{\the\secno}{\the\subsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsecentry % +{#1}{\the\chapno}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appendixsubsec{\parsearg\appendixsubsecyyy} +\def\appendixsubsecyyy #1{\apphead2{#1}} % normally calls appendixsubseczzz +\def\appendixsubseczzz #1{\seccheck{appendixsubsec}% +\gdef\thissection{#1}\subsubsecno=0 \global\advance \subsecno by 1 % +\subsecheading {#1}{\appendixletter}{\the\secno}{\the\subsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsecentry % +{#1}{\appendixletter}{\the\secno}{\the\subsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsubsec{\parsearg\unnumberedsubsecyyy} +\def\unnumberedsubsecyyy #1{\unnmhead2{#1}} %normally calls unnumberedsubseczzz +\def\unnumberedsubseczzz #1{\seccheck{unnumberedsubsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsubsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +\outer\def\numberedsubsubsec{\parsearg\numberedsubsubsecyyy} +\def\numberedsubsubsecyyy #1{\numhead3{#1}} % normally numberedsubsubseczzz +\def\numberedsubsubseczzz #1{\seccheck{subsubsection}% +\gdef\thissection{#1}\global\advance \subsubsecno by 1 % +\subsubsecheading {#1} + {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsubsecentry % + {#1} + {\the\chapno}{\the\secno}{\the\subsecno}{\the\subsubsecno} + {\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\donoderef % +\penalty 10000 % +}} + +\outer\def\appendixsubsubsec{\parsearg\appendixsubsubsecyyy} +\def\appendixsubsubsecyyy #1{\apphead3{#1}} % normally appendixsubsubseczzz +\def\appendixsubsubseczzz #1{\seccheck{appendixsubsubsec}% +\gdef\thissection{#1}\global\advance \subsubsecno by 1 % +\subsubsecheading {#1} + {\appendixletter}{\the\secno}{\the\subsecno}{\the\subsubsecno}% +{\chapternofonts% +\edef\temp{{\realbackslash subsubsecentry{#1}% + {\appendixletter} + {\the\secno}{\the\subsecno}{\the\subsubsecno}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\appendixnoderef % +\penalty 10000 % +}} + +\outer\def\unnumberedsubsubsec{\parsearg\unnumberedsubsubsecyyy} +\def\unnumberedsubsubsecyyy #1{\unnmhead3{#1}} %normally unnumberedsubsubseczzz +\def\unnumberedsubsubseczzz #1{\seccheck{unnumberedsubsubsec}% +\plainsecheading {#1}\gdef\thissection{#1}% +{\chapternofonts% +\edef\temp{{\realbackslash unnumbsubsubsecentry{#1}{\noexpand\folio}}}% +\escapechar=`\\% +\write \contentsfile \temp % +\unnumbnoderef % +\penalty 10000 % +}} + +% These are variants which are not "outer", so they can appear in @ifinfo. +% Actually, they should now be obsolete; ordinary section commands should work. +\def\infotop{\parsearg\unnumberedzzz} +\def\infounnumbered{\parsearg\unnumberedzzz} +\def\infounnumberedsec{\parsearg\unnumberedseczzz} +\def\infounnumberedsubsec{\parsearg\unnumberedsubseczzz} +\def\infounnumberedsubsubsec{\parsearg\unnumberedsubsubseczzz} + +\def\infoappendix{\parsearg\appendixzzz} +\def\infoappendixsec{\parsearg\appendixseczzz} +\def\infoappendixsubsec{\parsearg\appendixsubseczzz} +\def\infoappendixsubsubsec{\parsearg\appendixsubsubseczzz} + +\def\infochapter{\parsearg\chapterzzz} +\def\infosection{\parsearg\sectionzzz} +\def\infosubsection{\parsearg\subsectionzzz} +\def\infosubsubsection{\parsearg\subsubsectionzzz} + +% These macros control what the section commands do, according +% to what kind of chapter we are in (ordinary, appendix, or unnumbered). +% Define them by default for a numbered chapter. +\global\let\section = \numberedsec +\global\let\subsection = \numberedsubsec +\global\let\subsubsection = \numberedsubsubsec + +% Define @majorheading, @heading and @subheading + +% NOTE on use of \vbox for chapter headings, section headings, and +% such: +% 1) We use \vbox rather than the earlier \line to permit +% overlong headings to fold. +% 2) \hyphenpenalty is set to 10000 because hyphenation in a +% heading is obnoxious; this forbids it. +% 3) Likewise, headings look best if no \parindent is used, and +% if justification is not attempted. Hence \raggedright. + + +\def\majorheading{\parsearg\majorheadingzzz} +\def\majorheadingzzz #1{% +{\advance\chapheadingskip by 10pt \chapbreak }% +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 200} + +\def\chapheading{\parsearg\chapheadingzzz} +\def\chapheadingzzz #1{\chapbreak % +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 200} + +\def\heading{\parsearg\secheadingi} + +\def\subheading{\parsearg\subsecheadingi} + +\def\subsubheading{\parsearg\subsubsecheadingi} + +% These macros generate a chapter, section, etc. heading only +% (including whitespace, linebreaking, etc. around it), +% given all the information in convenient, parsed form. + +%%% Args are the skip and penalty (usually negative) +\def\dobreak#1#2{\par\ifdim\lastskip<#1\removelastskip\penalty#2\vskip#1\fi} + +\def\setchapterstyle #1 {\csname CHAPF#1\endcsname} + +%%% Define plain chapter starts, and page on/off switching for it +% Parameter controlling skip before chapter headings (if needed) + +\newskip \chapheadingskip \chapheadingskip = 30pt plus 8pt minus 4pt + +\def\chapbreak{\dobreak \chapheadingskip {-4000}} +\def\chappager{\par\vfill\supereject} +\def\chapoddpage{\chappager \ifodd\pageno \else \hbox to 0pt{} \chappager\fi} + +\def\setchapternewpage #1 {\csname CHAPPAG#1\endcsname} + +\def\CHAPPAGoff{ +\global\let\pchapsepmacro=\chapbreak +\global\let\pagealignmacro=\chappager} + +\def\CHAPPAGon{ +\global\let\pchapsepmacro=\chappager +\global\let\pagealignmacro=\chappager +\global\def\HEADINGSon{\HEADINGSsingle}} + +\def\CHAPPAGodd{ +\global\let\pchapsepmacro=\chapoddpage +\global\let\pagealignmacro=\chapoddpage +\global\def\HEADINGSon{\HEADINGSdouble}} + +\CHAPPAGon + +\def\CHAPFplain{ +\global\let\chapmacro=\chfplain +\global\let\unnumbchapmacro=\unnchfplain} + +\def\chfplain #1#2{% + \pchapsepmacro + {% + \chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #2\enspace #1}% + }% + \bigskip + \penalty5000 +} + +\def\unnchfplain #1{% +\pchapsepmacro % +{\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 10000 % +} +\CHAPFplain % The default + +\def\unnchfopen #1{% +\chapoddpage {\chapfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}\bigskip \par\penalty 10000 % +} + +\def\chfopen #1#2{\chapoddpage {\chapfonts +\vbox to 3in{\vfil \hbox to\hsize{\hfil #2} \hbox to\hsize{\hfil #1} \vfil}}% +\par\penalty 5000 % +} + +\def\CHAPFopen{ +\global\let\chapmacro=\chfopen +\global\let\unnumbchapmacro=\unnchfopen} + +% Parameter controlling skip before section headings. + +% was 17pt plus 8pt minus 4pt +\newskip \subsecheadingskip \subsecheadingskip = 0pt plus 4pt minus 4pt +\def\subsecheadingbreak{\dobreak \subsecheadingskip {-500}} + +% was 21pt plus 8pt minus 4pt +\newskip \secheadingskip \secheadingskip = 0pt plus 4pt minus 4pt +\def\secheadingbreak{\dobreak \secheadingskip {-1000}} + +% @paragraphindent is defined for the Info formatting commands only. +\let\paragraphindent=\comment + +% Section fonts are the base font at magstep2, which produces +% a size a bit more than 14 points in the default situation. + +\def\secheading #1#2#3{\secheadingi {#2.#3\enspace #1}} +\def\plainsecheading #1{\secheadingi {#1}} +\def\secheadingi #1{{\advance \secheadingskip by \parskip % +\secheadingbreak}% +{\secfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 } + + +% Subsection fonts are the base font at magstep1, +% which produces a size of 12 points. + +\def\subsecheading #1#2#3#4{\subsecheadingi {#2.#3.#4\enspace #1}} +\def\subsecheadingi #1{{\advance \subsecheadingskip by \parskip % +\subsecheadingbreak}% +{\subsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000 } + +\def\subsubsecfonts{\subsecfonts} % Maybe this should change: + % Perhaps make sssec fonts scaled + % magstep half +\def\subsubsecheading #1#2#3#4#5{\subsubsecheadingi {#2.#3.#4.#5\enspace #1}} +\def\subsubsecheadingi #1{{\advance \subsecheadingskip by \parskip % +\subsecheadingbreak}% +{\subsubsecfonts \vbox{\hyphenpenalty=10000\tolerance=5000 + \parindent=0pt\raggedright + \rm #1\hfill}}% +\ifdim \parskip<10pt \kern 10pt\kern -\parskip\fi \penalty 10000} + + +\message{toc printing,} + +% Finish up the main text and prepare to read what we've written +% to \contentsfile. + +\newskip\contentsrightmargin \contentsrightmargin=1in +\def\startcontents#1{% + \pagealignmacro + \immediate\closeout \contentsfile + \ifnum \pageno>0 + \pageno = -1 % Request roman numbered pages. + \fi + % Don't need to put `Contents' or `Short Contents' in the headline. + % It is abundantly clear what they are. + \unnumbchapmacro{#1}\def\thischapter{}% + \begingroup % Set up to handle contents files properly. + \catcode`\\=0 \catcode`\{=1 \catcode`\}=2 \catcode`\@=11 + \catcode`\^=7 % to see ^^e4 as \"a etc. juha@piuha.ydi.vtt.fi + \raggedbottom % Worry more about breakpoints than the bottom. + \advance\hsize by -\contentsrightmargin % Don't use the full line length. +} + + +% Normal (long) toc. +\outer\def\contents{% + \startcontents{\putwordTableofContents}% + \input \jobname.toc + \endgroup + \vfill \eject +} + +% And just the chapters. +\outer\def\summarycontents{% + \startcontents{\putwordShortContents}% + % + \let\chapentry = \shortchapentry + \let\unnumbchapentry = \shortunnumberedentry + % We want a true roman here for the page numbers. + \secfonts + \let\rm=\shortcontrm \let\bf=\shortcontbf \let\sl=\shortcontsl + \rm + \advance\baselineskip by 1pt % Open it up a little. + \def\secentry ##1##2##3##4{} + \def\unnumbsecentry ##1##2{} + \def\subsecentry ##1##2##3##4##5{} + \def\unnumbsubsecentry ##1##2{} + \def\subsubsecentry ##1##2##3##4##5##6{} + \def\unnumbsubsubsecentry ##1##2{} + \input \jobname.toc + \endgroup + \vfill \eject +} +\let\shortcontents = \summarycontents + +% These macros generate individual entries in the table of contents. +% The first argument is the chapter or section name. +% The last argument is the page number. +% The arguments in between are the chapter number, section number, ... + +% Chapter-level things, for both the long and short contents. +\def\chapentry#1#2#3{\dochapentry{#2\labelspace#1}{#3}} + +% See comments in \dochapentry re vbox and related settings +\def\shortchapentry#1#2#3{% + \tocentry{\shortchaplabel{#2}\labelspace #1}{\doshortpageno{#3}}% +} + +% Typeset the label for a chapter or appendix for the short contents. +% The arg is, e.g. `Appendix A' for an appendix, or `3' for a chapter. +% We could simplify the code here by writing out an \appendixentry +% command in the toc file for appendices, instead of using \chapentry +% for both, but it doesn't seem worth it. +\setbox0 = \hbox{\shortcontrm \putwordAppendix } +\newdimen\shortappendixwidth \shortappendixwidth = \wd0 + +\def\shortchaplabel#1{% + % We typeset #1 in a box of constant width, regardless of the text of + % #1, so the chapter titles will come out aligned. + \setbox0 = \hbox{#1}% + \dimen0 = \ifdim\wd0 > \shortappendixwidth \shortappendixwidth \else 0pt \fi + % + % This space should be plenty, since a single number is .5em, and the + % widest letter (M) is 1em, at least in the Computer Modern fonts. + % (This space doesn't include the extra space that gets added after + % the label; that gets put in in \shortchapentry above.) + \advance\dimen0 by 1.1em + \hbox to \dimen0{#1\hfil}% +} + +\def\unnumbchapentry#1#2{\dochapentry{#1}{#2}} +\def\shortunnumberedentry#1#2{\tocentry{#1}{\doshortpageno{#2}}} + +% Sections. +\def\secentry#1#2#3#4{\dosecentry{#2.#3\labelspace#1}{#4}} +\def\unnumbsecentry#1#2{\dosecentry{#1}{#2}} + +% Subsections. +\def\subsecentry#1#2#3#4#5{\dosubsecentry{#2.#3.#4\labelspace#1}{#5}} +\def\unnumbsubsecentry#1#2{\dosubsecentry{#1}{#2}} + +% And subsubsections. +\def\subsubsecentry#1#2#3#4#5#6{% + \dosubsubsecentry{#2.#3.#4.#5\labelspace#1}{#6}} +\def\unnumbsubsubsecentry#1#2{\dosubsubsecentry{#1}{#2}} + + +% This parameter controls the indentation of the various levels. +\newdimen\tocindent \tocindent = 3pc + +% Now for the actual typesetting. In all these, #1 is the text and #2 is the +% page number. +% +% If the toc has to be broken over pages, we would want to be at chapters +% if at all possible; hence the \penalty. +\def\dochapentry#1#2{% + \penalty-300 \vskip\baselineskip + \begingroup + \chapentryfonts + \tocentry{#1}{\dopageno{#2}}% + \endgroup + \nobreak\vskip .25\baselineskip +} + +\def\dosecentry#1#2{\begingroup + \secentryfonts \leftskip=\tocindent + \tocentry{#1}{\dopageno{#2}}% +\endgroup} + +\def\dosubsecentry#1#2{\begingroup + \subsecentryfonts \leftskip=2\tocindent + \tocentry{#1}{\dopageno{#2}}% +\endgroup} + +\def\dosubsubsecentry#1#2{\begingroup + \subsubsecentryfonts \leftskip=3\tocindent + \tocentry{#1}{\dopageno{#2}}% +\endgroup} + +% Final typesetting of a toc entry; we use the same \entry macro as for +% the index entries, but we want to suppress hyphenation here. (We +% can't do that in the \entry macro, since index entries might consist +% of hyphenated-identifiers-that-do-not-fit-on-a-line-and-nothing-else.) +% +\def\tocentry#1#2{\begingroup + \hyphenpenalty = 10000 + \entry{#1}{#2}% +\endgroup} + +% Space between chapter (or whatever) number and the title. +\def\labelspace{\hskip1em \relax} + +\def\dopageno#1{{\rm #1}} +\def\doshortpageno#1{{\rm #1}} + +\def\chapentryfonts{\secfonts \rm} +\def\secentryfonts{\textfonts} +\let\subsecentryfonts = \textfonts +\let\subsubsecentryfonts = \textfonts + + +\message{environments,} + +% Since these characters are used in examples, it should be an even number of +% \tt widths. Each \tt character is 1en, so two makes it 1em. +% Furthermore, these definitions must come after we define our fonts. +\newbox\dblarrowbox \newbox\longdblarrowbox +\newbox\pushcharbox \newbox\bullbox +\newbox\equivbox \newbox\errorbox + +\let\ptexequiv = \equiv + +%{\tentt +%\global\setbox\dblarrowbox = \hbox to 1em{\hfil$\Rightarrow$\hfil} +%\global\setbox\longdblarrowbox = \hbox to 1em{\hfil$\mapsto$\hfil} +%\global\setbox\pushcharbox = \hbox to 1em{\hfil$\dashv$\hfil} +%\global\setbox\equivbox = \hbox to 1em{\hfil$\ptexequiv$\hfil} +% Adapted from the manmac format (p.420 of TeXbook) +%\global\setbox\bullbox = \hbox to 1em{\kern.15em\vrule height .75ex width .85ex +% depth .1ex\hfil} +%} + +\def\point{$\star$} + +\def\result{\leavevmode\raise.15ex\hbox to 1em{\hfil$\Rightarrow$\hfil}} +\def\expansion{\leavevmode\raise.1ex\hbox to 1em{\hfil$\mapsto$\hfil}} +\def\print{\leavevmode\lower.1ex\hbox to 1em{\hfil$\dashv$\hfil}} + +\def\equiv{\leavevmode\lower.1ex\hbox to 1em{\hfil$\ptexequiv$\hfil}} + +% Adapted from the TeXbook's \boxit. +{\tentt \global\dimen0 = 3em}% Width of the box. +\dimen2 = .55pt % Thickness of rules +% The text. (`r' is open on the right, `e' somewhat less so on the left.) +\setbox0 = \hbox{\kern-.75pt \tensf error\kern-1.5pt} + +\global\setbox\errorbox=\hbox to \dimen0{\hfil + \hsize = \dimen0 \advance\hsize by -5.8pt % Space to left+right. + \advance\hsize by -2\dimen2 % Rules. + \vbox{ + \hrule height\dimen2 + \hbox{\vrule width\dimen2 \kern3pt % Space to left of text. + \vtop{\kern2.4pt \box0 \kern2.4pt}% Space above/below. + \kern3pt\vrule width\dimen2}% Space to right. + \hrule height\dimen2} + \hfil} + +% The @error{} command. +\def\error{\leavevmode\lower.7ex\copy\errorbox} + +% @tex ... @end tex escapes into raw Tex temporarily. +% One exception: @ is still an escape character, so that @end tex works. +% But \@ or @@ will get a plain tex @ character. + +\def\tex{\begingroup +\catcode `\\=0 \catcode `\{=1 \catcode `\}=2 +\catcode `\$=3 \catcode `\&=4 \catcode `\#=6 +\catcode `\^=7 \catcode `\_=8 \catcode `\~=13 \let~=\tie +\catcode `\%=14 +\catcode 43=12 +\catcode`\"=12 +\catcode`\==12 +\catcode`\|=12 +\catcode`\<=12 +\catcode`\>=12 +\escapechar=`\\ +% +\let\~=\ptextilde +\let\{=\ptexlbrace +\let\}=\ptexrbrace +\let\.=\ptexdot +\let\*=\ptexstar +\let\dots=\ptexdots +\def\@{@}% +\let\bullet=\ptexbullet +\let\b=\ptexb \let\c=\ptexc \let\i=\ptexi \let\t=\ptext \let\l=\ptexl +\let\L=\ptexL +% +\let\Etex=\endgroup} + +% Define @lisp ... @endlisp. +% @lisp does a \begingroup so it can rebind things, +% including the definition of @endlisp (which normally is erroneous). + +% Amount to narrow the margins by for @lisp. +\newskip\lispnarrowing \lispnarrowing=0.4in + +% This is the definition that ^^M gets inside @lisp, @example, and other +% such environments. \null is better than a space, since it doesn't +% have any width. +\def\lisppar{\null\endgraf} + +% Make each space character in the input produce a normal interword +% space in the output. Don't allow a line break at this space, as this +% is used only in environments like @example, where each line of input +% should produce a line of output anyway. +% +{\obeyspaces % +\gdef\sepspaces{\obeyspaces\let =\tie}} + +% Define \obeyedspace to be our active space, whatever it is. This is +% for use in \parsearg. +{\sepspaces% +\global\let\obeyedspace= } + +% This space is always present above and below environments. +\newskip\envskipamount \envskipamount = 0pt + +% Make spacing and below environment symmetrical. We use \parskip here +% to help in doing that, since in @example-like environments \parskip +% is reset to zero; thus the \afterenvbreak inserts no space -- but the +% start of the next paragraph will insert \parskip +% +\def\aboveenvbreak{{\advance\envskipamount by \parskip +\endgraf \ifdim\lastskip<\envskipamount +\removelastskip \penalty-50 \vskip\envskipamount \fi}} + +\let\afterenvbreak = \aboveenvbreak + +% \nonarrowing is a flag. If "set", @lisp etc don't narrow margins. +\let\nonarrowing=\relax + +%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +% \cartouche: draw rectangle w/rounded corners around argument +\font\circle=lcircle10 +\newdimen\circthick +\newdimen\cartouter\newdimen\cartinner +\newskip\normbskip\newskip\normpskip\newskip\normlskip +\circthick=\fontdimen8\circle +% +\def\ctl{{\circle\char'013\hskip -6pt}}% 6pt from pl file: 1/2charwidth +\def\ctr{{\hskip 6pt\circle\char'010}} +\def\cbl{{\circle\char'012\hskip -6pt}} +\def\cbr{{\hskip 6pt\circle\char'011}} +\def\carttop{\hbox to \cartouter{\hskip\lskip + \ctl\leaders\hrule height\circthick\hfil\ctr + \hskip\rskip}} +\def\cartbot{\hbox to \cartouter{\hskip\lskip + \cbl\leaders\hrule height\circthick\hfil\cbr + \hskip\rskip}} +% +\newskip\lskip\newskip\rskip + +\long\def\cartouche{% +\begingroup + \lskip=\leftskip \rskip=\rightskip + \leftskip=0pt\rightskip=0pt %we want these *outside*. + \cartinner=\hsize \advance\cartinner by-\lskip + \advance\cartinner by-\rskip + \cartouter=\hsize + \advance\cartouter by 18pt % allow for 3pt kerns on either +% side, and for 6pt waste from +% each corner char + \normbskip=\baselineskip \normpskip=\parskip \normlskip=\lineskip + % Flag to tell @lisp, etc., not to narrow margin. + \let\nonarrowing=\comment + \vbox\bgroup + \baselineskip=0pt\parskip=0pt\lineskip=0pt + \carttop + \hbox\bgroup + \hskip\lskip + \vrule\kern3pt + \vbox\bgroup + \hsize=\cartinner + \kern3pt + \begingroup + \baselineskip=\normbskip + \lineskip=\normlskip + \parskip=\normpskip + \vskip -\parskip +\def\Ecartouche{% + \endgroup + \kern3pt + \egroup + \kern3pt\vrule + \hskip\rskip + \egroup + \cartbot + \egroup +\endgroup +}} + + +% This macro is called at the beginning of all the @example variants, +% inside a group. +\def\nonfillstart{% + \aboveenvbreak + \inENV % This group ends at the end of the body + \hfuzz = 12pt % Don't be fussy + \sepspaces % Make spaces be word-separators rather than space tokens. + \singlespace + \let\par = \lisppar % don't ignore blank lines + \obeylines % each line of input is a line of output + \parskip = 0pt + \parindent = 0pt + \emergencystretch = 0pt % don't try to avoid overfull boxes + % @cartouche defines \nonarrowing to inhibit narrowing + % at next level down. + \ifx\nonarrowing\relax + \advance \leftskip by \lispnarrowing + \exdentamount=\lispnarrowing + \let\exdent=\nofillexdent + \let\nonarrowing=\relax + \fi +} + +% To ending an @example-like environment, we first end the paragraph +% (via \afterenvbreak's vertical glue), and then the group. That way we +% keep the zero \parskip that the environments set -- \parskip glue +% will be inserted at the beginning of the next paragraph in the +% document, after the environment. +% +\def\nonfillfinish{\afterenvbreak\endgroup}% + +% This macro is +\def\lisp{\begingroup + \nonfillstart + \let\Elisp = \nonfillfinish + \tt + \rawbackslash % have \ input char produce \ char from current font + \gobble +} + +% Define the \E... control sequence only if we are inside the +% environment, so the error checking in \end will work. +% +% We must call \lisp last in the definition, since it reads the +% return following the @example (or whatever) command. +% +\def\example{\begingroup \def\Eexample{\nonfillfinish\endgroup}\lisp} +\def\smallexample{\begingroup \def\Esmallexample{\nonfillfinish\endgroup}\lisp} +\def\smalllisp{\begingroup \def\Esmalllisp{\nonfillfinish\endgroup}\lisp} + +% @smallexample and @smalllisp. This is not used unless the @smallbook +% command is given. Originally contributed by Pavel@xerox. +% +\def\smalllispx{\begingroup + \nonfillstart + \let\Esmalllisp = \nonfillfinish + \let\Esmallexample = \nonfillfinish + % + % Smaller interline space and fonts for small examples. + \setleading{10pt}% + \indexfonts \tt + \rawbackslash % make \ output the \ character from the current font (tt) + \gobble +} + +% This is @display; same as @lisp except use roman font. +% +\def\display{\begingroup + \nonfillstart + \let\Edisplay = \nonfillfinish + \gobble +} + +% This is @format; same as @display except don't narrow margins. +% +\def\format{\begingroup + \let\nonarrowing = t + \nonfillstart + \let\Eformat = \nonfillfinish + \gobble +} + +% @flushleft (same as @format) and @flushright. +% +\def\flushleft{\begingroup + \let\nonarrowing = t + \nonfillstart + \let\Eflushleft = \nonfillfinish + \gobble +} +\def\flushright{\begingroup + \let\nonarrowing = t + \nonfillstart + \let\Eflushright = \nonfillfinish + \advance\leftskip by 0pt plus 1fill + \gobble} + +% @quotation does normal linebreaking (hence we can't use \nonfillstart) +% and narrows the margins. +% +\def\quotation{% + \begingroup\inENV %This group ends at the end of the @quotation body + {\parskip=0pt \aboveenvbreak}% because \aboveenvbreak inserts \parskip + \singlespace + \parindent=0pt + % We have retained a nonzero parskip for the environment, since we're + % doing normal filling. So to avoid extra space below the environment... + \def\Equotation{\parskip = 0pt \nonfillfinish}% + % + % @cartouche defines \nonarrowing to inhibit narrowing at next level down. + \ifx\nonarrowing\relax + \advance\leftskip by \lispnarrowing + \advance\rightskip by \lispnarrowing + \exdentamount = \lispnarrowing + \let\nonarrowing = \relax + \fi +} + +\message{defuns,} +% Define formatter for defuns +% First, allow user to change definition object font (\df) internally +\def\setdeffont #1 {\csname DEF#1\endcsname} + +\newskip\defbodyindent \defbodyindent=.4in +\newskip\defargsindent \defargsindent=50pt +\newskip\deftypemargin \deftypemargin=12pt +\newskip\deflastargmargin \deflastargmargin=18pt + +\newcount\parencount +% define \functionparens, which makes ( and ) and & do special things. +% \functionparens affects the group it is contained in. +\def\activeparens{% +\catcode`\(=\active \catcode`\)=\active \catcode`\&=\active +\catcode`\[=\active \catcode`\]=\active} + +% Make control sequences which act like normal parenthesis chars. +\let\lparen = ( \let\rparen = ) + +{\activeparens % Now, smart parens don't turn on until &foo (see \amprm) + +% Be sure that we always have a definition for `(', etc. For example, +% if the fn name has parens in it, \boldbrax will not be in effect yet, +% so TeX would otherwise complain about undefined control sequence. +\global\let(=\lparen \global\let)=\rparen +\global\let[=\lbrack \global\let]=\rbrack + +\gdef\functionparens{\boldbrax\let&=\amprm\parencount=0 } +\gdef\boldbrax{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb} +% This is used to turn on special parens +% but make & act ordinary (given that it's active). +\gdef\boldbraxnoamp{\let(=\opnr\let)=\clnr\let[=\lbrb\let]=\rbrb\let&=\ampnr} + +% Definitions of (, ) and & used in args for functions. +% This is the definition of ( outside of all parentheses. +\gdef\oprm#1 {{\rm\char`\(}#1 \bf \let(=\opnested % +\global\advance\parencount by 1 } +% +% This is the definition of ( when already inside a level of parens. +\gdef\opnested{\char`\(\global\advance\parencount by 1 } +% +\gdef\clrm{% Print a paren in roman if it is taking us back to depth of 0. +% also in that case restore the outer-level definition of (. +\ifnum \parencount=1 {\rm \char `\)}\sl \let(=\oprm \else \char `\) \fi +\global\advance \parencount by -1 } +% If we encounter &foo, then turn on ()-hacking afterwards +\gdef\amprm#1 {{\rm\}\let(=\oprm \let)=\clrm\ } +% +\gdef\normalparens{\boldbrax\let&=\ampnr} +} % End of definition inside \activeparens +%% These parens (in \boldbrax) actually are a little bolder than the +%% contained text. This is especially needed for [ and ] +\def\opnr{{\sf\char`\(}} \def\clnr{{\sf\char`\)}} \def\ampnr{\&} +\def\lbrb{{\bf\char`\[}} \def\rbrb{{\bf\char`\]}} + +% First, defname, which formats the header line itself. +% #1 should be the function name. +% #2 should be the type of definition, such as "Function". + +\def\defname #1#2{% +% Get the values of \leftskip and \rightskip as they were +% outside the @def... +\dimen2=\leftskip +\advance\dimen2 by -\defbodyindent +\dimen3=\rightskip +\advance\dimen3 by -\defbodyindent +\noindent % +\setbox0=\hbox{\hskip \deflastargmargin{\rm #2}\hskip \deftypemargin}% +\dimen0=\hsize \advance \dimen0 by -\wd0 % compute size for first line +\dimen1=\hsize \advance \dimen1 by -\defargsindent %size for continuations +\parshape 2 0in \dimen0 \defargsindent \dimen1 % +% Now output arg 2 ("Function" or some such) +% ending at \deftypemargin from the right margin, +% but stuck inside a box of width 0 so it does not interfere with linebreaking +{% Adjust \hsize to exclude the ambient margins, +% so that \rightline will obey them. +\advance \hsize by -\dimen2 \advance \hsize by -\dimen3 +\rlap{\rightline{{\rm #2}\hskip \deftypemargin}}}% +% Make all lines underfull and no complaints: +\tolerance=10000 \hbadness=10000 +\advance\leftskip by -\defbodyindent +\exdentamount=\defbodyindent +{\df #1}\enskip % Generate function name +} + +% Actually process the body of a definition +% #1 should be the terminating control sequence, such as \Edefun. +% #2 should be the "another name" control sequence, such as \defunx. +% #3 should be the control sequence that actually processes the header, +% such as \defunheader. + +\def\defparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2{\begingroup\obeylines\activeparens\spacesplit#3}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup % +\catcode 61=\active % 61 is `=' +\obeylines\activeparens\spacesplit#3} + +\def\defmethparsebody #1#2#3#4 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 {\begingroup\obeylines\activeparens\spacesplit{#3{##1}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\activeparens\spacesplit{#3{#4}}} + +\def\defopparsebody #1#2#3#4#5 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 ##2 {\def#4{##1}% +\begingroup\obeylines\activeparens\spacesplit{#3{##2}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\activeparens\spacesplit{#3{#5}}} + +% These parsing functions are similar to the preceding ones +% except that they do not make parens into active characters. +% These are used for "variables" since they have no arguments. + +\def\defvarparsebody #1#2#3{\begingroup\inENV% Environment for definitionbody +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2{\begingroup\obeylines\spacesplit#3}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup % +\catcode 61=\active % +\obeylines\spacesplit#3} + +% This is used for \def{tp,vr}parsebody. It could probably be used for +% some of the others, too, with some judicious conditionals. +% +\def\parsebodycommon#1#2#3{% + \begingroup\inENV % + \medbreak % + % Define the end token that this defining construct specifies + % so that it will exit this group. + \def#1{\endgraf\endgroup\medbreak}% + \def#2##1 {\begingroup\obeylines\spacesplit{#3{##1}}}% + \parindent=0in + \advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent + \exdentamount=\defbodyindent + \begingroup\obeylines +} + +\def\defvrparsebody#1#2#3#4 {% + \parsebodycommon{#1}{#2}{#3}% + \spacesplit{#3{#4}}% +} + +% This loses on `@deftp {Data Type} {struct termios}' -- it thinks the +% type is just `struct', because we lose the braces in `{struct +% termios}' when \spacesplit reads its undelimited argument. Sigh. +% \let\deftpparsebody=\defvrparsebody +% +% So, to get around this, we put \empty in with the type name. That +% way, TeX won't find exactly `{...}' as an undelimited argument, and +% won't strip off the braces. +% +\def\deftpparsebody #1#2#3#4 {% + \parsebodycommon{#1}{#2}{#3}% + \spacesplit{\parsetpheaderline{#3{#4}}}\empty +} + +% Fine, but then we have to eventually remove the \empty *and* the +% braces (if any). That's what this does, putting the result in \tptemp. +% +\def\removeemptybraces\empty#1\relax{\def\tptemp{#1}}% + +% After \spacesplit has done its work, this is called -- #1 is the final +% thing to call, #2 the type name (which starts with \empty), and #3 +% (which might be empty) the arguments. +% +\def\parsetpheaderline#1#2#3{% + \removeemptybraces#2\relax + #1{\tptemp}{#3}% +}% + +\def\defopvarparsebody #1#2#3#4#5 {\begingroup\inENV % +\medbreak % +% Define the end token that this defining construct specifies +% so that it will exit this group. +\def#1{\endgraf\endgroup\medbreak}% +\def#2##1 ##2 {\def#4{##1}% +\begingroup\obeylines\spacesplit{#3{##2}}}% +\parindent=0in +\advance\leftskip by \defbodyindent \advance \rightskip by \defbodyindent +\exdentamount=\defbodyindent +\begingroup\obeylines\spacesplit{#3{#5}}} + +% Split up #2 at the first space token. +% call #1 with two arguments: +% the first is all of #2 before the space token, +% the second is all of #2 after that space token. +% If #2 contains no space token, all of it is passed as the first arg +% and the second is passed as empty. + +{\obeylines +\gdef\spacesplit#1#2^^M{\endgroup\spacesplitfoo{#1}#2 \relax\spacesplitfoo}% +\long\gdef\spacesplitfoo#1#2 #3#4\spacesplitfoo{% +\ifx\relax #3% +#1{#2}{}\else #1{#2}{#3#4}\fi}} + +% So much for the things common to all kinds of definitions. + +% Define @defun. + +% First, define the processing that is wanted for arguments of \defun +% Use this to expand the args and terminate the paragraph they make up + +\def\defunargs #1{\functionparens \sl +% Expand, preventing hyphenation at `-' chars. +% Note that groups don't affect changes in \hyphenchar. +\hyphenchar\tensl=0 +#1% +\hyphenchar\tensl=45 +\ifnum\parencount=0 \else \errmessage{unbalanced parens in @def arguments}\fi% +\interlinepenalty=10000 +\advance\rightskip by 0pt plus 1fil +\endgraf\penalty 10000\vskip -\parskip\penalty 10000% +} + +\def\deftypefunargs #1{% +% Expand, preventing hyphenation at `-' chars. +% Note that groups don't affect changes in \hyphenchar. +% Use \boldbraxnoamp, not \functionparens, so that & is not special. +\boldbraxnoamp +\tclose{#1}% avoid \code because of side effects on active chars +\interlinepenalty=10000 +\advance\rightskip by 0pt plus 1fil +\endgraf\penalty 10000\vskip -\parskip\penalty 10000% +} + +% Do complete processing of one @defun or @defunx line already parsed. + +% @deffn Command forward-char nchars + +\def\deffn{\defmethparsebody\Edeffn\deffnx\deffnheader} + +\def\deffnheader #1#2#3{\doind {fn}{\code{#2}}% +\begingroup\defname {#2}{#1}\defunargs{#3}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defun == @deffn Function + +\def\defun{\defparsebody\Edefun\defunx\defunheader} + +\def\defunheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Function}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @deftypefun int foobar (int @var{foo}, float @var{bar}) + +\def\deftypefun{\defparsebody\Edeftypefun\deftypefunx\deftypefunheader} + +% #1 is the data type. #2 is the name and args. +\def\deftypefunheader #1#2{\deftypefunheaderx{#1}#2 \relax} +% #1 is the data type, #2 the name, #3 the args. +\def\deftypefunheaderx #1#2 #3\relax{% +\doind {fn}{\code{#2}}% Make entry in function index +\begingroup\defname {\defheaderxcond#1\relax$$$#2}{Function}% +\deftypefunargs {#3}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @deftypefn {Library Function} int foobar (int @var{foo}, float @var{bar}) + +\def\deftypefn{\defmethparsebody\Edeftypefn\deftypefnx\deftypefnheader} + +% \defheaderxcond#1\relax$$$ +% puts #1 in @code, followed by a space, but does nothing if #1 is null. +\def\defheaderxcond#1#2$$${\ifx#1\relax\else\code{#1#2} \fi} + +% #1 is the classification. #2 is the data type. #3 is the name and args. +\def\deftypefnheader #1#2#3{\deftypefnheaderx{#1}{#2}#3 \relax} +% #1 is the classification, #2 the data type, #3 the name, #4 the args. +\def\deftypefnheaderx #1#2#3 #4\relax{% +\doind {fn}{\code{#3}}% Make entry in function index +\begingroup +\normalparens % notably, turn off `&' magic, which prevents +% at least some C++ text from working +\defname {\defheaderxcond#2\relax$$$#3}{#1}% +\deftypefunargs {#4}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defmac == @deffn Macro + +\def\defmac{\defparsebody\Edefmac\defmacx\defmacheader} + +\def\defmacheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Macro}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% @defspec == @deffn Special Form + +\def\defspec{\defparsebody\Edefspec\defspecx\defspecheader} + +\def\defspecheader #1#2{\doind {fn}{\code{#1}}% Make entry in function index +\begingroup\defname {#1}{Special Form}% +\defunargs {#2}\endgroup % +\catcode 61=\other % Turn off change made in \defparsebody +} + +% This definition is run if you use @defunx +% anywhere other than immediately after a @defun or @defunx. + +\def\deffnx #1 {\errmessage{@deffnx in invalid context}} +\def\defunx #1 {\errmessage{@defunx in invalid context}} +\def\defmacx #1 {\errmessage{@defmacx in invalid context}} +\def\defspecx #1 {\errmessage{@defspecx in invalid context}} +\def\deftypefnx #1 {\errmessage{@deftypefnx in invalid context}} +\def\deftypeunx #1 {\errmessage{@deftypeunx in invalid context}} + +% @defmethod, and so on + +% @defop {Funny Method} foo-class frobnicate argument + +\def\defop #1 {\def\defoptype{#1}% +\defopparsebody\Edefop\defopx\defopheader\defoptype} + +\def\defopheader #1#2#3{% +\dosubind {fn}{\code{#2}}{on #1}% Make entry in function index +\begingroup\defname {#2}{\defoptype{} on #1}% +\defunargs {#3}\endgroup % +} + +% @defmethod == @defop Method + +\def\defmethod{\defmethparsebody\Edefmethod\defmethodx\defmethodheader} + +\def\defmethodheader #1#2#3{% +\dosubind {fn}{\code{#2}}{on #1}% entry in function index +\begingroup\defname {#2}{Method on #1}% +\defunargs {#3}\endgroup % +} + +% @defcv {Class Option} foo-class foo-flag + +\def\defcv #1 {\def\defcvtype{#1}% +\defopvarparsebody\Edefcv\defcvx\defcvarheader\defcvtype} + +\def\defcvarheader #1#2#3{% +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index +\begingroup\defname {#2}{\defcvtype{} of #1}% +\defvarargs {#3}\endgroup % +} + +% @defivar == @defcv {Instance Variable} + +\def\defivar{\defvrparsebody\Edefivar\defivarx\defivarheader} + +\def\defivarheader #1#2#3{% +\dosubind {vr}{\code{#2}}{of #1}% Make entry in var index +\begingroup\defname {#2}{Instance Variable of #1}% +\defvarargs {#3}\endgroup % +} + +% These definitions are run if you use @defmethodx, etc., +% anywhere other than immediately after a @defmethod, etc. + +\def\defopx #1 {\errmessage{@defopx in invalid context}} +\def\defmethodx #1 {\errmessage{@defmethodx in invalid context}} +\def\defcvx #1 {\errmessage{@defcvx in invalid context}} +\def\defivarx #1 {\errmessage{@defivarx in invalid context}} + +% Now @defvar + +% First, define the processing that is wanted for arguments of @defvar. +% This is actually simple: just print them in roman. +% This must expand the args and terminate the paragraph they make up +\def\defvarargs #1{\normalparens #1% +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000} + +% @defvr Counter foo-count + +\def\defvr{\defvrparsebody\Edefvr\defvrx\defvrheader} + +\def\defvrheader #1#2#3{\doind {vr}{\code{#2}}% +\begingroup\defname {#2}{#1}\defvarargs{#3}\endgroup} + +% @defvar == @defvr Variable + +\def\defvar{\defvarparsebody\Edefvar\defvarx\defvarheader} + +\def\defvarheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index +\begingroup\defname {#1}{Variable}% +\defvarargs {#2}\endgroup % +} + +% @defopt == @defvr {User Option} + +\def\defopt{\defvarparsebody\Edefopt\defoptx\defoptheader} + +\def\defoptheader #1#2{\doind {vr}{\code{#1}}% Make entry in var index +\begingroup\defname {#1}{User Option}% +\defvarargs {#2}\endgroup % +} + +% @deftypevar int foobar + +\def\deftypevar{\defvarparsebody\Edeftypevar\deftypevarx\deftypevarheader} + +% #1 is the data type. #2 is the name. +\def\deftypevarheader #1#2{% +\doind {vr}{\code{#2}}% Make entry in variables index +\begingroup\defname {\defheaderxcond#1\relax$$$#2}{Variable}% +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000 +\endgroup} + +% @deftypevr {Global Flag} int enable + +\def\deftypevr{\defvrparsebody\Edeftypevr\deftypevrx\deftypevrheader} + +\def\deftypevrheader #1#2#3{\doind {vr}{\code{#3}}% +\begingroup\defname {\defheaderxcond#2\relax$$$#3}{#1} +\interlinepenalty=10000 +\endgraf\penalty 10000\vskip -\parskip\penalty 10000 +\endgroup} + +% This definition is run if you use @defvarx +% anywhere other than immediately after a @defvar or @defvarx. + +\def\defvrx #1 {\errmessage{@defvrx in invalid context}} +\def\defvarx #1 {\errmessage{@defvarx in invalid context}} +\def\defoptx #1 {\errmessage{@defoptx in invalid context}} +\def\deftypevarx #1 {\errmessage{@deftypevarx in invalid context}} +\def\deftypevrx #1 {\errmessage{@deftypevrx in invalid context}} + +% Now define @deftp +% Args are printed in bold, a slight difference from @defvar. + +\def\deftpargs #1{\bf \defvarargs{#1}} + +% @deftp Class window height width ... + +\def\deftp{\deftpparsebody\Edeftp\deftpx\deftpheader} + +\def\deftpheader #1#2#3{\doind {tp}{\code{#2}}% +\begingroup\defname {#2}{#1}\deftpargs{#3}\endgroup} + +% This definition is run if you use @deftpx, etc +% anywhere other than immediately after a @deftp, etc. + +\def\deftpx #1 {\errmessage{@deftpx in invalid context}} + +\message{cross reference,} +% Define cross-reference macros +\newwrite \auxfile + +\newif\ifhavexrefs % True if xref values are known. +\newif\ifwarnedxrefs % True if we warned once that they aren't known. + +% \setref{foo} defines a cross-reference point named foo. + +\def\setref#1{% +\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Ysectionnumberandtype}} + +\def\unnumbsetref#1{% +\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Ynothing}} + +\def\appendixsetref#1{% +\dosetq{#1-title}{Ytitle}% +\dosetq{#1-pg}{Ypagenumber}% +\dosetq{#1-snt}{Yappendixletterandtype}} + +% \xref, \pxref, and \ref generate cross-references to specified points. +% For \xrefX, #1 is the node name, #2 the name of the Info +% cross-reference, #3 the printed node name, #4 the name of the Info +% file, #5 the name of the printed manual. All but the node name can be +% omitted. +% +\def\pxref#1{\putwordsee{} \xrefX[#1,,,,,,,]} +\def\xref#1{\putwordSee{} \xrefX[#1,,,,,,,]} +\def\ref#1{\xrefX[#1,,,,,,,]} +\def\xrefX[#1,#2,#3,#4,#5,#6]{\begingroup + \def\printedmanual{\ignorespaces #5}% + \def\printednodename{\ignorespaces #3}% + \setbox1=\hbox{\printedmanual}% + \setbox0=\hbox{\printednodename}% + \ifdim \wd0 = 0pt + % No printed node name was explicitly given. + \ifx\SETxref-automatic-section-title\relax % + % Use the actual chapter/section title appear inside + % the square brackets. Use the real section title if we have it. + \ifdim \wd1>0pt% + % It is in another manual, so we don't have it. + \def\printednodename{\ignorespaces #1}% + \else + \ifhavexrefs + % We know the real title if we have the xref values. + \def\printednodename{\refx{#1-title}}% + \else + % Otherwise just copy the Info node name. + \def\printednodename{\ignorespaces #1}% + \fi% + \fi + \def\printednodename{#1-title}% + \else + % Use the node name inside the square brackets. + \def\printednodename{\ignorespaces #1}% + \fi + \fi + % + % If we use \unhbox0 and \unhbox1 to print the node names, TeX does not + % insert empty discretionaries after hyphens, which means that it will + % not find a line break at a hyphen in a node names. Since some manuals + % are best written with fairly long node names, containing hyphens, this + % is a loss. Therefore, we give the text of the node name again, so it + % is as if TeX is seeing it for the first time. + \ifdim \wd1 > 0pt + \putwordsection{} ``\printednodename'' in \cite{\printedmanual}% + \else + % _ (for example) has to be the character _ for the purposes of the + % control sequence corresponding to the node, but it has to expand + % into the usual \leavevmode...\vrule stuff for purposes of + % printing. So we \turnoffactive for the \refx-snt, back on for the + % printing, back off for the \refx-pg. + {\turnoffactive \refx{#1-snt}{}}% + \space [\printednodename],\space + \turnoffactive \putwordpage\tie\refx{#1-pg}{}% + \fi +\endgroup} + +% \dosetq is the interface for calls from other macros + +% Use \turnoffactive so that punctuation chars such as underscore +% work in node names. +\def\dosetq #1#2{{\let\folio=0 \turnoffactive \auxhat% +\edef\next{\write\auxfile{\internalsetq {#1}{#2}}}% +\next}} + +% \internalsetq {foo}{page} expands into +% CHARACTERS 'xrdef {foo}{...expansion of \Ypage...} +% When the aux file is read, ' is the escape character + +\def\internalsetq #1#2{'xrdef {#1}{\csname #2\endcsname}} + +% Things to be expanded by \internalsetq + +\def\Ypagenumber{\folio} + +\def\Ytitle{\thissection} + +\def\Ynothing{} + +\def\Ysectionnumberandtype{% +\ifnum\secno=0 \putwordChapter\xreftie\the\chapno % +\else \ifnum \subsecno=0 \putwordSection\xreftie\the\chapno.\the\secno % +\else \ifnum \subsubsecno=0 % +\putwordSection\xreftie\the\chapno.\the\secno.\the\subsecno % +\else % +\putwordSection\xreftie\the\chapno.\the\secno.\the\subsecno.\the\subsubsecno % +\fi \fi \fi } + +\def\Yappendixletterandtype{% +\ifnum\secno=0 \putwordAppendix\xreftie'char\the\appendixno{}% +\else \ifnum \subsecno=0 \putwordSection\xreftie'char\the\appendixno.\the\secno % +\else \ifnum \subsubsecno=0 % +\putwordSection\xreftie'char\the\appendixno.\the\secno.\the\subsecno % +\else % +\putwordSection\xreftie'char\the\appendixno.\the\secno.\the\subsecno.\the\subsubsecno % +\fi \fi \fi } + +\gdef\xreftie{'tie} + +% Use TeX 3.0's \inputlineno to get the line number, for better error +% messages, but if we're using an old version of TeX, don't do anything. +% +\ifx\inputlineno\thisisundefined + \let\linenumber = \empty % Non-3.0. +\else + \def\linenumber{\the\inputlineno:\space} +\fi + +% Define \refx{NAME}{SUFFIX} to reference a cross-reference string named NAME. +% If its value is nonempty, SUFFIX is output afterward. + +\def\refx#1#2{% + \expandafter\ifx\csname X#1\endcsname\relax + % If not defined, say something at least. + $\langle$un\-de\-fined$\rangle$% + \ifhavexrefs + \message{\linenumber Undefined cross reference `#1'.}% + \else + \ifwarnedxrefs\else + \global\warnedxrefstrue + \message{Cross reference values unknown; you must run TeX again.}% + \fi + \fi + \else + % It's defined, so just use it. + \csname X#1\endcsname + \fi + #2% Output the suffix in any case. +} + +% Read the last existing aux file, if any. No error if none exists. + +% This is the macro invoked by entries in the aux file. +\def\xrdef #1#2{ +{\catcode`\'=\other\expandafter \gdef \csname X#1\endcsname {#2}}} + +\def\readauxfile{% +\begingroup +\catcode `\^^@=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\^^C=\other +\catcode `\^^D=\other +\catcode `\^^E=\other +\catcode `\^^F=\other +\catcode `\^^G=\other +\catcode `\^^H=\other +\catcode `\ =\other +\catcode `\^^L=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode `\=\other +\catcode 26=\other +\catcode `\^^[=\other +\catcode `\^^\=\other +\catcode `\^^]=\other +\catcode `\^^^=\other +\catcode `\^^_=\other +\catcode `\@=\other +\catcode `\^=\other +\catcode `\~=\other +\catcode `\[=\other +\catcode `\]=\other +\catcode`\"=\other +\catcode`\_=\other +\catcode`\|=\other +\catcode`\<=\other +\catcode`\>=\other +\catcode `\$=\other +\catcode `\#=\other +\catcode `\&=\other +% `\+ does not work, so use 43. +\catcode 43=\other +% Make the characters 128-255 be printing characters +{% + \count 1=128 + \def\loop{% + \catcode\count 1=\other + \advance\count 1 by 1 + \ifnum \count 1<256 \loop \fi + }% +}% +% the aux file uses ' as the escape. +% Turn off \ as an escape so we do not lose on +% entries which were dumped with control sequences in their names. +% For example, 'xrdef {$\leq $-fun}{page ...} made by @defun ^^ +% Reference to such entries still does not work the way one would wish, +% but at least they do not bomb out when the aux file is read in. +\catcode `\{=1 \catcode `\}=2 +\catcode `\%=\other +\catcode `\'=0 +\catcode`\^=7 % to make ^^e4 etc usable in xref tags +\catcode `\\=\other +\openin 1 \jobname.aux +\ifeof 1 \else \closein 1 \input \jobname.aux \global\havexrefstrue +\global\warnedobstrue +\fi +% Open the new aux file. Tex will close it automatically at exit. +\openout \auxfile=\jobname.aux +\endgroup} + + +% Footnotes. + +\newcount \footnoteno + +% The trailing space in the following definition for supereject is +% vital for proper filling; pages come out unaligned when you do a +% pagealignmacro call if that space before the closing brace is +% removed. +\def\supereject{\par\penalty -20000\footnoteno =0 } + +% @footnotestyle is meaningful for info output only.. +\let\footnotestyle=\comment + +\let\ptexfootnote=\footnote + +{\catcode `\@=11 +% +% Auto-number footnotes. Otherwise like plain. +\gdef\footnote{% + \global\advance\footnoteno by \@ne + \edef\thisfootno{$^{\the\footnoteno}$}% + % + % In case the footnote comes at the end of a sentence, preserve the + % extra spacing after we do the footnote number. + \let\@sf\empty + \ifhmode\edef\@sf{\spacefactor\the\spacefactor}\/\fi + % + % Remove inadvertent blank space before typesetting the footnote number. + \unskip + \thisfootno\@sf + \footnotezzz +}% + +% Don't bother with the trickery in plain.tex to not require the +% footnote text as a parameter. Our footnotes don't need to be so general. +% +\long\gdef\footnotezzz#1{\insert\footins{% + % We want to typeset this text as a normal paragraph, even if the + % footnote reference occurs in (for example) a display environment. + % So reset some parameters. + \interlinepenalty\interfootnotelinepenalty + \splittopskip\ht\strutbox % top baseline for broken footnotes + \splitmaxdepth\dp\strutbox + \floatingpenalty\@MM + \leftskip\z@skip + \rightskip\z@skip + \spaceskip\z@skip + \xspaceskip\z@skip + \parindent\defaultparindent + % + % Hang the footnote text off the number. + \hang + \textindent{\thisfootno}% + % + % Don't crash into the line above the footnote text. Since this + % expands into a box, it must come within the paragraph, lest it + % provide a place where TeX can split the footnote. + \footstrut + #1\strut}% +} + +}%end \catcode `\@=11 + +% Set the baselineskip to #1, and the lineskip and strut size +% correspondingly. There is no deep meaning behind these magic numbers +% used as factors; they just match (closely enough) what Knuth defined. +% +\def\lineskipfactor{.08333} +\def\strutheightpercent{.70833} +\def\strutdepthpercent {.29167} +% +\def\setleading#1{% + \normalbaselineskip = #1\relax + \normallineskip = \lineskipfactor\normalbaselineskip + \normalbaselines + \setbox\strutbox =\hbox{% + \vrule width0pt height\strutheightpercent\baselineskip + depth \strutdepthpercent \baselineskip + }% +} + +% @| inserts a changebar to the left of the current line. It should +% surround any changed text. This approach does *not* work if the +% change spans more than two lines of output. To handle that, we would +% have adopt a much more difficult approach (putting marks into the main +% vertical list for the beginning and end of each change). +% +\def\|{% + % \vadjust can only be used in horizontal mode. + \leavevmode + % + % Append this vertical mode material after the current line in the output. + \vadjust{% + % We want to insert a rule with the height and depth of the current + % leading; that is exactly what \strutbox is supposed to record. + \vskip-\baselineskip + % + % \vadjust-items are inserted at the left edge of the type. So + % the \llap here moves out into the left-hand margin. + \llap{% + % + % For a thicker or thinner bar, change the `1pt'. + \vrule height\baselineskip width1pt + % + % This is the space between the bar and the text. + \hskip 12pt + }% + }% +} + +% For a final copy, take out the rectangles +% that mark overfull boxes (in case you have decided +% that the text looks ok even though it passes the margin). +% +\def\finalout{\overfullrule=0pt} + + +% End of control word definitions. + +\message{and turning on texinfo input format.} + +\def\openindices{% + \newindex{cp}% + \newcodeindex{fn}% + \newcodeindex{vr}% + \newcodeindex{tp}% + \newcodeindex{ky}% + \newcodeindex{pg}% +} + +% Set some numeric style parameters, for 8.5 x 11 format. + +%\hsize = 6.5in +\newdimen\defaultparindent \defaultparindent = 15pt +\parindent = \defaultparindent +\parskip 18pt plus 1pt +\setleading{15pt} +\advance\topskip by 1.2cm + +% Prevent underfull vbox error messages. +\vbadness=10000 + +% Following George Bush, just get rid of widows and orphans. +\widowpenalty=10000 +\clubpenalty=10000 + +% Use TeX 3.0's \emergencystretch to help line breaking, but if we're +% using an old version of TeX, don't do anything. We want the amount of +% stretch added to depend on the line length, hence the dependence on +% \hsize. This makes it come to about 9pt for the 8.5x11 format. +% +\ifx\emergencystretch\thisisundefined + % Allow us to assign to \emergencystretch anyway. + \def\emergencystretch{\dimen0}% +\else + \emergencystretch = \hsize + \divide\emergencystretch by 45 +\fi + +% Use @smallbook to reset parameters for 7x9.5 format (or else 7x9.25) +\def\smallbook{ + +% These values for secheadingskip and subsecheadingskip are +% experiments. RJC 7 Aug 1992 +% was 17pt and 14pt plus 6pt minus 3pt +\global\secheadingskip = 0pt plus 4pt minus 4pt +\global\subsecheadingskip = 0pt plus 4pt minus 4pt + +\global\lispnarrowing = 0.3in +\setleading{12pt} +\advance\topskip by -1cm +\global\parskip 3pt plus 1pt +\global\hsize = 5in +\global\vsize=7.5in +\global\tolerance=700 +\global\hfuzz=1pt +\global\contentsrightmargin=0pt +\global\deftypemargin=0pt +\global\defbodyindent=.5cm + +\global\pagewidth=\hsize +\global\pageheight=\vsize + +\global\let\smalllisp=\smalllispx +\global\let\smallexample=\smalllispx +\global\def\Esmallexample{\Esmalllisp} +} + +% Use @afourpaper to print on European A4 paper. +\def\afourpaper{ +\global\tolerance=700 +\global\hfuzz=1pt +\setleading{12pt} +\global\parskip 15pt plus 1pt + +\global\vsize= 53\baselineskip +\advance\vsize by \topskip +%\global\hsize= 5.85in % A4 wide 10pt +\global\hsize= 6.5in +\global\outerhsize=\hsize +\global\advance\outerhsize by 0.5in +\global\outervsize=\vsize +\global\advance\outervsize by 0.6in + +\global\pagewidth=\hsize +\global\pageheight=\vsize +} + +% Allow control of the text dimensions. Parameters in order: textheight; +% textwidth; \voffset; \hoffset (!); binding offset. All require a dimension; +% header is additional; added length extends the bottom of the page. + +\def\changepagesizes#1#2#3#4#5{ + \global\vsize= #1 + \advance\vsize by \topskip + \global\voffset= #3 + \global\hsize= #2 + \global\outerhsize=\hsize + \global\advance\outerhsize by 0.5in + \global\outervsize=\vsize + \global\advance\outervsize by 0.6in + \global\pagewidth=\hsize + \global\pageheight=\vsize + \global\normaloffset= #4 + \global\bindingoffset= #5} + +% This layout is compatible with Latex on A4 paper. + +\def\afourlatex{\changepagesizes{22cm}{15cm}{7mm}{4.6mm}{5mm}} + +% Use @afourwide to print on European A4 paper in wide format. +\def\afourwide{\afourpaper +\changepagesizes{9.5in}{6.5in}{\hoffset}{\normaloffset}{\bindingoffset}} + +% Define macros to output various characters with catcode for normal text. +\catcode`\"=\other +\catcode`\~=\other +\catcode`\^=\other +\catcode`\_=\other +\catcode`\|=\other +\catcode`\<=\other +\catcode`\>=\other +\catcode`\+=\other +\def\normaldoublequote{"} +\def\normaltilde{~} +\def\normalcaret{^} +\def\normalunderscore{_} +\def\normalverticalbar{|} +\def\normalless{<} +\def\normalgreater{>} +\def\normalplus{+} + +% This macro is used to make a character print one way in ttfont +% where it can probably just be output, and another way in other fonts, +% where something hairier probably needs to be done. +% +% #1 is what to print if we are indeed using \tt; #2 is what to print +% otherwise. Since all the Computer Modern typewriter fonts have zero +% interword stretch (and shrink), and it is reasonable to expect all +% typewriter fonts to have this, we can check that font parameter. +% +\def\ifusingtt#1#2{\ifdim \fontdimen3\the\font=0pt #1\else #2\fi} + +% Turn off all special characters except @ +% (and those which the user can use as if they were ordinary). +% Most of these we simply print from the \tt font, but for some, we can +% use math or other variants that look better in normal text. + +\catcode`\"=\active +\def\activedoublequote{{\tt \char '042}} +\let"=\activedoublequote +\catcode`\~=\active +\def~{{\tt \char '176}} +\chardef\hat=`\^ +\catcode`\^=\active +\def\auxhat{\def^{'hat}} +\def^{{\tt \hat}} + +\catcode`\_=\active +\def_{\ifusingtt\normalunderscore\_} +% Subroutine for the previous macro. +\def\_{\lvvmode \kern.06em \vbox{\hrule width.3em height.1ex}} + +% \lvvmode is equivalent in function to \leavevmode. +% Using \leavevmode runs into trouble when written out to +% an index file due to the expansion of \leavevmode into ``\unhbox +% \voidb@x'' ---which looks to TeX like ``\unhbox \voidb\x'' due to our +% magic tricks with @. +\def\lvvmode{\vbox to 0pt{}} + +\catcode`\|=\active +\def|{{\tt \char '174}} +\chardef \less=`\< +\catcode`\<=\active +\def<{{\tt \less}} +\chardef \gtr=`\> +\catcode`\>=\active +\def>{{\tt \gtr}} +\catcode`\+=\active +\def+{{\tt \char 43}} +%\catcode 27=\active +%\def^^[{$\diamondsuit$} + +% Set up an active definition for =, but don't enable it most of the time. +{\catcode`\==\active +\global\def={{\tt \char 61}}} + +\catcode`+=\active +\catcode`\_=\active + +% If a .fmt file is being used, characters that might appear in a file +% name cannot be active until we have parsed the command line. +% So turn them off again, and have \everyjob (or @setfilename) turn them on. +% \otherifyactive is called near the end of this file. +\def\otherifyactive{\catcode`+=\other \catcode`\_=\other} + +\catcode`\@=0 + +% \rawbackslashxx output one backslash character in current font +\global\chardef\rawbackslashxx=`\\ +%{\catcode`\\=\other +%@gdef@rawbackslashxx{\}} + +% \rawbackslash redefines \ as input to do \rawbackslashxx. +{\catcode`\\=\active +@gdef@rawbackslash{@let\=@rawbackslashxx }} + +% \normalbackslash outputs one backslash in fixed width font. +\def\normalbackslash{{\tt\rawbackslashxx}} + +% Say @foo, not \foo, in error messages. +\escapechar=`\@ + +% \catcode 17=0 % Define control-q +\catcode`\\=\active + +% Used sometimes to turn off (effectively) the active characters +% even after parsing them. +@def@turnoffactive{@let"=@normaldoublequote +@let\=@realbackslash +@let~=@normaltilde +@let^=@normalcaret +@let_=@normalunderscore +@let|=@normalverticalbar +@let<=@normalless +@let>=@normalgreater +@let+=@normalplus} + +@def@normalturnoffactive{@let"=@normaldoublequote +@let\=@normalbackslash +@let~=@normaltilde +@let^=@normalcaret +@let_=@normalunderscore +@let|=@normalverticalbar +@let<=@normalless +@let>=@normalgreater +@let+=@normalplus} + +% Make _ and + \other characters, temporarily. +% This is canceled by @fixbackslash. +@otherifyactive + +% If a .fmt file is being used, we don't want the `\input texinfo' to show up. +% That is what \eatinput is for; after that, the `\' should revert to printing +% a backslash. +% +@gdef@eatinput input texinfo{@fixbackslash} +@global@let\ = @eatinput + +% On the other hand, perhaps the file did not have a `\input texinfo'. Then +% the first `\{ in the file would cause an error. This macro tries to fix +% that, assuming it is called before the first `\' could plausibly occur. +% Also back turn on active characters that might appear in the input +% file name, in case not using a pre-dumped format. +% +@gdef@fixbackslash{@ifx\@eatinput @let\ = @normalbackslash @fi + @catcode`+=@active @catcode`@_=@active} + +%% These look ok in all fonts, so just make them not special. The @rm below +%% makes sure that the current font starts out as the newly loaded cmr10 +@catcode`@$=@other @catcode`@%=@other @catcode`@&=@other @catcode`@#=@other + +@textfonts +@rm + +@c Local variables: +@c page-delimiter: "^\\\\message" +@c End: diff --git a/examples/ChangeLog b/examples/ChangeLog new file mode 100644 index 00000000..c41d21b4 --- /dev/null +++ b/examples/ChangeLog @@ -0,0 +1,15 @@ +Sun Aug 9 11:16:13 1998 Ben Pfaff + + * descriptives.stat: Renamed descript.stat. + +Sat Aug 8 00:28:24 1998 Ben Pfaff + + * New directory. + + * descriptives.stat: New file. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/examples/descript.stat b/examples/descript.stat new file mode 100644 index 00000000..2f2ad562 --- /dev/null +++ b/examples/descript.stat @@ -0,0 +1,29 @@ +title 'Demonstrate DESCRIPTIVES procedure'. + +remark EOF + Sample syntax file for PSPP. + (This comment will appear in the output.) +EOF + +/* run this syntax file with the command: +/* pspp example.stat +/* +/* Output is written to the file "pspp.list". +/* +/* (This comment will not appear in the output.) + +data list / v0 to v2 1-9. +begin data. + 12 12 89 + 34 12 80 + 56 12 77 + 78 12 73 + 90 91 + 37 97 85 + 52 82 + 12 79 + 26 78 76 + 29 13 71 +end data. + +descript all/stat=all/format=serial. diff --git a/intl/ChangeLog b/intl/ChangeLog new file mode 100644 index 00000000..743b3f5a --- /dev/null +++ b/intl/ChangeLog @@ -0,0 +1,1026 @@ +Thu Oct 9 13:41:22 1997 Ben Pfaff + + * Makefile.in: (INCLUDES) Add -I$(top_srcdir)/src. + +1997-09-06 02:10 Ulrich Drepper + + * intlh.inst.in: Reformat copyright. + +1997-08-19 15:22 Ulrich Drepper + + * dcgettext.c (DCGETTEXT): Remove wrong comment. + +1997-08-16 00:13 Ulrich Drepper + + * Makefile.in (install-data): Don't change directory to install. + +1997-08-01 14:30 Ulrich Drepper + + * cat-compat.c: Fix copyright. + + * localealias.c: Don't define strchr unless !HAVE_STRCHR. + + * loadmsgcat.c: Update copyright. Fix typos. + + * l10nflist.c: Don't define strchr unless !HAVE_STRCHR. + (_nl_make_l10nflist): Handle sponsor and revision correctly. + + * gettext.c: Update copyright. + * gettext.h: Likewise. + * hash-string.h: Likewise. + + * finddomain.c: Remoave dead code. Define strchr only if + !HAVE_STRCHR. + + * explodename.c: Include . + + * explodename.c: Reformat copyright text. + (_nl_explode_name): Fix typo. + + * dcgettext.c: Define and use __set_errno. + (guess_category_value): Don't use setlocale if HAVE_LC_MESSAGES is + not defined. + + * bindtextdom.c: Pretty printing. + +1997-05-01 02:25 Ulrich Drepper + + * dcgettext.c (guess_category_value): Don't depend on + HAVE_LC_MESSAGES. We don't need the macro here. + Patch by Bruno Haible . + + * cat-compat.c (textdomain): DoN't refer to HAVE_SETLOCALE_NULL + macro. Instead use HAVE_LOCALE_NULL and define it when using + glibc, as in dcgettext.c. + Patch by Bruno Haible . + + * Makefile.in (CPPFLAGS): New variable. Reported by Franc,ois + Pinard. + +Mon Mar 10 06:51:17 1997 Ulrich Drepper + + * Makefile.in: Implement handling of libtool. + + * gettextP.h: Change data structures for use of generic lowlevel + i18n file handling. + +Wed Dec 4 20:21:18 1996 Ulrich Drepper + + * textdomain.c: Put parentheses around arguments of memcpy macro + definition. + * localealias.c: Likewise. + * l10nflist.c: Likewise. + * finddomain.c: Likewise. + * bindtextdom.c: Likewise. + Reported by Thomas Esken. + +Mon Nov 25 22:57:51 1996 Ulrich Drepper + + * textdomain.c: Move definition of `memcpy` macro to right + position. + +Fri Nov 22 04:01:58 1996 Ulrich Drepper + + * finddomain.c [!HAVE_STRING_H && !_LIBC]: Define memcpy using + bcopy if not already defined. Reported by Thomas Esken. + * bindtextdom.c: Likewise. + * l10nflist.c: Likewise. + * localealias.c: Likewise. + * textdomain.c: Likewise. + +Tue Oct 29 11:10:27 1996 Ulrich Drepper + + * Makefile.in (libdir): Change to use exec_prefix instead of + prefix. Reported by Knut-HåvardAksnes . + +Sat Aug 31 03:07:09 1996 Ulrich Drepper + + * l10nflist.c (_nl_normalize_codeset): We convert to lower case, + so don't prepend uppercase `ISO' for only numeric arg. + +Fri Jul 19 00:15:46 1996 Ulrich Drepper + + * l10nflist.c: Move inclusion of argz.h, ctype.h, stdlib.h after + definition of _GNU_SOURCE. Patch by Roland McGrath. + + * Makefile.in (uninstall): Fix another bug with `for' loop and + empty arguments. Patch by Jim Meyering. Correct name os + uninstalled files: no intl- prefix anymore. + + * Makefile.in (install-data): Again work around shells which + cannot handle mpty for list. Reported by Jim Meyering. + +Sat Jul 13 18:11:35 1996 Ulrich Drepper + + * Makefile.in (install): Split goal. Now depend on install-exec + and install-data. + (install-exec, install-data): New goals. Created from former + install goal. + Reported by Karl Berry. + +Sat Jun 22 04:58:14 1996 Ulrich Drepper + + * Makefile.in (MKINSTALLDIRS): New variable. Path to + mkinstalldirs script. + (install): use MKINSTALLDIRS variable or if the script is not present + try to find it in the $top_scrdir). + +Wed Jun 19 02:56:56 1996 Ulrich Drepper + + * l10nflist.c: Linux libc *partly* includes the argz_* functions. + Grr. Work around by renaming the static version and use macros + for renaming. + +Tue Jun 18 20:11:17 1996 Ulrich Drepper + + * l10nflist.c: Correct presence test macros of __argz_* functions. + + * l10nflist.c: Include based on test of it instead when + __argz_* functions are available. + Reported by Andreas Schwab. + +Thu Jun 13 15:17:44 1996 Ulrich Drepper + + * explodename.c, l10nflist.c: Define NULL for dumb systems. + +Tue Jun 11 17:05:13 1996 Ulrich Drepper + + * intlh.inst.in, libgettext.h (dcgettext): Rename local variable + result to __result to prevent name clash. + + * l10nflist.c, localealias.c, dcgettext.c: Define _GNU_SOURCE to + get prototype for stpcpy and strcasecmp. + + * intlh.inst.in, libgettext.h: Move declaration of + `_nl_msg_cat_cntr' outside __extension__ block to prevent warning + from gcc's -Wnested-extern option. + +Fri Jun 7 01:58:00 1996 Ulrich Drepper + + * Makefile.in (install): Remove comment. + +Thu Jun 6 17:28:17 1996 Ulrich Drepper + + * Makefile.in (install): Work around for another Buglix stupidity. + Always use an `else' close for `if's. Reported by Nelson Beebe. + + * Makefile.in (intlh.inst): Correct typo in phony rule. + Reported by Nelson Beebe. + +Thu Jun 6 01:49:52 1996 Ulrich Drepper + + * dcgettext.c (read_alias_file): Rename variable alloca_list to + block_list as the macro calls assume. + Patch by Eric Backus. + + * localealias.c [!HAVE_ALLOCA]: Define alloca as macro using + malloc. + (read_alias_file): Rename varriabe alloca_list to block_list as the + macro calls assume. + Patch by Eric Backus. + + * l10nflist.c: Correct conditional for inclusion. + Reported by Roland McGrath. + + * Makefile.in (all): Depend on all-@USE_INCLUDED_LIBINTL@, not + all-@USE_NLS@. + + * Makefile.in (install): intlh.inst comes from local dir, not + $(srcdir). + + * Makefile.in (intlh.inst): Special handling of this goal. If + used in gettext, this is really a rul to construct this file. If + used in any other package it is defined as a .PHONY rule with + empty body. + + * finddomain.c: Extract locale file information handling into + l10nfile.c. Rename local stpcpy__ function to stpcpy. + + * dcgettext.c (stpcpy): Add local definition. + + * l10nflist.c: Solve some portability problems. Patches partly by + Thomas Esken. Add local definition of stpcpy. + +Tue Jun 4 02:47:49 1996 Ulrich Drepper + + * intlh.inst.in: Don't depend including on + HAVE_LOCALE_H. Instead configure must rewrite this fiile + depending on the result of the configure run. + + * Makefile.in (install): libintl.inst is now called intlh.inst. + Add rules for updating intlh.inst from intlh.inst.in. + + * libintl.inst: Renamed to intlh.inst.in. + + * localealias.c, dcgettext.c [__GNUC__]: Define HAVE_ALLOCA to 1 + because gcc has __buitlin_alloca. + Reported by Roland McGrath. + +Mon Jun 3 00:32:16 1996 Ulrich Drepper + + * Makefile.in (installcheck): New goal to fulfill needs of + automake's distcheck. + + * Makefile.in (install): Reorder commands so that VERSION is + found. + + * Makefile.in (gettextsrcdir): Now use subdirectory intl/ in + @datadir@/gettext. + (COMSRCS): Add l10nfile.c. + (OBJECTS): Add l10nfile.o. + (DISTFILES): Rename to DISTFILE.normal. Remove $(DISTFILES.common). + (DISTFILE.gettext): Remove $(DISTFILES.common). + (all-gettext): Remove goal. + (install): If $(PACKAGE) = gettext install, otherwose do nothing. No + package but gettext itself should install libintl.h + headers. + (dist): Extend goal to work for gettext, too. + (dist-gettext): Remove goal. + + * dcgettext.c [!HAVE_ALLOCA]: Define macro alloca by using malloc. + +Sun Jun 2 17:33:06 1996 Ulrich Drepper + + * loadmsgcat.c (_nl_load_domain): Parameter is now comes from + find_l10nfile. + +Sat Jun 1 02:23:03 1996 Ulrich Drepper + + * l10nflist.c (__argz_next): Add definition. + + * dcgettext.c [!HAVE_ALLOCA]: Add code for handling missing alloca + code. Use new l10nfile handling. + + * localealias.c [!HAVE_ALLOCA]: Add code for handling missing + alloca code. + + * l10nflist.c: Initial revision. + +Tue Apr 2 18:51:18 1996 Ulrich Drepper + + * Makefile.in (all-gettext): New goal. Same as all-yes. + +Thu Mar 28 23:01:22 1996 Karl Eichwalder + + * Makefile.in (gettextsrcdir): Define using @datadir@. + +Tue Mar 26 12:39:14 1996 Ulrich Drepper + + * finddomain.c: Include . Reported by Roland McGrath. + +Sat Mar 23 02:00:35 1996 Ulrich Drepper + + * finddomain.c (stpcpy): Rename to stpcpy__ to prevent clashing + with external declaration. + +Sat Mar 2 00:47:09 1996 Ulrich Drepper + + * Makefile.in (all-no): Rename from all_no. + +Sat Feb 17 00:25:59 1996 Ulrich Drepper + + * gettextP.h [loaded_domain]: Array `successor' must now contain up + to 63 elements (because of codeset name normalization). + + * finddomain.c: Implement codeset name normalization. + +Thu Feb 15 04:39:09 1996 Ulrich Drepper + + * Makefile.in (all): Define to `all-@USE_NLS@'. + (all-yes, all_no): New goals. `all-no' is noop, `all-yes' + is former all. + +Mon Jan 15 21:46:01 1996 Howard Gayle + + * localealias.c (alias_compare): Increment string pointers in loop + of strcasecmp replacement. + +Fri Dec 29 21:16:34 1995 Ulrich Drepper + + * Makefile.in (install-src): Who commented this goal out ? :-) + +Fri Dec 29 15:08:16 1995 Ulrich Drepper + + * dcgettext.c (DCGETTEXT): Save `errno'. Failing system calls + should not effect it because a missing catalog is no error. + Reported by Harald Knig . + +Tue Dec 19 22:09:13 1995 Ulrich Drepper + + * Makefile.in (Makefile): Explicitly use $(SHELL) for running + shell scripts. + +Fri Dec 15 17:34:59 1995 Andreas Schwab + + * Makefile.in (install-src): Only install library and header when + we use the own implementation. Don't do it when using the + system's gettext or catgets functions. + + * dcgettext.c (find_msg): Must not swap domain->hash_size here. + +Sat Dec 9 16:24:37 1995 Ulrich Drepper + + * localealias.c, libintl.inst, libgettext.h, hash-string.h, + gettextP.h, finddomain.c, dcgettext.c, cat-compat.c: + Use PARAMS instead of __P. Suggested by Roland McGrath. + +Tue Dec 5 11:39:14 1995 Larry Schwimmer + + * libgettext.h: Use `#if !defined (_LIBINTL_H)' instead of `#if + !_LIBINTL_H' because Solaris defines _LIBINTL_H as empty. + +Mon Dec 4 15:42:07 1995 Ulrich Drepper + + * Makefile.in (install-src): + Install libintl.inst instead of libintl.h.install. + +Sat Dec 2 22:51:38 1995 Marcus Daniels + + * cat-compat.c (textdomain): + Reverse order in which files are tried you load. First + try local file, when this failed absolute path. + +Wed Nov 29 02:03:53 1995 Nelson H. F. Beebe + + * cat-compat.c (bindtextdomain): Add missing { }. + +Sun Nov 26 18:21:41 1995 Ulrich Drepper + + * libintl.inst: Add missing __P definition. Reported by Nelson Beebe. + + * Makefile.in: + Add dummy `all' and `dvi' goals. Reported by Tom Tromey. + +Sat Nov 25 16:12:01 1995 Franc,ois Pinard + + * hash-string.h: Capitalize arguments of macros. + +Sat Nov 25 12:01:36 1995 Ulrich Drepper + + * Makefile.in (DISTFILES): Prevent files names longer than 13 + characters. libintl.h.glibc->libintl.glibc, + libintl.h.install->libintl.inst. Reported by Joshua R. Poulson. + +Sat Nov 25 11:31:12 1995 Eric Backus + + * dcgettext.c: Fix bug in preprocessor conditionals. + +Sat Nov 25 02:35:27 1995 Nelson H. F. Beebe + + * libgettext.h: Solaris cc does not understand + #if !SYMBOL1 && !SYMBOL2. Sad but true. + +Thu Nov 23 16:22:14 1995 Ulrich Drepper + + * hash-string.h (hash_string): + Fix for machine with >32 bit `unsigned long's. + + * dcgettext.c (DCGETTEXT): + Fix horrible bug in loop for alternative translation. + +Thu Nov 23 01:45:29 1995 Ulrich Drepper + + * po2tbl.sed.in, linux-msg.sed, xopen-msg.sed: + Some further simplifications in message number generation. + +Mon Nov 20 21:08:43 1995 Ulrich Drepper + + * libintl.h.glibc: Use __const instead of const in prototypes. + + * Makefile.in (install-src): + Install libintl.h.install instead of libintl.h. This + is a stripped-down version. Suggested by Peter Miller. + + * libintl.h.install, libintl.h.glibc: Initial revision. + + * localealias.c (_nl_expand_alias, read_alias_file): + Protect prototypes in type casts by __P. + +Tue Nov 14 16:43:58 1995 Ulrich Drepper + + * hash-string.h: Correct prototype for hash_string. + +Sun Nov 12 12:42:30 1995 Ulrich Drepper + + * hash-string.h (hash_string): Add prototype. + + * gettextP.h: Fix copyright. + (SWAP): Add prototype. + +Wed Nov 8 22:56:33 1995 Ulrich Drepper + + * localealias.c (read_alias_file): Forgot sizeof. + Avoid calling *printf function. This introduces a big overhead. + Patch by Roland McGrath. + +Tue Nov 7 14:21:08 1995 Ulrich Drepper + + * finddomain.c, cat-compat.c: Wrong indentation in #if for stpcpy. + + * finddomain.c (stpcpy): + Define substitution function local. The macro was to flaky. + + * cat-compat.c: Fix typo. + + * xopen-msg.sed, linux-msg.sed: + While bringing message number to right place only accept digits. + + * linux-msg.sed, xopen-msg.sed: Now that the counter does not have + leading 0s we don't need to remove them. Reported by Marcus + Daniels. + + * Makefile.in (../po/cat-id-tbl.o): Use $(top_srdir) in + dependency. Reported by Marcus Daniels. + + * cat-compat.c: (stpcpy) [!_LIBC && !HAVE_STPCPY]: Define replacement. + Generally cleanup using #if instead of #ifndef. + + * Makefile.in: Correct typos in comment. By Franc,ois Pinard. + +Mon Nov 6 00:27:02 1995 Ulrich Drepper + + * Makefile.in (install-src): Don't install libintl.h and libintl.a + if we use an available gettext implementation. + +Sun Nov 5 22:02:08 1995 Ulrich Drepper + + * libgettext.h: Fix typo: HAVE_CATGETTS -> HAVE_CATGETS. Reported + by Franc,ois Pinard. + + * libgettext.h: Use #if instead of #ifdef/#ifndef. + + * finddomain.c: + Comments describing what has to be done should start with FIXME. + +Sun Nov 5 19:38:01 1995 Ulrich Drepper + + * Makefile.in (DISTFILES): Split. Use DISTFILES with normal meaning. + DISTFILES.common names the files common to both dist goals. + DISTFILES.gettext are the files only distributed in GNU gettext. + +Sun Nov 5 17:32:54 1995 Ulrich Drepper + + * dcgettext.c (DCGETTEXT): Correct searching in derived locales. + This was necessary since a change in _nl_find_msg several weeks + ago. I really don't know this is still not fixed. + +Sun Nov 5 12:43:12 1995 Ulrich Drepper + + * loadmsgcat.c (_nl_load_domain): Test for FILENAME == NULL. This + might mark a special condition. + + * finddomain.c (make_entry_rec): Don't make illegal entry as decided. + + * Makefile.in (dist): Suppress error message when ln failed. + Get files from $(srcdir) explicitly. + + * libgettext.h (gettext_const): Rename to gettext_noop. + +Fri Nov 3 07:36:50 1995 Ulrich Drepper + + * finddomain.c (make_entry_rec): + Protect against wrong locale names by testing mask. + + * libgettext.h (gettext_const): Add macro definition. + Capitalize macro arguments. + +Thu Nov 2 23:15:51 1995 Ulrich Drepper + + * finddomain.c (_nl_find_domain): + Test for pointer != NULL before accessing value. + Reported by Tom Tromey. + + * gettext.c (NULL): + Define as (void*)0 instad of 0. Reported by Franc,ois Pinard. + +Mon Oct 30 21:28:52 1995 Ulrich Drepper + + * po2tbl.sed.in: Serious typo bug fixed by Jim Meyering. + +Sat Oct 28 23:20:47 1995 Ulrich Drepper + + * libgettext.h: Disable dcgettext optimization for Solaris 2.3. + + * localealias.c (alias_compare): + Peter Miller reported that tolower in some systems is + even dumber than I thought. Protect call by `isupper'. + +Fri Oct 27 22:22:51 1995 Ulrich Drepper + + * Makefile.in (libdir, includedir): New variables. + (install-src): Install libintl.a and libintl.h in correct dirs. + +Fri Oct 27 22:07:29 1995 Ulrich Drepper + + * Makefile.in (SOURCES): Fix typo: intrl.compat.c -> intl-compat.c. + + * po2tbl.sed.in: Patch for buggy SEDs by Christian von Roques. + + * localealias.c: + Fix typo and superflous test. Reported by Christian von Roques. + +Fri Oct 6 11:52:05 1995 Ulrich Drepper + + * finddomain.c (_nl_find_domain): + Correct some remainder from the pre-CEN syntax. Now + we don't have a constant number of successors anymore. + +Wed Sep 27 21:41:13 1995 Ulrich Drepper + + * Makefile.in (DISTFILES): Add libintl.h.glibc. + + * Makefile.in (dist-libc): Add goal for packing sources for glibc. + (COMSRCS, COMHDRS): Splitted to separate sources shared with glibc. + + * loadmsgcat.c: Forget to continue #if line. + + * localealias.c: + [_LIBC]: Rename strcasecmp to __strcasecmp to keep ANSI C name + space clean. + + * dcgettext.c, finddomain.c: Better comment to last change. + + * loadmsgcat.c: + [_LIBC]: Rename fstat, open, close, read, mmap, and munmap to + __fstat, __open, __close, __read, __mmap, and __munmap resp + to keep ANSI C name space clean. + + * finddomain.c: + [_LIBC]: Rename stpcpy to __stpcpy to keep ANSI C name space clean. + + * dcgettext.c: + [_LIBC]: Rename getced and stpcpy to __getcwd and __stpcpy resp to + keep ANSI C name space clean. + + * libgettext.h: + Include sys/types.h for those old SysV systems out there. + Reported by Francesco Potorti`. + + * loadmsgcat.c (use_mmap): Define if compiled for glibc. + + * bindtextdom.c: Include all those standard headers + unconditionally if _LIBC is defined. + + * finddomain.c: Fix 2 times defiend -> defined. + + * textdomain.c: Include libintl.h instead of libgettext.h when + compiling for glibc. Include all those standard headers + unconditionally if _LIBC is defined. + + * localealias.c, loadmsgcat.c: Prepare to be compiled in glibc. + + * gettext.c: + Include libintl.h instead of libgettext.h when compiling for glibc. + Get NULL from stddef.h if we compile for glibc. + + * finddomain.c: Include libintl.h instead of libgettext.h when + compiling for glibc. Include all those standard headers + unconditionally if _LIBC is defined. + + * dcgettext.c: Include all those standard headers unconditionally + if _LIBC is defined. + + * dgettext.c: If compiled in glibc include libintl.h instead of + libgettext.h. + (locale.h): Don't rely on HAVE_LOCALE_H when compiling for glibc. + + * dcgettext.c: If compiled in glibc include libintl.h instead of + libgettext.h. + (getcwd): Don't rely on HAVE_GETCWD when compiling for glibc. + + * bindtextdom.c: + If compiled in glibc include libintl.h instead of libgettext.h. + +Mon Sep 25 22:23:06 1995 Ulrich Drepper + + * localealias.c (_nl_expand_alias): Don't call bsearch if NMAP <= 0. + Reported by Marcus Daniels. + + * cat-compat.c (bindtextdomain): + String used in putenv must not be recycled. + Reported by Marcus Daniels. + + * libgettext.h (__USE_GNU_GETTEXT): + Additional symbol to signal that we use GNU gettext + library. + + * cat-compat.c (bindtextdomain): + Fix bug with the strange stpcpy replacement. + Reported by Nelson Beebe. + +Sat Sep 23 08:23:51 1995 Ulrich Drepper + + * cat-compat.c: Include for stpcpy prototype. + + * localealias.c (read_alias_file): + While expand strdup code temporary variable `cp' hided + higher level variable with same name. Rename to `tp'. + + * textdomain.c (textdomain): + Avoid warning by using temporary variable in strdup code. + + * finddomain.c (_nl_find_domain): Remove unused variable `application'. + +Thu Sep 21 15:51:44 1995 Ulrich Drepper + + * localealias.c (alias_compare): + Use strcasecmp() only if available. Else use + implementation in place. + + * intl-compat.c: + Wrapper functions now call *__ functions instead of __*. + + * libgettext.h: Declare prototypes for *__ functions instead for __*. + + * cat-compat.c, loadmsgcat.c: + Don't use xmalloc, xstrdup, and stpcpy. These functions are not part + of the standard libc and so prevent libintl.a from being used + standalone. + + * bindtextdom.c: + Don't use xmalloc, xstrdup, and stpcpy. These functions are not part + of the standard libc and so prevent libintl.a from being used + standalone. + Rename to bindtextdomain__ if not used in GNU C Library. + + * dgettext.c: + Rename function to dgettext__ if not used in GNU C Library. + + * gettext.c: + Don't use xmalloc, xstrdup, and stpcpy. These functions are not part + of the standard libc and so prevent libintl.a from being used + standalone. + Functions now called gettext__ if not used in GNU C Library. + + * dcgettext.c, localealias.c, textdomain.c, finddomain.c: + Don't use xmalloc, xstrdup, and stpcpy. These functions are not part + of the standard libc and so prevent libintl.a from being used + standalone. + +Sun Sep 17 23:14:49 1995 Ulrich Drepper + + * finddomain.c: Correct some bugs in handling of CEN standard + locale definitions. + +Thu Sep 7 01:49:28 1995 Ulrich Drepper + + * finddomain.c: Implement CEN syntax. + + * gettextP.h (loaded_domain): Extend number of successors to 31. + +Sat Aug 19 19:25:29 1995 Ulrich Drepper + + * Makefile.in (aliaspath): Remove path to X11 locale dir. + + * Makefile.in: Make install-src depend on install. This helps + gettext to install the sources and other packages can use the + install goal. + +Sat Aug 19 15:19:33 1995 Ulrich Drepper + + * Makefile.in (uninstall): Remove stuff installed by install-src. + +Tue Aug 15 13:13:53 1995 Ulrich Drepper + + * VERSION.in: Initial revision. + + * Makefile.in (DISTFILES): + Add VERSION file. This is not necessary for gettext, but + for other packages using this library. + +Tue Aug 15 06:16:44 1995 Ulrich Drepper + + * gettextP.h (_nl_find_domain): + New prototype after changing search strategy. + + * finddomain.c (_nl_find_domain): + We now try only to find a specified catalog. Fall back to other + catalogs listed in the locale list is now done in __dcgettext. + + * dcgettext.c (__dcgettext): + Now we provide message fall back even to different languages. + I.e. if a message is not available in one language all the other + in the locale list a tried. Formerly fall back was only possible + within one language. Implemented by moving one loop from + _nl_find_domain to here. + +Mon Aug 14 23:45:50 1995 Ulrich Drepper + + * Makefile.in (gettextsrcdir): + Directory where source of GNU gettext library are made + available. + (INSTALL, INSTALL_DATA): Programs used for installing sources. + (gettext-src): New. Rule to install GNU gettext sources for use in + gettextize shell script. + +Sun Aug 13 14:40:48 1995 Ulrich Drepper + + * loadmsgcat.c (_nl_load_domain): + Use mmap for loading only when munmap function is + also available. + + * Makefile.in (install): Depend on `all' goal. + +Wed Aug 9 11:04:33 1995 Ulrich Drepper + + * localealias.c (read_alias_file): + Do not overwrite '\n' when terminating alias value string. + + * localealias.c (read_alias_file): + Handle long lines. Ignore the rest not fitting in + the buffer after the initial `fgets' call. + +Wed Aug 9 00:54:29 1995 Ulrich Drepper + + * gettextP.h (_nl_load_domain): + Add prototype, replacing prototype for _nl_load_msg_cat. + + * finddomain.c (_nl_find_domain): + Remove unneeded variable filename and filename_len. + (expand_alias): Remove prototype because functions does not + exist anymore. + + * localealias.c (read_alias_file): + Change type of fname_len parameter to int. + (xmalloc): Add prototype. + + * loadmsgcat.c: Better prototypes for xmalloc. + +Tue Aug 8 22:30:39 1995 Ulrich Drepper + + * finddomain.c (_nl_find_domain): + Allow alias name to be constructed from the four components. + + * Makefile.in (aliaspath): New variable. Set to preliminary value. + (SOURCES): Add localealias.c. + (OBJECTS): Add localealias.o. + + * gettextP.h: Add prototype for _nl_expand_alias. + + * finddomain.c: Aliasing handled in intl/localealias.c. + + * localealias.c: Aliasing for locale names. + + * bindtextdom.c: Better prototypes for xmalloc and xstrdup. + +Mon Aug 7 23:47:42 1995 Ulrich Drepper + + * Makefile.in (DISTFILES): gettext.perl is now found in misc/. + + * cat-compat.c (bindtextdomain): + Correct implementation. dirname parameter was not used. + Reported by Marcus Daniels. + + * gettextP.h (loaded_domain): + New fields `successor' and `decided' for oo, lazy + message handling implementation. + + * dcgettext.c: + Adopt for oo, lazy message handliing. + Now we can inherit translations from less specific locales. + (find_msg): New function. + + * loadmsgcat.c, finddomain.c: + Complete rewrite. Implement oo, lazy message handling :-). + We now have an additional environment variable `LANGUAGE' with + a higher priority than LC_ALL for the LC_MESSAGE locale. + Here we can set a colon separated list of specifications each + of the form `language[_territory[.codeset]][@modifier]'. + +Sat Aug 5 09:55:42 1995 Ulrich Drepper + + * finddomain.c (unistd.h): + Include to get _PC_PATH_MAX defined on system having it. + +Fri Aug 4 22:42:00 1995 Ulrich Drepper + + * finddomain.c (stpcpy): Include prototype. + + * Makefile.in (dist): Remove `copying instead' message. + +Wed Aug 2 18:52:03 1995 Ulrich Drepper + + * Makefile.in (ID, TAGS): Do not use $^. + +Tue Aug 1 20:07:11 1995 Ulrich Drepper + + * Makefile.in (TAGS, ID): Use $^ as command argument. + (TAGS): Give etags -o option t write to current directory, + not $(srcdir). + (ID): Use $(srcdir) instead os $(top_srcdir)/src. + (distclean): Remove ID. + +Sun Jul 30 11:51:46 1995 Ulrich Drepper + + * Makefile.in (gnulocaledir): + New variable, always using share/ for data directory. + (DEFS): Add GNULOCALEDIR, used in finddomain.c. + + * finddomain.c (_nl_default_dirname): + Set to GNULOCALEDIR, because it always has to point + to the directory where GNU gettext Library writes it to. + + * intl-compat.c (textdomain, bindtextdomain): + Undefine macros before function definition. + +Sat Jul 22 01:10:02 1995 Ulrich Drepper + + * libgettext.h (_LIBINTL_H): + Protect definition in case where this file is included as + libgettext.h on Solaris machines. Add comment about this. + +Wed Jul 19 02:36:42 1995 Ulrich Drepper + + * intl-compat.c (textdomain): Correct typo. + +Wed Jul 19 01:51:35 1995 Ulrich Drepper + + * dcgettext.c (dcgettext): Function now called __dcgettext. + + * dgettext.c (dgettext): Now called __dgettext and calls + __dcgettext. + + * gettext.c (gettext): + Function now called __gettext and calls __dgettext. + + * textdomain.c (textdomain): Function now called __textdomain. + + * bindtextdom.c (bindtextdomain): Function now called + __bindtextdomain. + + * intl-compat.c: Initial revision. + + * Makefile.in (SOURCES): Add intl-compat.c. + (OBJECTS): We always compile the GNU gettext library functions. + OBJECTS contains all objects but cat-compat.o, ../po/cat-if-tbl.o, + and intl-compat.o. + (GETTOBJS): Contains now only intl-compat.o. + + * libgettext.h: + Re-include protection matches dualistic character of libgettext.h. + For all functions in GNU gettext library define __ counter part. + + * finddomain.c (strchr): Define as index if not found in C library. + (_nl_find_domain): For relative paths paste / in between. + +Tue Jul 18 16:37:45 1995 Ulrich Drepper + + * loadmsgcat.c, finddomain.c: Add inclusion of sys/types.h. + + * xopen-msg.sed: Fix bug with `msgstr ""' lines. + A little bit better comments. + +Tue Jul 18 01:18:27 1995 Ulrich Drepper + + * Makefile.in: + po-mode.el, makelinks, combine-sh are now found in ../misc. + + * po-mode.el, makelinks, combine-sh, elisp-comp: + Moved to ../misc/. + + * libgettext.h, gettextP.h, gettext.h: Uniform test for __STDC__. + +Sun Jul 16 22:33:02 1995 Ulrich Drepper + + * Makefile.in (INSTALL, INSTALL_DATA): New variables. + (install-data, uninstall): Install/uninstall .elc file. + + * po-mode.el (Installation comment): + Add .pox as possible extension of .po files. + +Sun Jul 16 13:23:27 1995 Ulrich Drepper + + * elisp-comp: Complete new version by Franc,ois: This does not + fail when not compiling in the source directory. + +Sun Jul 16 00:12:17 1995 Ulrich Drepper + + * Makefile.in (../po/cat-id-tbl.o): + Use $(MAKE) instead of make for recursive make. + + * Makefile.in (.el.elc): Use $(SHELL) instead of /bin/sh. + (install-exec): Add missing dummy goal. + (install-data, uninstall): @ in multi-line shell command at + beginning, not in front of echo. Reported by Eric Backus. + +Sat Jul 15 00:21:28 1995 Ulrich Drepper + + * Makefile.in (DISTFILES): + Rename libgettext.perl to gettext.perl to fit in 14 chars + file systems. + + * gettext.perl: + Rename to gettext.perl to fit in 14 chars file systems. + +Thu Jul 13 23:17:20 1995 Ulrich Drepper + + * cat-compat.c: If !STDC_HEADERS try to include malloc.h. + +Thu Jul 13 20:55:02 1995 Ulrich Drepper + + * po2tbl.sed.in: Pretty printing. + + * linux-msg.sed, xopen-msg.sed: + Correct bugs with handling substitute flags in branches. + + * hash-string.h (hash_string): + Old K&R compilers don't under stand `unsigned char'. + + * gettext.h (nls_uint32): + Some old K&R compilers (eg HP) don't understand `unsigned int'. + + * cat-compat.c (msg_to_cat_id): De-ANSI-fy prototypes. + +Thu Jul 13 01:34:33 1995 Ulrich Drepper + + * Makefile.in (ELCFILES): New variable. + (DISTFILES): Add elisp-comp. + Add implicit rule for .el -> .elc compilation. + (install-data): install $ELCFILES + (clean): renamed po-to-tbl and po-to-msg to po2tbl and po2msg resp. + + * elisp-comp: Initial revision + +Wed Jul 12 16:14:52 1995 Ulrich Drepper + + * Makefile.in: + cat-id-tbl.c is now found in po/. This enables us to use an identical + intl/ directory in all packages. + + * dcgettext.c (dcgettext): hashing does not work for table size <= 2. + + * textdomain.c: fix typo (#if def -> #if defined) + +Tue Jul 11 18:44:43 1995 Ulrich Drepper + + * Makefile.in (stamp-cat-id): use top_srcdir to address source files + (DISTFILES,distclean): move tupdate.perl to src/ + + * po-to-tbl.sed.in: + add additional jump to clear change flag to recognize multiline strings + +Tue Jul 11 01:32:50 1995 Ulrich Drepper + + * textdomain.c: Protect inclusion of stdlib.h and string.h. + + * loadmsgcat.c: Protect inclusion of stdlib.h. + + * libgettext.h: Protect inclusion of locale.h. + Allow use in C++ programs. + Define NULL is not happened already. + + * Makefile.in (DISTFILES): ship po-to-tbl.sed.in instead of + po-to-tbl.sed. + (distclean): remove po-to-tbl.sed and tupdate.perl. + + * tupdate.perl.in: Substitute Perl path even in exec line. + Don't include entries without translation from old .po file. + +Tue Jul 4 00:41:51 1995 Ulrich Drepper + + * tupdate.perl.in: use "Updated: " in msgid "". + + * cat-compat.c: Fix typo (LOCALDIR -> LOCALEDIR). + Define getenv if !__STDC__. + + * bindtextdom.c: Protect stdlib.h and string.h inclusion. + Define free if !__STDC__. + + * finddomain.c: Change DEF_MSG_DOM_DIR to LOCALEDIR. + Define free if !__STDC__. + + * cat-compat.c: Change DEF_MSG_DOM_DIR to LOCALEDIR. + +Mon Jul 3 23:56:30 1995 Ulrich Drepper + + * Makefile.in: Use LOCALEDIR instead of DEF_MSG_DOM_DIR. + Remove unneeded $(srcdir) from Makefile.in dependency. + + * makelinks: Add copyright and short description. + + * po-mode.el: Last version for 0.7. + + * tupdate.perl.in: Fix die message. + + * dcgettext.c: Protect include of string.h. + + * gettext.c: Protect include of stdlib.h and further tries to get NULL. + + * finddomain.c: Some corrections in includes. + + * Makefile.in (INCLUDES): Prune list correct path to Makefile.in. + + * po-to-tbl.sed: Adopt for new .po file format. + + * linux-msg.sed, xopen-msg.sed: Adopt for new .po file format. + +Sun Jul 2 23:55:03 1995 Ulrich Drepper + + * tupdate.perl.in: Complete rewrite for new .po file format. + +Sun Jul 2 02:06:50 1995 Ulrich Drepper + + * First official release. This directory contains all the code + needed to internationalize own packages. It provides functions + which allow to use the X/Open catgets function with an interface + like the Uniforum gettext function. For system which does not + have neither of those a complete implementation is provided. diff --git a/intl/Makefile.in b/intl/Makefile.in new file mode 100644 index 00000000..c5e0ca9e --- /dev/null +++ b/intl/Makefile.in @@ -0,0 +1,214 @@ +# Makefile for directory with message catalog handling in GNU NLS Utilities. +# Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +PACKAGE = @PACKAGE@ +VERSION = @VERSION@ + +SHELL = /bin/sh + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +top_builddir = .. +VPATH = @srcdir@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +transform = @program_transform_name@ +libdir = $(exec_prefix)/lib +includedir = $(prefix)/include +datadir = $(prefix)/@DATADIRNAME@ +localedir = $(datadir)/locale +gnulocaledir = $(prefix)/share/locale +gettextsrcdir = @datadir@/gettext/intl +aliaspath = $(localedir):. +subdir = intl + +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MKINSTALLDIRS = @MKINSTALLDIRS@ + +l = @l@ + +AR = ar +CC = @CC@ +LIBTOOL = @LIBTOOL@ +RANLIB = @RANLIB@ + +DEFS = -DLOCALEDIR=\"$(localedir)\" -DGNULOCALEDIR=\"$(gnulocaledir)\" \ +-DLOCALE_ALIAS_PATH=\"$(aliaspath)\" @DEFS@ +CPPFLAGS = @CPPFLAGS@ +CFLAGS = @CFLAGS@ +LDFLAGS = @LDFLAGS@ + +COMPILE = $(CC) -c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(XCFLAGS) + +HEADERS = $(COMHDRS) libgettext.h loadinfo.h +COMHDRS = gettext.h gettextP.h hash-string.h +SOURCES = $(COMSRCS) intl-compat.c cat-compat.c +COMSRCS = bindtextdom.c dcgettext.c dgettext.c gettext.c \ +finddomain.c loadmsgcat.c localealias.c textdomain.c l10nflist.c \ +explodename.c +OBJECTS = @INTLOBJS@ bindtextdom.$lo dcgettext.$lo dgettext.$lo gettext.$lo \ +finddomain.$lo loadmsgcat.$lo localealias.$lo textdomain.$lo l10nflist.$lo \ +explodename.$lo +CATOBJS = cat-compat.$lo ../po/cat-id-tbl.$lo +GETTOBJS = intl-compat.$lo +DISTFILES.common = ChangeLog Makefile.in linux-msg.sed po2tbl.sed.in \ +xopen-msg.sed $(HEADERS) $(SOURCES) +DISTFILES.normal = VERSION +DISTFILES.gettext = libintl.glibc intlh.inst.in + +.SUFFIXES: +.SUFFIXES: .c .o .lo +.c.o: + $(COMPILE) $< +.c.lo: + $(LIBTOOL) --mode=compile $(COMPILE) $< + +INCLUDES = -I.. -I. -I$(top_srcdir)/intl -I$(top_srcdir)/lib -I$(top_srcdir)/src + +all: all-@USE_INCLUDED_LIBINTL@ + +all-yes: libintl.$la intlh.inst +all-no: + +libintl.a: $(OBJECTS) + rm -f $@ + $(AR) cru $@ $(OBJECTS) + $(RANLIB) $@ + +libintl.la: $(OBJECTS) + $(LIBTOOL) --mode=link $(CC) $(LDFLAGS) -o $@ $(OBJECTS) \ + -version-info 1:0 -rpath $(libdir) + +../po/cat-id-tbl.$lo: ../po/cat-id-tbl.c $(top_srcdir)/po/$(PACKAGE).pot + cd ../po && $(MAKE) cat-id-tbl.$lo + +check: all + +# This installation goal is only used in GNU gettext. Packages which +# only use the library should use install instead. + +# We must not install the libintl.h/libintl.a files if we are on a +# system which has the gettext() function in its C library or in a +# separate library or use the catgets interface. A special case is +# where configure found a previously installed GNU gettext library. +# If you want to use the one which comes with this version of the +# package, you have to use `configure --with-included-gettext'. +install: install-exec install-data +install-exec: all + if test "$(PACKAGE)" = "gettext" \ + && test '@INTLOBJS@' = '$(GETTOBJS)'; then \ + if test -r $(MKINSTALLDIRS); then \ + $(MKINSTALLDIRS) $(libdir) $(includedir); \ + else \ + $(top_srcdir)/mkinstalldirs $(libdir) $(includedir); \ + fi; \ + $(INSTALL_DATA) intlh.inst $(includedir)/libintl.h; \ + $(INSTALL_DATA) libintl.a $(libdir)/libintl.a; \ + else \ + : ; \ + fi +install-data: all + if test "$(PACKAGE)" = "gettext"; then \ + if test -r $(MKINSTALLDIRS); then \ + $(MKINSTALLDIRS) $(gettextsrcdir); \ + else \ + $(top_srcdir)/mkinstalldirs $(gettextsrcdir); \ + fi; \ + $(INSTALL_DATA) VERSION $(gettextsrcdir)/VERSION; \ + dists="$(DISTFILES.common)"; \ + for file in $$dists; do \ + $(INSTALL_DATA) $(srcdir)/$$file $(gettextsrcdir)/$$file; \ + done; \ + else \ + : ; \ + fi + +# Define this as empty until I found a useful application. +installcheck: + +uninstall: + dists="$(DISTFILES.common)"; \ + for file in $$dists; do \ + rm -f $(gettextsrcdir)/$$file; \ + done + +info dvi: + +$(OBJECTS): ../config.h libgettext.h +bindtextdom.$lo finddomain.$lo loadmsgcat.$lo: gettextP.h gettext.h loadinfo.h +dcgettext.$lo: gettextP.h gettext.h hash-string.h loadinfo.h + +tags: TAGS + +TAGS: $(HEADERS) $(SOURCES) + here=`pwd`; cd $(srcdir) && etags -o $$here/TAGS $(HEADERS) $(SOURCES) + +id: ID + +ID: $(HEADERS) $(SOURCES) + here=`pwd`; cd $(srcdir) && mkid -f$$here/ID $(HEADERS) $(SOURCES) + + +mostlyclean: + rm -f *.a *.o *.lo core core.* + +clean: mostlyclean + +distclean: clean + rm -f Makefile ID TAGS po2msg.sed po2tbl.sed libintl.h + +maintainer-clean: distclean + @echo "This command is intended for maintainers to use;" + @echo "it deletes files that may require special tools to rebuild." + + +# GNU gettext needs not contain the file `VERSION' but contains some +# other files which should not be distributed in other packages. +distdir = ../$(PACKAGE)-$(VERSION)/$(subdir) +dist distdir: Makefile $(DISTFILES) + if test "$(PACKAGE)" = gettext; then \ + additional="$(DISTFILES.gettext)"; \ + else \ + additional="$(DISTFILES.normal)"; \ + fi; \ + for file in $(DISTFILES.common) $$additional; do \ + ln $(srcdir)/$$file $(distdir) 2> /dev/null \ + || cp -p $(srcdir)/$$file $(distdir); \ + done + +dist-libc: + tar zcvf intl-glibc.tar.gz $(COMSRCS) $(COMHDRS) libintl.h.glibc + +Makefile: Makefile.in ../config.status + cd .. \ + && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= $(SHELL) ./config.status + +# The dependency for intlh.inst is different in gettext and all other +# packages. Because we cannot you GNU make features we have to solve +# the problem while rewriting Makefile.in. +@GT_YES@intlh.inst: intlh.inst.in ../config.status +@GT_YES@ cd .. \ +@GT_YES@ && CONFIG_FILES=$(subdir)/$@ CONFIG_HEADERS= \ +@GT_YES@ $(SHELL) ./config.status +@GT_NO@.PHONY: intlh.inst +@GT_NO@intlh.inst: + +# Tell versions [3.59,3.63) of GNU make not to export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/intl/VERSION b/intl/VERSION new file mode 100644 index 00000000..d0e8c699 --- /dev/null +++ b/intl/VERSION @@ -0,0 +1 @@ +0.10.32 diff --git a/intl/bindtextdom.c b/intl/bindtextdom.c new file mode 100644 index 00000000..9fcb8d9f --- /dev/null +++ b/intl/bindtextdom.c @@ -0,0 +1,199 @@ +/* Implementation of the bindtextdomain(3) function + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#if defined STDC_HEADERS || defined _LIBC +# include +#else +# ifdef HAVE_MALLOC_H +# include +# else +void free (); +# endif +#endif + +#if defined HAVE_STRING_H || defined _LIBC +# include +#else +# include +# ifndef memcpy +# define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) +# endif +#endif + +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif +#include "gettext.h" +#include "gettextP.h" + +/* @@ end of prolog @@ */ + +/* Contains the default location of the message catalogs. */ +extern const char _nl_default_dirname[]; + +/* List with bindings of specific domains. */ +extern struct binding *_nl_domain_bindings; + + +/* Names for the libintl functions are a problem. They must not clash + with existing names and they should follow ANSI C. But this source + code is also used in GNU C Library where the names have a __ + prefix. So we have to make a difference here. */ +#ifdef _LIBC +# define BINDTEXTDOMAIN __bindtextdomain +# define strdup(str) __strdup (str) +#else +# define BINDTEXTDOMAIN bindtextdomain__ +#endif + +/* Specify that the DOMAINNAME message catalog will be found + in DIRNAME rather than in the system locale data base. */ +char * +BINDTEXTDOMAIN (domainname, dirname) + const char *domainname; + const char *dirname; +{ + struct binding *binding; + + /* Some sanity checks. */ + if (domainname == NULL || domainname[0] == '\0') + return NULL; + + for (binding = _nl_domain_bindings; binding != NULL; binding = binding->next) + { + int compare = strcmp (domainname, binding->domainname); + if (compare == 0) + /* We found it! */ + break; + if (compare < 0) + { + /* It is not in the list. */ + binding = NULL; + break; + } + } + + if (dirname == NULL) + /* The current binding has be to returned. */ + return binding == NULL ? (char *) _nl_default_dirname : binding->dirname; + + if (binding != NULL) + { + /* The domain is already bound. If the new value and the old + one are equal we simply do nothing. Otherwise replace the + old binding. */ + if (strcmp (dirname, binding->dirname) != 0) + { + char *new_dirname; + + if (strcmp (dirname, _nl_default_dirname) == 0) + new_dirname = (char *) _nl_default_dirname; + else + { +#if defined _LIBC || defined HAVE_STRDUP + new_dirname = strdup (dirname); + if (new_dirname == NULL) + return NULL; +#else + size_t len = strlen (dirname) + 1; + new_dirname = (char *) malloc (len); + if (new_dirname == NULL) + return NULL; + + memcpy (new_dirname, dirname, len); +#endif + } + + if (binding->dirname != _nl_default_dirname) + free (binding->dirname); + + binding->dirname = new_dirname; + } + } + else + { + /* We have to create a new binding. */ + size_t len; + struct binding *new_binding = + (struct binding *) malloc (sizeof (*new_binding)); + + if (new_binding == NULL) + return NULL; + +#if defined _LIBC || defined HAVE_STRDUP + new_binding->domainname = strdup (domainname); + if (new_binding->domainname == NULL) + return NULL; +#else + len = strlen (domainname) + 1; + new_binding->domainname = (char *) malloc (len); + if (new_binding->domainname == NULL) + return NULL; + memcpy (new_binding->domainname, domainname, len); +#endif + + if (strcmp (dirname, _nl_default_dirname) == 0) + new_binding->dirname = (char *) _nl_default_dirname; + else + { +#if defined _LIBC || defined HAVE_STRDUP + new_binding->dirname = strdup (dirname); + if (new_binding->dirname == NULL) + return NULL; +#else + len = strlen (dirname) + 1; + new_binding->dirname = (char *) malloc (len); + if (new_binding->dirname == NULL) + return NULL; + memcpy (new_binding->dirname, dirname, len); +#endif + } + + /* Now enqueue it. */ + if (_nl_domain_bindings == NULL + || strcmp (domainname, _nl_domain_bindings->domainname) < 0) + { + new_binding->next = _nl_domain_bindings; + _nl_domain_bindings = new_binding; + } + else + { + binding = _nl_domain_bindings; + while (binding->next != NULL + && strcmp (domainname, binding->next->domainname) > 0) + binding = binding->next; + + new_binding->next = binding->next; + binding->next = new_binding; + } + + binding = new_binding; + } + + return binding->dirname; +} + +#ifdef _LIBC +/* Alias for function name in GNU C Library. */ +weak_alias (__bindtextdomain, bindtextdomain); +#endif diff --git a/intl/cat-compat.c b/intl/cat-compat.c new file mode 100644 index 00000000..867d901b --- /dev/null +++ b/intl/cat-compat.c @@ -0,0 +1,262 @@ +/* Compatibility code for gettext-using-catgets interface. + Copyright (C) 1995, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#ifdef STDC_HEADERS +# include +# include +#else +char *getenv (); +# ifdef HAVE_MALLOC_H +# include +# endif +#endif + +#ifdef HAVE_NL_TYPES_H +# include +#endif + +#include "libgettext.h" + +/* @@ end of prolog @@ */ + +/* XPG3 defines the result of `setlocale (category, NULL)' as: + ``Directs `setlocale()' to query `category' and return the current + setting of `local'.'' + However it does not specify the exact format. And even worse: POSIX + defines this not at all. So we can use this feature only on selected + system (e.g. those using GNU C Library). */ +#ifdef _LIBC +# define HAVE_LOCALE_NULL +#endif + +/* The catalog descriptor. */ +static nl_catd catalog = (nl_catd) -1; + +/* Name of the default catalog. */ +static const char default_catalog_name[] = "messages"; + +/* Name of currently used catalog. */ +static const char *catalog_name = default_catalog_name; + +/* Get ID for given string. If not found return -1. */ +static int msg_to_cat_id PARAMS ((const char *msg)); + +/* Substitution for systems lacking this function in their C library. */ +#if !_LIBC && !HAVE_STPCPY +static char *stpcpy PARAMS ((char *dest, const char *src)); +#endif + + +/* Set currently used domain/catalog. */ +char * +textdomain (domainname) + const char *domainname; +{ + nl_catd new_catalog; + char *new_name; + size_t new_name_len; + char *lang; + +#if defined HAVE_SETLOCALE && defined HAVE_LC_MESSAGES \ + && defined HAVE_LOCALE_NULL + lang = setlocale (LC_MESSAGES, NULL); +#else + lang = getenv ("LC_ALL"); + if (lang == NULL || lang[0] == '\0') + { + lang = getenv ("LC_MESSAGES"); + if (lang == NULL || lang[0] == '\0') + lang = getenv ("LANG"); + } +#endif + if (lang == NULL || lang[0] == '\0') + lang = "C"; + + /* See whether name of currently used domain is asked. */ + if (domainname == NULL) + return (char *) catalog_name; + + if (domainname[0] == '\0') + domainname = default_catalog_name; + + /* Compute length of added path element. */ + new_name_len = sizeof (LOCALEDIR) - 1 + 1 + strlen (lang) + + sizeof ("/LC_MESSAGES/") - 1 + sizeof (PACKAGE) - 1 + + sizeof (".cat"); + + new_name = (char *) malloc (new_name_len); + if (new_name == NULL) + return NULL; + + strcpy (new_name, PACKAGE); + new_catalog = catopen (new_name, 0); + + if (new_catalog == (nl_catd) -1) + { + /* NLSPATH search didn't work, try absolute path */ + sprintf (new_name, "%s/%s/LC_MESSAGES/%s.cat", LOCALEDIR, lang, + PACKAGE); + new_catalog = catopen (new_name, 0); + + if (new_catalog == (nl_catd) -1) + { + free (new_name); + return (char *) catalog_name; + } + } + + /* Close old catalog. */ + if (catalog != (nl_catd) -1) + catclose (catalog); + if (catalog_name != default_catalog_name) + free ((char *) catalog_name); + + catalog = new_catalog; + catalog_name = new_name; + + return (char *) catalog_name; +} + +char * +bindtextdomain (domainname, dirname) + const char *domainname; + const char *dirname; +{ +#if HAVE_SETENV || HAVE_PUTENV + char *old_val, *new_val, *cp; + size_t new_val_len; + + /* This does not make much sense here but to be compatible do it. */ + if (domainname == NULL) + return NULL; + + /* Compute length of added path element. If we use setenv we don't need + the first byts for NLSPATH=, but why complicate the code for this + peanuts. */ + new_val_len = sizeof ("NLSPATH=") - 1 + strlen (dirname) + + sizeof ("/%L/LC_MESSAGES/%N.cat"); + + old_val = getenv ("NLSPATH"); + if (old_val == NULL || old_val[0] == '\0') + { + old_val = NULL; + new_val_len += 1 + sizeof (LOCALEDIR) - 1 + + sizeof ("/%L/LC_MESSAGES/%N.cat"); + } + else + new_val_len += strlen (old_val); + + new_val = (char *) malloc (new_val_len); + if (new_val == NULL) + return NULL; + +# if HAVE_SETENV + cp = new_val; +# else + cp = stpcpy (new_val, "NLSPATH="); +# endif + + cp = stpcpy (cp, dirname); + cp = stpcpy (cp, "/%L/LC_MESSAGES/%N.cat:"); + + if (old_val == NULL) + { +# if __STDC__ + stpcpy (cp, LOCALEDIR "/%L/LC_MESSAGES/%N.cat"); +# else + + cp = stpcpy (cp, LOCALEDIR); + stpcpy (cp, "/%L/LC_MESSAGES/%N.cat"); +# endif + } + else + stpcpy (cp, old_val); + +# if HAVE_SETENV + setenv ("NLSPATH", new_val, 1); + free (new_val); +# else + putenv (new_val); + /* Do *not* free the environment entry we just entered. It is used + from now on. */ +# endif + +#endif + + return (char *) domainname; +} + +#undef gettext +char * +gettext (msg) + const char *msg; +{ + int msgid; + + if (msg == NULL || catalog == (nl_catd) -1) + return (char *) msg; + + /* Get the message from the catalog. We always use set number 1. + The message ID is computed by the function `msg_to_cat_id' + which works on the table generated by `po-to-tbl'. */ + msgid = msg_to_cat_id (msg); + if (msgid == -1) + return (char *) msg; + + return catgets (catalog, 1, msgid, (char *) msg); +} + +/* Look through the table `_msg_tbl' which has `_msg_tbl_length' entries + for the one equal to msg. If it is found return the ID. In case when + the string is not found return -1. */ +static int +msg_to_cat_id (msg) + const char *msg; +{ + int cnt; + + for (cnt = 0; cnt < _msg_tbl_length; ++cnt) + if (strcmp (msg, _msg_tbl[cnt]._msg) == 0) + return _msg_tbl[cnt]._msg_number; + + return -1; +} + + +/* @@ begin of epilog @@ */ + +/* We don't want libintl.a to depend on any other library. So we + avoid the non-standard function stpcpy. In GNU C Library this + function is available, though. Also allow the symbol HAVE_STPCPY + to be defined. */ +#if !_LIBC && !HAVE_STPCPY +static char * +stpcpy (dest, src) + char *dest; + const char *src; +{ + while ((*dest++ = *src++) != '\0') + /* Do nothing. */ ; + return dest - 1; +} +#endif diff --git a/intl/dcgettext.c b/intl/dcgettext.c new file mode 100644 index 00000000..a316bfd1 --- /dev/null +++ b/intl/dcgettext.c @@ -0,0 +1,593 @@ +/* Implementation of the dcgettext(3) function + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include + +#ifdef __GNUC__ +# define alloca __builtin_alloca +# define HAVE_ALLOCA 1 +#else +# if defined HAVE_ALLOCA_H || defined _LIBC +# include +# else +# ifdef _AIX + #pragma alloca +# else +# ifndef alloca +char *alloca (); +# endif +# endif +# endif +#endif + +#include +#ifndef errno +extern int errno; +#endif +#ifndef __set_errno +# define __set_errno(val) errno = (val) +#endif + +#if defined STDC_HEADERS || defined _LIBC +# include +#else +char *getenv (); +# ifdef HAVE_MALLOC_H +# include +# else +void free (); +# endif +#endif + +#if defined HAVE_STRING_H || defined _LIBC +# ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 +# endif +# include +#else +# include +#endif +#if !HAVE_STRCHR && !defined _LIBC +# ifndef strchr +# define strchr index +# endif +#endif + +#if defined HAVE_UNISTD_H || defined _LIBC +# include +#endif + +#include "gettext.h" +#include "gettextP.h" +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif +#include "hash-string.h" + +/* @@ end of prolog @@ */ + +#ifdef _LIBC +/* Rename the non ANSI C functions. This is required by the standard + because some ANSI C functions will require linking with this object + file and the name space must not be polluted. */ +# define getcwd __getcwd +# define stpcpy __stpcpy +#else +# if !defined HAVE_GETCWD +char *getwd (); +# define getcwd(buf, max) getwd (buf) +# else +char *getcwd (); +# endif +# ifndef HAVE_STPCPY +static char *stpcpy PARAMS ((char *dest, const char *src)); +# endif +#endif + +/* Amount to increase buffer size by in each try. */ +#define PATH_INCR 32 + +/* The following is from pathmax.h. */ +/* Non-POSIX BSD systems might have gcc's limits.h, which doesn't define + PATH_MAX but might cause redefinition warnings when sys/param.h is + later included (as on MORE/BSD 4.3). */ +#if defined(_POSIX_VERSION) || (defined(HAVE_LIMITS_H) && !defined(__GNUC__)) +# include +#endif + +#ifndef _POSIX_PATH_MAX +# define _POSIX_PATH_MAX 255 +#endif + +#if !defined(PATH_MAX) && defined(_PC_PATH_MAX) +# define PATH_MAX (pathconf ("/", _PC_PATH_MAX) < 1 ? 1024 : pathconf ("/", _PC_PATH_MAX)) +#endif + +/* Don't include sys/param.h if it already has been. */ +#if defined(HAVE_SYS_PARAM_H) && !defined(PATH_MAX) && !defined(MAXPATHLEN) +# include +#endif + +#if !defined(PATH_MAX) && defined(MAXPATHLEN) +# define PATH_MAX MAXPATHLEN +#endif + +#ifndef PATH_MAX +# define PATH_MAX _POSIX_PATH_MAX +#endif + +/* XPG3 defines the result of `setlocale (category, NULL)' as: + ``Directs `setlocale()' to query `category' and return the current + setting of `local'.'' + However it does not specify the exact format. And even worse: POSIX + defines this not at all. So we can use this feature only on selected + system (e.g. those using GNU C Library). */ +#ifdef _LIBC +# define HAVE_LOCALE_NULL +#endif + +/* Name of the default domain used for gettext(3) prior any call to + textdomain(3). The default value for this is "messages". */ +const char _nl_default_default_domain[] = "messages"; + +/* Value used as the default domain for gettext(3). */ +const char *_nl_current_default_domain = _nl_default_default_domain; + +/* Contains the default location of the message catalogs. */ +const char _nl_default_dirname[] = GNULOCALEDIR; + +/* List with bindings of specific domains created by bindtextdomain() + calls. */ +struct binding *_nl_domain_bindings; + +/* Prototypes for local functions. */ +static char *find_msg PARAMS ((struct loaded_l10nfile *domain_file, + const char *msgid)); +static const char *category_to_name PARAMS ((int category)); +static const char *guess_category_value PARAMS ((int category, + const char *categoryname)); + + +/* For those loosing systems which don't have `alloca' we have to add + some additional code emulating it. */ +#ifdef HAVE_ALLOCA +/* Nothing has to be done. */ +# define ADD_BLOCK(list, address) /* nothing */ +# define FREE_BLOCKS(list) /* nothing */ +#else +struct block_list +{ + void *address; + struct block_list *next; +}; +# define ADD_BLOCK(list, addr) \ + do { \ + struct block_list *newp = (struct block_list *) malloc (sizeof (*newp)); \ + /* If we cannot get a free block we cannot add the new element to \ + the list. */ \ + if (newp != NULL) { \ + newp->address = (addr); \ + newp->next = (list); \ + (list) = newp; \ + } \ + } while (0) +# define FREE_BLOCKS(list) \ + do { \ + while (list != NULL) { \ + struct block_list *old = list; \ + list = list->next; \ + free (old); \ + } \ + } while (0) +# undef alloca +# define alloca(size) (malloc (size)) +#endif /* have alloca */ + + +/* Names for the libintl functions are a problem. They must not clash + with existing names and they should follow ANSI C. But this source + code is also used in GNU C Library where the names have a __ + prefix. So we have to make a difference here. */ +#ifdef _LIBC +# define DCGETTEXT __dcgettext +#else +# define DCGETTEXT dcgettext__ +#endif + +/* Look up MSGID in the DOMAINNAME message catalog for the current CATEGORY + locale. */ +char * +DCGETTEXT (domainname, msgid, category) + const char *domainname; + const char *msgid; + int category; +{ +#ifndef HAVE_ALLOCA + struct block_list *block_list = NULL; +#endif + struct loaded_l10nfile *domain; + struct binding *binding; + const char *categoryname; + const char *categoryvalue; + char *dirname, *xdomainname; + char *single_locale; + char *retval; + int saved_errno = errno; + + /* If no real MSGID is given return NULL. */ + if (msgid == NULL) + return NULL; + + /* If DOMAINNAME is NULL, we are interested in the default domain. If + CATEGORY is not LC_MESSAGES this might not make much sense but the + defintion left this undefined. */ + if (domainname == NULL) + domainname = _nl_current_default_domain; + + /* First find matching binding. */ + for (binding = _nl_domain_bindings; binding != NULL; binding = binding->next) + { + int compare = strcmp (domainname, binding->domainname); + if (compare == 0) + /* We found it! */ + break; + if (compare < 0) + { + /* It is not in the list. */ + binding = NULL; + break; + } + } + + if (binding == NULL) + dirname = (char *) _nl_default_dirname; + else if (binding->dirname[0] == '/') + dirname = binding->dirname; + else + { + /* We have a relative path. Make it absolute now. */ + size_t dirname_len = strlen (binding->dirname) + 1; + size_t path_max; + char *ret; + + path_max = (unsigned) PATH_MAX; + path_max += 2; /* The getcwd docs say to do this. */ + + dirname = (char *) alloca (path_max + dirname_len); + ADD_BLOCK (block_list, dirname); + + __set_errno (0); + while ((ret = getcwd (dirname, path_max)) == NULL && errno == ERANGE) + { + path_max += PATH_INCR; + dirname = (char *) alloca (path_max + dirname_len); + ADD_BLOCK (block_list, dirname); + __set_errno (0); + } + + if (ret == NULL) + { + /* We cannot get the current working directory. Don't signal an + error but simply return the default string. */ + FREE_BLOCKS (block_list); + __set_errno (saved_errno); + return (char *) msgid; + } + + stpcpy (stpcpy (strchr (dirname, '\0'), "/"), binding->dirname); + } + + /* Now determine the symbolic name of CATEGORY and its value. */ + categoryname = category_to_name (category); + categoryvalue = guess_category_value (category, categoryname); + + xdomainname = (char *) alloca (strlen (categoryname) + + strlen (domainname) + 5); + ADD_BLOCK (block_list, xdomainname); + + stpcpy (stpcpy (stpcpy (stpcpy (xdomainname, categoryname), "/"), + domainname), + ".mo"); + + /* Creating working area. */ + single_locale = (char *) alloca (strlen (categoryvalue) + 1); + ADD_BLOCK (block_list, single_locale); + + + /* Search for the given string. This is a loop because we perhaps + got an ordered list of languages to consider for th translation. */ + while (1) + { + /* Make CATEGORYVALUE point to the next element of the list. */ + while (categoryvalue[0] != '\0' && categoryvalue[0] == ':') + ++categoryvalue; + if (categoryvalue[0] == '\0') + { + /* The whole contents of CATEGORYVALUE has been searched but + no valid entry has been found. We solve this situation + by implicitly appending a "C" entry, i.e. no translation + will take place. */ + single_locale[0] = 'C'; + single_locale[1] = '\0'; + } + else + { + char *cp = single_locale; + while (categoryvalue[0] != '\0' && categoryvalue[0] != ':') + *cp++ = *categoryvalue++; + *cp = '\0'; + } + + /* If the current locale value is C (or POSIX) we don't load a + domain. Return the MSGID. */ + if (strcmp (single_locale, "C") == 0 + || strcmp (single_locale, "POSIX") == 0) + { + FREE_BLOCKS (block_list); + __set_errno (saved_errno); + return (char *) msgid; + } + + + /* Find structure describing the message catalog matching the + DOMAINNAME and CATEGORY. */ + domain = _nl_find_domain (dirname, single_locale, xdomainname); + + if (domain != NULL) + { + retval = find_msg (domain, msgid); + + if (retval == NULL) + { + int cnt; + + for (cnt = 0; domain->successor[cnt] != NULL; ++cnt) + { + retval = find_msg (domain->successor[cnt], msgid); + + if (retval != NULL) + break; + } + } + + if (retval != NULL) + { + FREE_BLOCKS (block_list); + __set_errno (saved_errno); + return retval; + } + } + } + /* NOTREACHED */ +} + +#ifdef _LIBC +/* Alias for function name in GNU C Library. */ +weak_alias (__dcgettext, dcgettext); +#endif + + +static char * +find_msg (domain_file, msgid) + struct loaded_l10nfile *domain_file; + const char *msgid; +{ + size_t top, act, bottom; + struct loaded_domain *domain; + + if (domain_file->decided == 0) + _nl_load_domain (domain_file); + + if (domain_file->data == NULL) + return NULL; + + domain = (struct loaded_domain *) domain_file->data; + + /* Locate the MSGID and its translation. */ + if (domain->hash_size > 2 && domain->hash_tab != NULL) + { + /* Use the hashing table. */ + nls_uint32 len = strlen (msgid); + nls_uint32 hash_val = hash_string (msgid); + nls_uint32 idx = hash_val % domain->hash_size; + nls_uint32 incr = 1 + (hash_val % (domain->hash_size - 2)); + nls_uint32 nstr = W (domain->must_swap, domain->hash_tab[idx]); + + if (nstr == 0) + /* Hash table entry is empty. */ + return NULL; + + if (W (domain->must_swap, domain->orig_tab[nstr - 1].length) == len + && strcmp (msgid, + domain->data + W (domain->must_swap, + domain->orig_tab[nstr - 1].offset)) == 0) + return (char *) domain->data + W (domain->must_swap, + domain->trans_tab[nstr - 1].offset); + + while (1) + { + if (idx >= domain->hash_size - incr) + idx -= domain->hash_size - incr; + else + idx += incr; + + nstr = W (domain->must_swap, domain->hash_tab[idx]); + if (nstr == 0) + /* Hash table entry is empty. */ + return NULL; + + if (W (domain->must_swap, domain->orig_tab[nstr - 1].length) == len + && strcmp (msgid, + domain->data + W (domain->must_swap, + domain->orig_tab[nstr - 1].offset)) + == 0) + return (char *) domain->data + + W (domain->must_swap, domain->trans_tab[nstr - 1].offset); + } + /* NOTREACHED */ + } + + /* Now we try the default method: binary search in the sorted + array of messages. */ + bottom = 0; + top = domain->nstrings; + while (bottom < top) + { + int cmp_val; + + act = (bottom + top) / 2; + cmp_val = strcmp (msgid, domain->data + + W (domain->must_swap, + domain->orig_tab[act].offset)); + if (cmp_val < 0) + top = act; + else if (cmp_val > 0) + bottom = act + 1; + else + break; + } + + /* If an translation is found return this. */ + return bottom >= top ? NULL : (char *) domain->data + + W (domain->must_swap, + domain->trans_tab[act].offset); +} + + +/* Return string representation of locale CATEGORY. */ +static const char * +category_to_name (category) + int category; +{ + const char *retval; + + switch (category) + { +#ifdef LC_COLLATE + case LC_COLLATE: + retval = "LC_COLLATE"; + break; +#endif +#ifdef LC_CTYPE + case LC_CTYPE: + retval = "LC_CTYPE"; + break; +#endif +#ifdef LC_MONETARY + case LC_MONETARY: + retval = "LC_MONETARY"; + break; +#endif +#ifdef LC_NUMERIC + case LC_NUMERIC: + retval = "LC_NUMERIC"; + break; +#endif +#ifdef LC_TIME + case LC_TIME: + retval = "LC_TIME"; + break; +#endif +#ifdef LC_MESSAGES + case LC_MESSAGES: + retval = "LC_MESSAGES"; + break; +#endif +#ifdef LC_RESPONSE + case LC_RESPONSE: + retval = "LC_RESPONSE"; + break; +#endif +#ifdef LC_ALL + case LC_ALL: + /* This might not make sense but is perhaps better than any other + value. */ + retval = "LC_ALL"; + break; +#endif + default: + /* If you have a better idea for a default value let me know. */ + retval = "LC_XXX"; + } + + return retval; +} + +/* Guess value of current locale from value of the environment variables. */ +static const char * +guess_category_value (category, categoryname) + int category; + const char *categoryname; +{ + const char *retval; + + /* The highest priority value is the `LANGUAGE' environment + variable. This is a GNU extension. */ + retval = getenv ("LANGUAGE"); + if (retval != NULL && retval[0] != '\0') + return retval; + + /* `LANGUAGE' is not set. So we have to proceed with the POSIX + methods of looking to `LC_ALL', `LC_xxx', and `LANG'. On some + systems this can be done by the `setlocale' function itself. */ +#if defined HAVE_SETLOCALE && defined HAVE_LC_MESSAGES && defined HAVE_LOCALE_NULL + return setlocale (category, NULL); +#else + /* Setting of LC_ALL overwrites all other. */ + retval = getenv ("LC_ALL"); + if (retval != NULL && retval[0] != '\0') + return retval; + + /* Next comes the name of the desired category. */ + retval = getenv (categoryname); + if (retval != NULL && retval[0] != '\0') + return retval; + + /* Last possibility is the LANG environment variable. */ + retval = getenv ("LANG"); + if (retval != NULL && retval[0] != '\0') + return retval; + + /* We use C as the default domain. POSIX says this is implementation + defined. */ + return "C"; +#endif +} + +/* @@ begin of epilog @@ */ + +/* We don't want libintl.a to depend on any other library. So we + avoid the non-standard function stpcpy. In GNU C Library this + function is available, though. Also allow the symbol HAVE_STPCPY + to be defined. */ +#if !_LIBC && !HAVE_STPCPY +static char * +stpcpy (dest, src) + char *dest; + const char *src; +{ + while ((*dest++ = *src++) != '\0') + /* Do nothing. */ ; + return dest - 1; +} +#endif diff --git a/intl/dgettext.c b/intl/dgettext.c new file mode 100644 index 00000000..2fde6770 --- /dev/null +++ b/intl/dgettext.c @@ -0,0 +1,59 @@ +/* dgettext.c -- implementation of the dgettext(3) function + Copyright (C) 1995 Software Foundation, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#if defined HAVE_LOCALE_H || defined _LIBC +# include +#endif + +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif + +/* @@ end of prolog @@ */ + +/* Names for the libintl functions are a problem. They must not clash + with existing names and they should follow ANSI C. But this source + code is also used in GNU C Library where the names have a __ + prefix. So we have to make a difference here. */ +#ifdef _LIBC +# define DGETTEXT __dgettext +# define DCGETTEXT __dcgettext +#else +# define DGETTEXT dgettext__ +# define DCGETTEXT dcgettext__ +#endif + +/* Look up MSGID in the DOMAINNAME message catalog of the current + LC_MESSAGES locale. */ +char * +DGETTEXT (domainname, msgid) + const char *domainname; + const char *msgid; +{ + return DCGETTEXT (domainname, msgid, LC_MESSAGES); +} + +#ifdef _LIBC +/* Alias for function name in GNU C Library. */ +weak_alias (__dgettext, dgettext); +#endif diff --git a/intl/explodename.c b/intl/explodename.c new file mode 100644 index 00000000..e45b2a21 --- /dev/null +++ b/intl/explodename.c @@ -0,0 +1,181 @@ +/* Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + Contributed by Ulrich Drepper , 1995. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include + +#include "loadinfo.h" + +/* On some strange systems still no definition of NULL is found. Sigh! */ +#ifndef NULL +# if defined __STDC__ && __STDC__ +# define NULL ((void *) 0) +# else +# define NULL 0 +# endif +#endif + +/* @@ end of prolog @@ */ + +int +_nl_explode_name (name, language, modifier, territory, codeset, + normalized_codeset, special, sponsor, revision) + char *name; + const char **language; + const char **modifier; + const char **territory; + const char **codeset; + const char **normalized_codeset; + const char **special; + const char **sponsor; + const char **revision; +{ + enum { undecided, xpg, cen } syntax; + char *cp; + int mask; + + *modifier = NULL; + *territory = NULL; + *codeset = NULL; + *normalized_codeset = NULL; + *special = NULL; + *sponsor = NULL; + *revision = NULL; + + /* Now we determine the single parts of the locale name. First + look for the language. Termination symbols are `_' and `@' if + we use XPG4 style, and `_', `+', and `,' if we use CEN syntax. */ + mask = 0; + syntax = undecided; + *language = cp = name; + while (cp[0] != '\0' && cp[0] != '_' && cp[0] != '@' + && cp[0] != '+' && cp[0] != ',') + ++cp; + + if (*language == cp) + /* This does not make sense: language has to be specified. Use + this entry as it is without exploding. Perhaps it is an alias. */ + cp = strchr (*language, '\0'); + else if (cp[0] == '_') + { + /* Next is the territory. */ + cp[0] = '\0'; + *territory = ++cp; + + while (cp[0] != '\0' && cp[0] != '.' && cp[0] != '@' + && cp[0] != '+' && cp[0] != ',' && cp[0] != '_') + ++cp; + + mask |= TERRITORY; + + if (cp[0] == '.') + { + /* Next is the codeset. */ + syntax = xpg; + cp[0] = '\0'; + *codeset = ++cp; + + while (cp[0] != '\0' && cp[0] != '@') + ++cp; + + mask |= XPG_CODESET; + + if (*codeset != cp && (*codeset)[0] != '\0') + { + *normalized_codeset = _nl_normalize_codeset (*codeset, + cp - *codeset); + if (strcmp (*codeset, *normalized_codeset) == 0) + free ((char *) *normalized_codeset); + else + mask |= XPG_NORM_CODESET; + } + } + } + + if (cp[0] == '@' || (syntax != xpg && cp[0] == '+')) + { + /* Next is the modifier. */ + syntax = cp[0] == '@' ? xpg : cen; + cp[0] = '\0'; + *modifier = ++cp; + + while (syntax == cen && cp[0] != '\0' && cp[0] != '+' + && cp[0] != ',' && cp[0] != '_') + ++cp; + + mask |= XPG_MODIFIER | CEN_AUDIENCE; + } + + if (syntax != xpg && (cp[0] == '+' || cp[0] == ',' || cp[0] == '_')) + { + syntax = cen; + + if (cp[0] == '+') + { + /* Next is special application (CEN syntax). */ + cp[0] = '\0'; + *special = ++cp; + + while (cp[0] != '\0' && cp[0] != ',' && cp[0] != '_') + ++cp; + + mask |= CEN_SPECIAL; + } + + if (cp[0] == ',') + { + /* Next is sponsor (CEN syntax). */ + cp[0] = '\0'; + *sponsor = ++cp; + + while (cp[0] != '\0' && cp[0] != '_') + ++cp; + + mask |= CEN_SPONSOR; + } + + if (cp[0] == '_') + { + /* Next is revision (CEN syntax). */ + cp[0] = '\0'; + *revision = ++cp; + + mask |= CEN_REVISION; + } + } + + /* For CEN syntax values it might be important to have the + separator character in the file name, not for XPG syntax. */ + if (syntax == xpg) + { + if (*territory != NULL && (*territory)[0] == '\0') + mask &= ~TERRITORY; + + if (*codeset != NULL && (*codeset)[0] == '\0') + mask &= ~XPG_CODESET; + + if (*modifier != NULL && (*modifier)[0] == '\0') + mask &= ~XPG_MODIFIER; + } + + return mask; +} diff --git a/intl/finddomain.c b/intl/finddomain.c new file mode 100644 index 00000000..fd27f6f7 --- /dev/null +++ b/intl/finddomain.c @@ -0,0 +1,189 @@ +/* Handle list of needed message catalogs + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + Written by Ulrich Drepper , 1995. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include +#include + +#if defined STDC_HEADERS || defined _LIBC +# include +#else +# ifdef HAVE_MALLOC_H +# include +# else +void free (); +# endif +#endif + +#if defined HAVE_STRING_H || defined _LIBC +# include +#else +# include +# ifndef memcpy +# define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) +# endif +#endif +#if !HAVE_STRCHR && !defined _LIBC +# ifndef strchr +# define strchr index +# endif +#endif + +#if defined HAVE_UNISTD_H || defined _LIBC +# include +#endif + +#include "gettext.h" +#include "gettextP.h" +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif + +/* @@ end of prolog @@ */ +/* List of already loaded domains. */ +static struct loaded_l10nfile *_nl_loaded_domains; + + +/* Return a data structure describing the message catalog described by + the DOMAINNAME and CATEGORY parameters with respect to the currently + established bindings. */ +struct loaded_l10nfile * +_nl_find_domain (dirname, locale, domainname) + const char *dirname; + char *locale; + const char *domainname; +{ + struct loaded_l10nfile *retval; + const char *language; + const char *modifier; + const char *territory; + const char *codeset; + const char *normalized_codeset; + const char *special; + const char *sponsor; + const char *revision; + const char *alias_value; + int mask; + + /* LOCALE can consist of up to four recognized parts for the XPG syntax: + + language[_territory[.codeset]][@modifier] + + and six parts for the CEN syntax: + + language[_territory][+audience][+special][,[sponsor][_revision]] + + Beside the first all of them are allowed to be missing. If the + full specified locale is not found, the less specific one are + looked for. The various part will be stripped of according to + the following order: + (1) revision + (2) sponsor + (3) special + (4) codeset + (5) normalized codeset + (6) territory + (7) audience/modifier + */ + + /* If we have already tested for this locale entry there has to + be one data set in the list of loaded domains. */ + retval = _nl_make_l10nflist (&_nl_loaded_domains, dirname, + strlen (dirname) + 1, 0, locale, NULL, NULL, + NULL, NULL, NULL, NULL, NULL, domainname, 0); + if (retval != NULL) + { + /* We know something about this locale. */ + int cnt; + + if (retval->decided == 0) + _nl_load_domain (retval); + + if (retval->data != NULL) + return retval; + + for (cnt = 0; retval->successor[cnt] != NULL; ++cnt) + { + if (retval->successor[cnt]->decided == 0) + _nl_load_domain (retval->successor[cnt]); + + if (retval->successor[cnt]->data != NULL) + break; + } + return cnt >= 0 ? retval : NULL; + /* NOTREACHED */ + } + + /* See whether the locale value is an alias. If yes its value + *overwrites* the alias name. No test for the original value is + done. */ + alias_value = _nl_expand_alias (locale); + if (alias_value != NULL) + { + size_t len = strlen (alias_value) + 1; + locale = (char *) malloc (len); + if (locale == NULL) + return NULL; + + memcpy (locale, alias_value, len); + } + + /* Now we determine the single parts of the locale name. First + look for the language. Termination symbols are `_' and `@' if + we use XPG4 style, and `_', `+', and `,' if we use CEN syntax. */ + mask = _nl_explode_name (locale, &language, &modifier, &territory, + &codeset, &normalized_codeset, &special, + &sponsor, &revision); + + /* Create all possible locale entries which might be interested in + generalization. */ + retval = _nl_make_l10nflist (&_nl_loaded_domains, dirname, + strlen (dirname) + 1, mask, language, territory, + codeset, normalized_codeset, modifier, special, + sponsor, revision, domainname, 1); + if (retval == NULL) + /* This means we are out of core. */ + return NULL; + + if (retval->decided == 0) + _nl_load_domain (retval); + if (retval->data == NULL) + { + int cnt; + for (cnt = 0; retval->successor[cnt] != NULL; ++cnt) + { + if (retval->successor[cnt]->decided == 0) + _nl_load_domain (retval->successor[cnt]); + if (retval->successor[cnt]->data != NULL) + break; + } + } + + /* The room for an alias was dynamically allocated. Free it now. */ + if (alias_value != NULL) + free (locale); + + return retval; +} diff --git a/intl/gettext.c b/intl/gettext.c new file mode 100644 index 00000000..1336d21e --- /dev/null +++ b/intl/gettext.c @@ -0,0 +1,70 @@ +/* Implementation of gettext(3) function + Copyright (C) 1995, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#ifdef _LIBC +# define __need_NULL +# include +#else +# ifdef STDC_HEADERS +# include /* Just for NULL. */ +# else +# ifdef HAVE_STRING_H +# include +# else +# define NULL ((void *) 0) +# endif +# endif +#endif + +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif + +/* @@ end of prolog @@ */ + +/* Names for the libintl functions are a problem. They must not clash + with existing names and they should follow ANSI C. But this source + code is also used in GNU C Library where the names have a __ + prefix. So we have to make a difference here. */ +#ifdef _LIBC +# define GETTEXT __gettext +# define DGETTEXT __dgettext +#else +# define GETTEXT gettext__ +# define DGETTEXT dgettext__ +#endif + +/* Look up MSGID in the current default message catalog for the current + LC_MESSAGES locale. If not found, returns MSGID itself (the default + text). */ +char * +GETTEXT (msgid) + const char *msgid; +{ + return DGETTEXT (NULL, msgid); +} + +#ifdef _LIBC +/* Alias for function name in GNU C Library. */ +weak_alias (__gettext, gettext); +#endif diff --git a/intl/gettext.h b/intl/gettext.h new file mode 100644 index 00000000..6b4b9e33 --- /dev/null +++ b/intl/gettext.h @@ -0,0 +1,105 @@ +/* Internal header for GNU gettext internationalization functions + Copyright (C) 1995, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +#ifndef _GETTEXT_H +#define _GETTEXT_H 1 + +#include + +#if HAVE_LIMITS_H || _LIBC +# include +#endif + +/* @@ end of prolog @@ */ + +/* The magic number of the GNU message catalog format. */ +#define _MAGIC 0x950412de +#define _MAGIC_SWAPPED 0xde120495 + +/* Revision number of the currently used .mo (binary) file format. */ +#define MO_REVISION_NUMBER 0 + +/* The following contortions are an attempt to use the C preprocessor + to determine an unsigned integral type that is 32 bits wide. An + alternative approach is to use autoconf's AC_CHECK_SIZEOF macro, but + doing that would require that the configure script compile and *run* + the resulting executable. Locally running cross-compiled executables + is usually not possible. */ + +#if __STDC__ +# define UINT_MAX_32_BITS 4294967295U +#else +# define UINT_MAX_32_BITS 0xFFFFFFFF +#endif + +/* If UINT_MAX isn't defined, assume it's a 32-bit type. + This should be valid for all systems GNU cares about because + that doesn't include 16-bit systems, and only modern systems + (that certainly have ) have 64+-bit integral types. */ + +#ifndef UINT_MAX +# define UINT_MAX UINT_MAX_32_BITS +#endif + +#if UINT_MAX == UINT_MAX_32_BITS +typedef unsigned nls_uint32; +#else +# if USHRT_MAX == UINT_MAX_32_BITS +typedef unsigned short nls_uint32; +# else +# if ULONG_MAX == UINT_MAX_32_BITS +typedef unsigned long nls_uint32; +# else + /* The following line is intended to throw an error. Using #error is + not portable enough. */ + "Cannot determine unsigned 32-bit data type." +# endif +# endif +#endif + + +/* Header for binary .mo file format. */ +struct mo_file_header +{ + /* The magic number. */ + nls_uint32 magic; + /* The revision number of the file format. */ + nls_uint32 revision; + /* The number of strings pairs. */ + nls_uint32 nstrings; + /* Offset of table with start offsets of original strings. */ + nls_uint32 orig_tab_offset; + /* Offset of table with start offsets of translation strings. */ + nls_uint32 trans_tab_offset; + /* Size of hashing table. */ + nls_uint32 hash_tab_size; + /* Offset of first hashing entry. */ + nls_uint32 hash_tab_offset; +}; + +struct string_desc +{ + /* Length of addressed string. */ + nls_uint32 length; + /* Offset of string in file. */ + nls_uint32 offset; +}; + +/* @@ begin of epilog @@ */ + +#endif /* gettext.h */ diff --git a/intl/gettextP.h b/intl/gettextP.h new file mode 100644 index 00000000..bb8d5523 --- /dev/null +++ b/intl/gettextP.h @@ -0,0 +1,73 @@ +/* Header describing internals of gettext library + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifndef _GETTEXTP_H +#define _GETTEXTP_H + +#include "loadinfo.h" + +/* @@ end of prolog @@ */ + +#ifndef PARAMS +# if __STDC__ +# define PARAMS(args) args +# else +# define PARAMS(args) () +# endif +#endif + +#ifndef W +# define W(flag, data) ((flag) ? SWAP (data) : (data)) +#endif + + +static nls_uint32 SWAP PARAMS ((nls_uint32 i)); + +static inline nls_uint32 +SWAP (i) + nls_uint32 i; +{ + return (i << 24) | ((i & 0xff00) << 8) | ((i >> 8) & 0xff00) | (i >> 24); +} + + +struct loaded_domain +{ + const char *data; + int must_swap; + nls_uint32 nstrings; + struct string_desc *orig_tab; + struct string_desc *trans_tab; + nls_uint32 hash_size; + nls_uint32 *hash_tab; +}; + +struct binding +{ + struct binding *next; + char *domainname; + char *dirname; +}; + +struct loaded_l10nfile *_nl_find_domain PARAMS ((const char *__dirname, + char *__locale, + const char *__domainname)); +void _nl_load_domain PARAMS ((struct loaded_l10nfile *__domain)); + +/* @@ begin of epilog @@ */ + +#endif /* gettextP.h */ diff --git a/intl/hash-string.h b/intl/hash-string.h new file mode 100644 index 00000000..e66e8417 --- /dev/null +++ b/intl/hash-string.h @@ -0,0 +1,63 @@ +/* Implements a string hashing function. + Copyright (C) 1995, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_VALUES_H +# include +#endif + +/* @@ end of prolog @@ */ + +#ifndef PARAMS +# if __STDC__ +# define PARAMS(Args) Args +# else +# define PARAMS(Args) () +# endif +#endif + +/* We assume to have `unsigned long int' value with at least 32 bits. */ +#define HASHWORDBITS 32 + + +/* Defines the so called `hashpjw' function by P.J. Weinberger + [see Aho/Sethi/Ullman, COMPILERS: Principles, Techniques and Tools, + 1986, 1987 Bell Telephone Laboratories, Inc.] */ +static unsigned long hash_string PARAMS ((const char *__str_param)); + +static inline unsigned long +hash_string (str_param) + const char *str_param; +{ + unsigned long int hval, g; + const char *str = str_param; + + /* Compute the hash value for the given string. */ + hval = 0; + while (*str != '\0') + { + hval <<= 4; + hval += (unsigned long) *str++; + g = hval & ((unsigned long) 0xf << (HASHWORDBITS - 4)); + if (g != 0) + { + hval ^= g >> (HASHWORDBITS - 8); + hval ^= g; + } + } + return hval; +} diff --git a/intl/intl-compat.c b/intl/intl-compat.c new file mode 100644 index 00000000..503efa0f --- /dev/null +++ b/intl/intl-compat.c @@ -0,0 +1,76 @@ +/* intl-compat.c - Stub functions to call gettext functions from GNU gettext + Library. + Copyright (C) 1995 Software Foundation, Inc. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2, or (at your option) +any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include "libgettext.h" + +/* @@ end of prolog @@ */ + + +#undef gettext +#undef dgettext +#undef dcgettext +#undef textdomain +#undef bindtextdomain + + +char * +bindtextdomain (domainname, dirname) + const char *domainname; + const char *dirname; +{ + return bindtextdomain__ (domainname, dirname); +} + + +char * +dcgettext (domainname, msgid, category) + const char *domainname; + const char *msgid; + int category; +{ + return dcgettext__ (domainname, msgid, category); +} + + +char * +dgettext (domainname, msgid) + const char *domainname; + const char *msgid; +{ + return dgettext__ (domainname, msgid); +} + + +char * +gettext (msgid) + const char *msgid; +{ + return gettext__ (msgid); +} + + +char * +textdomain (domainname) + const char *domainname; +{ + return textdomain__ (domainname); +} diff --git a/intl/l10nflist.c b/intl/l10nflist.c new file mode 100644 index 00000000..1b1da1ff --- /dev/null +++ b/intl/l10nflist.c @@ -0,0 +1,409 @@ +/* Handle list of needed message catalogs + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + Written by Ulrich Drepper , 1995. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + + +#if defined HAVE_STRING_H || defined _LIBC +# ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 +# endif +# include +#else +# include +# ifndef memcpy +# define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) +# endif +#endif +#if !HAVE_STRCHR && !defined _LIBC +# ifndef strchr +# define strchr index +# endif +#endif + +#if defined _LIBC || defined HAVE_ARGZ_H +# include +#endif +#include +#include + +#if defined STDC_HEADERS || defined _LIBC +# include +#endif + +#include "loadinfo.h" + +/* On some strange systems still no definition of NULL is found. Sigh! */ +#ifndef NULL +# if defined __STDC__ && __STDC__ +# define NULL ((void *) 0) +# else +# define NULL 0 +# endif +#endif + +/* @@ end of prolog @@ */ + +#ifdef _LIBC +/* Rename the non ANSI C functions. This is required by the standard + because some ANSI C functions will require linking with this object + file and the name space must not be polluted. */ +# define stpcpy(dest, src) __stpcpy(dest, src) +#else +# ifndef HAVE_STPCPY +static char *stpcpy PARAMS ((char *dest, const char *src)); +# endif +#endif + +/* Define function which are usually not available. */ + +#if !defined _LIBC && !defined HAVE___ARGZ_COUNT +/* Returns the number of strings in ARGZ. */ +static size_t argz_count__ PARAMS ((const char *argz, size_t len)); + +static size_t +argz_count__ (argz, len) + const char *argz; + size_t len; +{ + size_t count = 0; + while (len > 0) + { + size_t part_len = strlen (argz); + argz += part_len + 1; + len -= part_len + 1; + count++; + } + return count; +} +# undef __argz_count +# define __argz_count(argz, len) argz_count__ (argz, len) +#endif /* !_LIBC && !HAVE___ARGZ_COUNT */ + +#if !defined _LIBC && !defined HAVE___ARGZ_STRINGIFY +/* Make '\0' separated arg vector ARGZ printable by converting all the '\0's + except the last into the character SEP. */ +static void argz_stringify__ PARAMS ((char *argz, size_t len, int sep)); + +static void +argz_stringify__ (argz, len, sep) + char *argz; + size_t len; + int sep; +{ + while (len > 0) + { + size_t part_len = strlen (argz); + argz += part_len; + len -= part_len + 1; + if (len > 0) + *argz++ = sep; + } +} +# undef __argz_stringify +# define __argz_stringify(argz, len, sep) argz_stringify__ (argz, len, sep) +#endif /* !_LIBC && !HAVE___ARGZ_STRINGIFY */ + +#if !defined _LIBC && !defined HAVE___ARGZ_NEXT +static char *argz_next__ PARAMS ((char *argz, size_t argz_len, + const char *entry)); + +static char * +argz_next__ (argz, argz_len, entry) + char *argz; + size_t argz_len; + const char *entry; +{ + if (entry) + { + if (entry < argz + argz_len) + entry = strchr (entry, '\0') + 1; + + return entry >= argz + argz_len ? NULL : (char *) entry; + } + else + if (argz_len > 0) + return argz; + else + return 0; +} +# undef __argz_next +# define __argz_next(argz, len, entry) argz_next__ (argz, len, entry) +#endif /* !_LIBC && !HAVE___ARGZ_NEXT */ + + +/* Return number of bits set in X. */ +static int pop PARAMS ((int x)); + +static inline int +pop (x) + int x; +{ + /* We assume that no more than 16 bits are used. */ + x = ((x & ~0x5555) >> 1) + (x & 0x5555); + x = ((x & ~0x3333) >> 2) + (x & 0x3333); + x = ((x >> 4) + x) & 0x0f0f; + x = ((x >> 8) + x) & 0xff; + + return x; +} + + +struct loaded_l10nfile * +_nl_make_l10nflist (l10nfile_list, dirlist, dirlist_len, mask, language, + territory, codeset, normalized_codeset, modifier, special, + sponsor, revision, filename, do_allocate) + struct loaded_l10nfile **l10nfile_list; + const char *dirlist; + size_t dirlist_len; + int mask; + const char *language; + const char *territory; + const char *codeset; + const char *normalized_codeset; + const char *modifier; + const char *special; + const char *sponsor; + const char *revision; + const char *filename; + int do_allocate; +{ + char *abs_filename; + struct loaded_l10nfile *last = NULL; + struct loaded_l10nfile *retval; + char *cp; + size_t entries; + int cnt; + + /* Allocate room for the full file name. */ + abs_filename = (char *) malloc (dirlist_len + + strlen (language) + + ((mask & TERRITORY) != 0 + ? strlen (territory) + 1 : 0) + + ((mask & XPG_CODESET) != 0 + ? strlen (codeset) + 1 : 0) + + ((mask & XPG_NORM_CODESET) != 0 + ? strlen (normalized_codeset) + 1 : 0) + + (((mask & XPG_MODIFIER) != 0 + || (mask & CEN_AUDIENCE) != 0) + ? strlen (modifier) + 1 : 0) + + ((mask & CEN_SPECIAL) != 0 + ? strlen (special) + 1 : 0) + + (((mask & CEN_SPONSOR) != 0 + || (mask & CEN_REVISION) != 0) + ? (1 + ((mask & CEN_SPONSOR) != 0 + ? strlen (sponsor) + 1 : 0) + + ((mask & CEN_REVISION) != 0 + ? strlen (revision) + 1 : 0)) : 0) + + 1 + strlen (filename) + 1); + + if (abs_filename == NULL) + return NULL; + + retval = NULL; + last = NULL; + + /* Construct file name. */ + memcpy (abs_filename, dirlist, dirlist_len); + __argz_stringify (abs_filename, dirlist_len, ':'); + cp = abs_filename + (dirlist_len - 1); + *cp++ = '/'; + cp = stpcpy (cp, language); + + if ((mask & TERRITORY) != 0) + { + *cp++ = '_'; + cp = stpcpy (cp, territory); + } + if ((mask & XPG_CODESET) != 0) + { + *cp++ = '.'; + cp = stpcpy (cp, codeset); + } + if ((mask & XPG_NORM_CODESET) != 0) + { + *cp++ = '.'; + cp = stpcpy (cp, normalized_codeset); + } + if ((mask & (XPG_MODIFIER | CEN_AUDIENCE)) != 0) + { + /* This component can be part of both syntaces but has different + leading characters. For CEN we use `+', else `@'. */ + *cp++ = (mask & CEN_AUDIENCE) != 0 ? '+' : '@'; + cp = stpcpy (cp, modifier); + } + if ((mask & CEN_SPECIAL) != 0) + { + *cp++ = '+'; + cp = stpcpy (cp, special); + } + if ((mask & (CEN_SPONSOR | CEN_REVISION)) != 0) + { + *cp++ = ','; + if ((mask & CEN_SPONSOR) != 0) + cp = stpcpy (cp, sponsor); + if ((mask & CEN_REVISION) != 0) + { + *cp++ = '_'; + cp = stpcpy (cp, revision); + } + } + + *cp++ = '/'; + stpcpy (cp, filename); + + /* Look in list of already loaded domains whether it is already + available. */ + last = NULL; + for (retval = *l10nfile_list; retval != NULL; retval = retval->next) + if (retval->filename != NULL) + { + int compare = strcmp (retval->filename, abs_filename); + if (compare == 0) + /* We found it! */ + break; + if (compare < 0) + { + /* It's not in the list. */ + retval = NULL; + break; + } + + last = retval; + } + + if (retval != NULL || do_allocate == 0) + { + free (abs_filename); + return retval; + } + + retval = (struct loaded_l10nfile *) + malloc (sizeof (*retval) + (__argz_count (dirlist, dirlist_len) + * (1 << pop (mask)) + * sizeof (struct loaded_l10nfile *))); + if (retval == NULL) + return NULL; + + retval->filename = abs_filename; + retval->decided = (__argz_count (dirlist, dirlist_len) != 1 + || ((mask & XPG_CODESET) != 0 + && (mask & XPG_NORM_CODESET) != 0)); + retval->data = NULL; + + if (last == NULL) + { + retval->next = *l10nfile_list; + *l10nfile_list = retval; + } + else + { + retval->next = last->next; + last->next = retval; + } + + entries = 0; + /* If the DIRLIST is a real list the RETVAL entry corresponds not to + a real file. So we have to use the DIRLIST separation mechanism + of the inner loop. */ + cnt = __argz_count (dirlist, dirlist_len) == 1 ? mask - 1 : mask; + for (; cnt >= 0; --cnt) + if ((cnt & ~mask) == 0 + && ((cnt & CEN_SPECIFIC) == 0 || (cnt & XPG_SPECIFIC) == 0) + && ((cnt & XPG_CODESET) == 0 || (cnt & XPG_NORM_CODESET) == 0)) + { + /* Iterate over all elements of the DIRLIST. */ + char *dir = NULL; + + while ((dir = __argz_next ((char *) dirlist, dirlist_len, dir)) + != NULL) + retval->successor[entries++] + = _nl_make_l10nflist (l10nfile_list, dir, strlen (dir) + 1, cnt, + language, territory, codeset, + normalized_codeset, modifier, special, + sponsor, revision, filename, 1); + } + retval->successor[entries] = NULL; + + return retval; +} + +/* Normalize codeset name. There is no standard for the codeset + names. Normalization allows the user to use any of the common + names. */ +const char * +_nl_normalize_codeset (codeset, name_len) + const char *codeset; + size_t name_len; +{ + int len = 0; + int only_digit = 1; + char *retval; + char *wp; + size_t cnt; + + for (cnt = 0; cnt < name_len; ++cnt) + if (isalnum (codeset[cnt])) + { + ++len; + + if (isalpha (codeset[cnt])) + only_digit = 0; + } + + retval = (char *) malloc ((only_digit ? 3 : 0) + len + 1); + + if (retval != NULL) + { + if (only_digit) + wp = stpcpy (retval, "iso"); + else + wp = retval; + + for (cnt = 0; cnt < name_len; ++cnt) + if (isalpha (codeset[cnt])) + *wp++ = tolower (codeset[cnt]); + else if (isdigit (codeset[cnt])) + *wp++ = codeset[cnt]; + + *wp = '\0'; + } + + return (const char *) retval; +} + + +/* @@ begin of epilog @@ */ + +/* We don't want libintl.a to depend on any other library. So we + avoid the non-standard function stpcpy. In GNU C Library this + function is available, though. Also allow the symbol HAVE_STPCPY + to be defined. */ +#if !_LIBC && !HAVE_STPCPY +static char * +stpcpy (dest, src) + char *dest; + const char *src; +{ + while ((*dest++ = *src++) != '\0') + /* Do nothing. */ ; + return dest - 1; +} +#endif diff --git a/intl/libgettext.h b/intl/libgettext.h new file mode 100644 index 00000000..0d4de4d0 --- /dev/null +++ b/intl/libgettext.h @@ -0,0 +1,182 @@ +/* Message catalogs for internationalization. + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +/* Because on some systems (e.g. Solaris) we sometimes have to include + the systems libintl.h as well as this file we have more complex + include protection above. But the systems header might perhaps also + define _LIBINTL_H and therefore we have to protect the definition here. */ + +#if !defined (_LIBINTL_H) || !defined (_LIBGETTEXT_H) +#if !defined (_LIBINTL_H) +# define _LIBINTL_H 1 +#endif +#define _LIBGETTEXT_H 1 + +/* We define an additional symbol to signal that we use the GNU + implementation of gettext. */ +#define __USE_GNU_GETTEXT 1 + +#include + +#if HAVE_LOCALE_H +# include +#endif + + +#ifdef __cplusplus +extern "C" { +#endif + +/* @@ end of prolog @@ */ + +#ifndef PARAMS +# if __STDC__ +# define PARAMS(args) args +# else +# define PARAMS(args) () +# endif +#endif + +#ifndef NULL +# if !defined __cplusplus || defined __GNUC__ +# define NULL ((void *) 0) +# else +# define NULL (0) +# endif +#endif + +#if !HAVE_LC_MESSAGES +/* This value determines the behaviour of the gettext() and dgettext() + function. But some system does not have this defined. Define it + to a default value. */ +# define LC_MESSAGES (-1) +#endif + + +/* Declarations for gettext-using-catgets interface. Derived from + Jim Meyering's libintl.h. */ +struct _msg_ent +{ + const char *_msg; + int _msg_number; +}; + + +#if HAVE_CATGETS +/* These two variables are defined in the automatically by po-to-tbl.sed + generated file `cat-id-tbl.c'. */ +extern const struct _msg_ent _msg_tbl[]; +extern int _msg_tbl_length; +#endif + + +/* For automatical extraction of messages sometimes no real + translation is needed. Instead the string itself is the result. */ +#define gettext_noop(Str) (Str) + +/* Look up MSGID in the current default message catalog for the current + LC_MESSAGES locale. If not found, returns MSGID itself (the default + text). */ +extern char *gettext PARAMS ((const char *__msgid)); +extern char *gettext__ PARAMS ((const char *__msgid)); + +/* Look up MSGID in the DOMAINNAME message catalog for the current + LC_MESSAGES locale. */ +extern char *dgettext PARAMS ((const char *__domainname, const char *__msgid)); +extern char *dgettext__ PARAMS ((const char *__domainname, + const char *__msgid)); + +/* Look up MSGID in the DOMAINNAME message catalog for the current CATEGORY + locale. */ +extern char *dcgettext PARAMS ((const char *__domainname, const char *__msgid, + int __category)); +extern char *dcgettext__ PARAMS ((const char *__domainname, + const char *__msgid, int __category)); + + +/* Set the current default message catalog to DOMAINNAME. + If DOMAINNAME is null, return the current default. + If DOMAINNAME is "", reset to the default of "messages". */ +extern char *textdomain PARAMS ((const char *__domainname)); +extern char *textdomain__ PARAMS ((const char *__domainname)); + +/* Specify that the DOMAINNAME message catalog will be found + in DIRNAME rather than in the system locale data base. */ +extern char *bindtextdomain PARAMS ((const char *__domainname, + const char *__dirname)); +extern char *bindtextdomain__ PARAMS ((const char *__domainname, + const char *__dirname)); + +#if ENABLE_NLS + +/* Solaris 2.3 has the gettext function but dcgettext is missing. + So we omit this optimization for Solaris 2.3. BTW, Solaris 2.4 + has dcgettext. */ +# if !HAVE_CATGETS && (!HAVE_GETTEXT || HAVE_DCGETTEXT) + +# define gettext(Msgid) \ + dgettext (NULL, Msgid) + +# define dgettext(Domainname, Msgid) \ + dcgettext (Domainname, Msgid, LC_MESSAGES) + +# if defined __GNUC__ && __GNUC__ == 2 && __GNUC_MINOR__ >= 7 +/* This global variable is defined in loadmsgcat.c. We need a sign, + whether a new catalog was loaded, which can be associated with all + translations. */ +extern int _nl_msg_cat_cntr; + +# define dcgettext(Domainname, Msgid, Category) \ + (__extension__ \ + ({ \ + char *__result; \ + if (__builtin_constant_p (Msgid)) \ + { \ + static char *__translation__; \ + static int __catalog_counter__; \ + if (! __translation__ || __catalog_counter__ != _nl_msg_cat_cntr) \ + { \ + __translation__ = \ + dcgettext__ (Domainname, Msgid, Category); \ + __catalog_counter__ = _nl_msg_cat_cntr; \ + } \ + __result = __translation__; \ + } \ + else \ + __result = dcgettext__ (Domainname, Msgid, Category); \ + __result; \ + })) +# endif +# endif + +#else + +# define gettext(Msgid) (Msgid) +# define dgettext(Domainname, Msgid) (Msgid) +# define dcgettext(Domainname, Msgid, Category) (Msgid) +# define textdomain(Domainname) while (0) /* nothing */ +# define bindtextdomain(Domainname, Dirname) while (0) /* nothing */ + +#endif + +/* @@ begin of epilog @@ */ + +#ifdef __cplusplus +} +#endif + +#endif diff --git a/intl/linux-msg.sed b/intl/linux-msg.sed new file mode 100644 index 00000000..7feb38d6 --- /dev/null +++ b/intl/linux-msg.sed @@ -0,0 +1,100 @@ +# po2msg.sed - Convert Uniforum style .po file to Linux style .msg file +# Copyright (C) 1995 Free Software Foundation, Inc. +# Ulrich Drepper , 1995. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# +# The first directive in the .msg should be the definition of the +# message set number. We use always set number 1. +# +1 { + i\ +$set 1 # Automatically created by po2msg.sed + h + s/.*/0/ + x +} +# +# Mitch's old catalog format does not allow comments. +# +# We copy the original message as a comment into the .msg file. +# +/^msgid/ { + s/msgid[ ]*"// +# +# This does not work now with the new format. +# /"$/! { +# s/\\$// +# s/$/ ... (more lines following)"/ +# } + x +# The following nice solution is by +# Bruno + td +# Increment a decimal number in pattern space. +# First hide trailing `9' digits. + :d + s/9\(_*\)$/_\1/ + td +# Assure at least one digit is available. + s/^\(_*\)$/0\1/ +# Increment the last digit. + s/8\(_*\)$/9\1/ + s/7\(_*\)$/8\1/ + s/6\(_*\)$/7\1/ + s/5\(_*\)$/6\1/ + s/4\(_*\)$/5\1/ + s/3\(_*\)$/4\1/ + s/2\(_*\)$/3\1/ + s/1\(_*\)$/2\1/ + s/0\(_*\)$/1\1/ +# Convert the hidden `9' digits to `0's. + s/_/0/g + x + G + s/\(.*\)"\n\([0-9]*\)/$ #\2 Original Message:(\1)/p +} +# +# The .msg file contains, other then the .po file, only the translations +# but each given a unique ID. Starting from 1 and incrementing by 1 for +# each message we assign them to the messages. +# It is important that the .po file used to generate the cat-id-tbl.c file +# (with po-to-tbl) is the same as the one used here. (At least the order +# of declarations must not be changed.) +# +/^msgstr/ { + s/msgstr[ ]*"\(.*\)"/# \1/ +# Clear substitution flag. + tb +# Append the next line. + :b + N +# Look whether second part is continuation line. + s/\(.*\n\)"\(.*\)"/\1\2/ +# Yes, then branch. + ta + P + D +# Note that D includes a jump to the start!! +# We found a continuation line. But before printing insert '\'. + :a + s/\(.*\)\(\n.*\)/\1\\\2/ + P +# We cannot use D here. + s/.*\n\(.*\)/\1/ + tb +} +d diff --git a/intl/loadinfo.h b/intl/loadinfo.h new file mode 100644 index 00000000..c67c2eb2 --- /dev/null +++ b/intl/loadinfo.h @@ -0,0 +1,58 @@ +#ifndef PARAMS +# if __STDC__ +# define PARAMS(args) args +# else +# define PARAMS(args) () +# endif +#endif + +/* Encoding of locale name parts. */ +#define CEN_REVISION 1 +#define CEN_SPONSOR 2 +#define CEN_SPECIAL 4 +#define XPG_NORM_CODESET 8 +#define XPG_CODESET 16 +#define TERRITORY 32 +#define CEN_AUDIENCE 64 +#define XPG_MODIFIER 128 + +#define CEN_SPECIFIC (CEN_REVISION|CEN_SPONSOR|CEN_SPECIAL|CEN_AUDIENCE) +#define XPG_SPECIFIC (XPG_CODESET|XPG_NORM_CODESET|XPG_MODIFIER) + + +struct loaded_l10nfile +{ + const char *filename; + int decided; + + const void *data; + + struct loaded_l10nfile *next; + struct loaded_l10nfile *successor[1]; +}; + + +extern const char *_nl_normalize_codeset PARAMS ((const char *codeset, + size_t name_len)); + +extern struct loaded_l10nfile * +_nl_make_l10nflist PARAMS ((struct loaded_l10nfile **l10nfile_list, + const char *dirlist, size_t dirlist_len, int mask, + const char *language, const char *territory, + const char *codeset, + const char *normalized_codeset, + const char *modifier, const char *special, + const char *sponsor, const char *revision, + const char *filename, int do_allocate)); + + +extern const char *_nl_expand_alias PARAMS ((const char *name)); + +extern int _nl_explode_name PARAMS ((char *name, const char **language, + const char **modifier, + const char **territory, + const char **codeset, + const char **normalized_codeset, + const char **special, + const char **sponsor, + const char **revision)); diff --git a/intl/loadmsgcat.c b/intl/loadmsgcat.c new file mode 100644 index 00000000..73e90a91 --- /dev/null +++ b/intl/loadmsgcat.c @@ -0,0 +1,199 @@ +/* Load needed message catalogs + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include + +#if defined STDC_HEADERS || defined _LIBC +# include +#endif + +#if defined HAVE_UNISTD_H || defined _LIBC +# include +#endif + +#if (defined HAVE_MMAP && defined HAVE_MUNMAP) || defined _LIBC +# include +#endif + +#include "gettext.h" +#include "gettextP.h" + +/* @@ end of prolog @@ */ + +#ifdef _LIBC +/* Rename the non ISO C functions. This is required by the standard + because some ISO C functions will require linking with this object + file and the name space must not be polluted. */ +# define fstat __fstat +# define open __open +# define close __close +# define read __read +# define mmap __mmap +# define munmap __munmap +#endif + +/* We need a sign, whether a new catalog was loaded, which can be associated + with all translations. This is important if the translations are + cached by one of GCC's features. */ +int _nl_msg_cat_cntr = 0; + + +/* Load the message catalogs specified by FILENAME. If it is no valid + message catalog do nothing. */ +void +_nl_load_domain (domain_file) + struct loaded_l10nfile *domain_file; +{ + int fd; + struct stat st; + struct mo_file_header *data = (struct mo_file_header *) -1; +#if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ + || defined _LIBC + int use_mmap = 0; +#endif + struct loaded_domain *domain; + + domain_file->decided = 1; + domain_file->data = NULL; + + /* If the record does not represent a valid locale the FILENAME + might be NULL. This can happen when according to the given + specification the locale file name is different for XPG and CEN + syntax. */ + if (domain_file->filename == NULL) + return; + + /* Try to open the addressed file. */ + fd = open (domain_file->filename, O_RDONLY); + if (fd == -1) + return; + + /* We must know about the size of the file. */ + if (fstat (fd, &st) != 0 + && st.st_size < (off_t) sizeof (struct mo_file_header)) + { + /* Something went wrong. */ + close (fd); + return; + } + +#if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ + || defined _LIBC + /* Now we are ready to load the file. If mmap() is available we try + this first. If not available or it failed we try to load it. */ + data = (struct mo_file_header *) mmap (NULL, st.st_size, PROT_READ, + MAP_PRIVATE, fd, 0); + + if (data != (struct mo_file_header *) -1) + { + /* mmap() call was successful. */ + close (fd); + use_mmap = 1; + } +#endif + + /* If the data is not yet available (i.e. mmap'ed) we try to load + it manually. */ + if (data == (struct mo_file_header *) -1) + { + off_t to_read; + char *read_ptr; + + data = (struct mo_file_header *) malloc (st.st_size); + if (data == NULL) + return; + + to_read = st.st_size; + read_ptr = (char *) data; + do + { + long int nb = (long int) read (fd, read_ptr, to_read); + if (nb == -1) + { + close (fd); + return; + } + + read_ptr += nb; + to_read -= nb; + } + while (to_read > 0); + + close (fd); + } + + /* Using the magic number we can test whether it really is a message + catalog file. */ + if (data->magic != _MAGIC && data->magic != _MAGIC_SWAPPED) + { + /* The magic number is wrong: not a message catalog file. */ +#if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ + || defined _LIBC + if (use_mmap) + munmap ((caddr_t) data, st.st_size); + else +#endif + free (data); + return; + } + + domain_file->data + = (struct loaded_domain *) malloc (sizeof (struct loaded_domain)); + if (domain_file->data == NULL) + return; + + domain = (struct loaded_domain *) domain_file->data; + domain->data = (char *) data; + domain->must_swap = data->magic != _MAGIC; + + /* Fill in the information about the available tables. */ + switch (W (domain->must_swap, data->revision)) + { + case 0: + domain->nstrings = W (domain->must_swap, data->nstrings); + domain->orig_tab = (struct string_desc *) + ((char *) data + W (domain->must_swap, data->orig_tab_offset)); + domain->trans_tab = (struct string_desc *) + ((char *) data + W (domain->must_swap, data->trans_tab_offset)); + domain->hash_size = W (domain->must_swap, data->hash_tab_size); + domain->hash_tab = (nls_uint32 *) + ((char *) data + W (domain->must_swap, data->hash_tab_offset)); + break; + default: + /* This is an illegal revision. */ +#if (defined HAVE_MMAP && defined HAVE_MUNMAP && !defined DISALLOW_MMAP) \ + || defined _LIBC + if (use_mmap) + munmap ((caddr_t) data, st.st_size); + else +#endif + free (data); + free (domain); + domain_file->data = NULL; + return; + } + + /* Show that one domain is changed. This might make some cached + translations invalid. */ + ++_nl_msg_cat_cntr; +} diff --git a/intl/localealias.c b/intl/localealias.c new file mode 100644 index 00000000..64e8ca78 --- /dev/null +++ b/intl/localealias.c @@ -0,0 +1,378 @@ +/* Handle aliases for locale names + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + Written by Ulrich Drepper , 1995. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#include +#include +#include + +#ifdef __GNUC__ +# define alloca __builtin_alloca +# define HAVE_ALLOCA 1 +#else +# if defined HAVE_ALLOCA_H || defined _LIBC +# include +# else +# ifdef _AIX + #pragma alloca +# else +# ifndef alloca +char *alloca (); +# endif +# endif +# endif +#endif + +#if defined STDC_HEADERS || defined _LIBC +# include +#else +char *getenv (); +# ifdef HAVE_MALLOC_H +# include +# else +void free (); +# endif +#endif + +#if defined HAVE_STRING_H || defined _LIBC +# ifndef _GNU_SOURCE +# define _GNU_SOURCE 1 +# endif +# include +#else +# include +# ifndef memcpy +# define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) +# endif +#endif +#if !HAVE_STRCHR && !defined _LIBC +# ifndef strchr +# define strchr index +# endif +#endif + +#include "gettext.h" +#include "gettextP.h" + +/* @@ end of prolog @@ */ + +#ifdef _LIBC +/* Rename the non ANSI C functions. This is required by the standard + because some ANSI C functions will require linking with this object + file and the name space must not be polluted. */ +# define strcasecmp __strcasecmp +#endif + + +/* For those loosing systems which don't have `alloca' we have to add + some additional code emulating it. */ +#ifdef HAVE_ALLOCA +/* Nothing has to be done. */ +# define ADD_BLOCK(list, address) /* nothing */ +# define FREE_BLOCKS(list) /* nothing */ +#else +struct block_list +{ + void *address; + struct block_list *next; +}; +# define ADD_BLOCK(list, addr) \ + do { \ + struct block_list *newp = (struct block_list *) malloc (sizeof (*newp)); \ + /* If we cannot get a free block we cannot add the new element to \ + the list. */ \ + if (newp != NULL) { \ + newp->address = (addr); \ + newp->next = (list); \ + (list) = newp; \ + } \ + } while (0) +# define FREE_BLOCKS(list) \ + do { \ + while (list != NULL) { \ + struct block_list *old = list; \ + list = list->next; \ + free (old); \ + } \ + } while (0) +# undef alloca +# define alloca(size) (malloc (size)) +#endif /* have alloca */ + + +struct alias_map +{ + const char *alias; + const char *value; +}; + + +static struct alias_map *map; +static size_t nmap = 0; +static size_t maxmap = 0; + + +/* Prototypes for local functions. */ +static size_t read_alias_file PARAMS ((const char *fname, int fname_len)); +static void extend_alias_table PARAMS ((void)); +static int alias_compare PARAMS ((const struct alias_map *map1, + const struct alias_map *map2)); + + +const char * +_nl_expand_alias (name) + const char *name; +{ + static const char *locale_alias_path = LOCALE_ALIAS_PATH; + struct alias_map *retval; + size_t added; + + do + { + struct alias_map item; + + item.alias = name; + + if (nmap > 0) + retval = (struct alias_map *) bsearch (&item, map, nmap, + sizeof (struct alias_map), + (int (*) PARAMS ((const void *, + const void *)) + ) alias_compare); + else + retval = NULL; + + /* We really found an alias. Return the value. */ + if (retval != NULL) + return retval->value; + + /* Perhaps we can find another alias file. */ + added = 0; + while (added == 0 && locale_alias_path[0] != '\0') + { + const char *start; + + while (locale_alias_path[0] == ':') + ++locale_alias_path; + start = locale_alias_path; + + while (locale_alias_path[0] != '\0' && locale_alias_path[0] != ':') + ++locale_alias_path; + + if (start < locale_alias_path) + added = read_alias_file (start, locale_alias_path - start); + } + } + while (added != 0); + + return NULL; +} + + +static size_t +read_alias_file (fname, fname_len) + const char *fname; + int fname_len; +{ +#ifndef HAVE_ALLOCA + struct block_list *block_list = NULL; +#endif + FILE *fp; + char *full_fname; + size_t added; + static const char aliasfile[] = "/locale.alias"; + + full_fname = (char *) alloca (fname_len + sizeof aliasfile); + ADD_BLOCK (block_list, full_fname); + memcpy (full_fname, fname, fname_len); + memcpy (&full_fname[fname_len], aliasfile, sizeof aliasfile); + + fp = fopen (full_fname, "r"); + if (fp == NULL) + { + FREE_BLOCKS (block_list); + return 0; + } + + added = 0; + while (!feof (fp)) + { + /* It is a reasonable approach to use a fix buffer here because + a) we are only interested in the first two fields + b) these fields must be usable as file names and so must not + be that long + */ + char buf[BUFSIZ]; + char *alias; + char *value; + char *cp; + + if (fgets (buf, BUFSIZ, fp) == NULL) + /* EOF reached. */ + break; + + cp = buf; + /* Ignore leading white space. */ + while (isspace (cp[0])) + ++cp; + + /* A leading '#' signals a comment line. */ + if (cp[0] != '\0' && cp[0] != '#') + { + alias = cp++; + while (cp[0] != '\0' && !isspace (cp[0])) + ++cp; + /* Terminate alias name. */ + if (cp[0] != '\0') + *cp++ = '\0'; + + /* Now look for the beginning of the value. */ + while (isspace (cp[0])) + ++cp; + + if (cp[0] != '\0') + { + char *tp; + size_t len; + + value = cp++; + while (cp[0] != '\0' && !isspace (cp[0])) + ++cp; + /* Terminate value. */ + if (cp[0] == '\n') + { + /* This has to be done to make the following test + for the end of line possible. We are looking for + the terminating '\n' which do not overwrite here. */ + *cp++ = '\0'; + *cp = '\n'; + } + else if (cp[0] != '\0') + *cp++ = '\0'; + + if (nmap >= maxmap) + extend_alias_table (); + + /* We cannot depend on strdup available in the libc. Sigh! */ + len = strlen (alias) + 1; + tp = (char *) malloc (len); + if (tp == NULL) + { + FREE_BLOCKS (block_list); + return added; + } + memcpy (tp, alias, len); + map[nmap].alias = tp; + + len = strlen (value) + 1; + tp = (char *) malloc (len); + if (tp == NULL) + { + FREE_BLOCKS (block_list); + return added; + } + memcpy (tp, value, len); + map[nmap].value = tp; + + ++nmap; + ++added; + } + } + + /* Possibly not the whole line fits into the buffer. Ignore + the rest of the line. */ + while (strchr (cp, '\n') == NULL) + { + cp = buf; + if (fgets (buf, BUFSIZ, fp) == NULL) + /* Make sure the inner loop will be left. The outer loop + will exit at the `feof' test. */ + *cp = '\n'; + } + } + + /* Should we test for ferror()? I think we have to silently ignore + errors. --drepper */ + fclose (fp); + + if (added > 0) + qsort (map, nmap, sizeof (struct alias_map), + (int (*) PARAMS ((const void *, const void *))) alias_compare); + + FREE_BLOCKS (block_list); + return added; +} + + +static void +extend_alias_table () +{ + size_t new_size; + struct alias_map *new_map; + + new_size = maxmap == 0 ? 100 : 2 * maxmap; + new_map = (struct alias_map *) malloc (new_size + * sizeof (struct alias_map)); + if (new_map == NULL) + /* Simply don't extend: we don't have any more core. */ + return; + + memcpy (new_map, map, nmap * sizeof (struct alias_map)); + + if (maxmap != 0) + free (map); + + map = new_map; + maxmap = new_size; +} + + +static int +alias_compare (map1, map2) + const struct alias_map *map1; + const struct alias_map *map2; +{ +#if defined _LIBC || defined HAVE_STRCASECMP + return strcasecmp (map1->alias, map2->alias); +#else + const unsigned char *p1 = (const unsigned char *) map1->alias; + const unsigned char *p2 = (const unsigned char *) map2->alias; + unsigned char c1, c2; + + if (p1 == p2) + return 0; + + do + { + /* I know this seems to be odd but the tolower() function in + some systems libc cannot handle nonalpha characters. */ + c1 = isupper (*p1) ? tolower (*p1) : *p1; + c2 = isupper (*p2) ? tolower (*p2) : *p2; + if (c1 == '\0') + break; + ++p1; + ++p2; + } + while (c1 == c2); + + return c1 - c2; +#endif +} diff --git a/intl/po2tbl.sed.in b/intl/po2tbl.sed.in new file mode 100644 index 00000000..247b668a --- /dev/null +++ b/intl/po2tbl.sed.in @@ -0,0 +1,102 @@ +# po2tbl.sed - Convert Uniforum style .po file to lookup table for catgets +# Copyright (C) 1995 Free Software Foundation, Inc. +# Ulrich Drepper , 1995. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +1 { + i\ +/* Automatically generated by po2tbl.sed from @PACKAGE NAME@.pot. */\ +\ +#if HAVE_CONFIG_H\ +# include \ +#endif\ +\ +#include "libgettext.h"\ +\ +const struct _msg_ent _msg_tbl[] = { + h + s/.*/0/ + x +} +# +# Write msgid entries in C array form. +# +/^msgid/ { + s/msgid[ ]*\(".*"\)/ {\1/ + tb +# Append the next line + :b + N +# Look whether second part is continuation line. + s/\(.*\)"\(\n\)"\(.*"\)/\1\2\3/ +# Yes, then branch. + ta +# Because we assume that the input file correctly formed the line +# just read cannot be again be a msgid line. So it's safe to ignore +# it. + s/\(.*\)\n.*/\1/ + bc +# We found a continuation line. But before printing insert '\'. + :a + s/\(.*\)\(\n.*\)/\1\\\2/ + P +# We cannot use D here. + s/.*\n\(.*\)/\1/ +# Some buggy seds do not clear the `successful substitution since last ``t''' +# flag on `N', so we do a `t' here to clear it. + tb +# Not reached + :c + x +# The following nice solution is by +# Bruno + td +# Increment a decimal number in pattern space. +# First hide trailing `9' digits. + :d + s/9\(_*\)$/_\1/ + td +# Assure at least one digit is available. + s/^\(_*\)$/0\1/ +# Increment the last digit. + s/8\(_*\)$/9\1/ + s/7\(_*\)$/8\1/ + s/6\(_*\)$/7\1/ + s/5\(_*\)$/6\1/ + s/4\(_*\)$/5\1/ + s/3\(_*\)$/4\1/ + s/2\(_*\)$/3\1/ + s/1\(_*\)$/2\1/ + s/0\(_*\)$/1\1/ +# Convert the hidden `9' digits to `0's. + s/_/0/g + x + G + s/\(.*\)\n\([0-9]*\)/\1, \2},/ + s/\(.*\)"$/\1/ + p +} +# +# Last line. +# +$ { + i\ +};\ + + g + s/0*\(.*\)/int _msg_tbl_length = \1;/p +} +d diff --git a/intl/textdomain.c b/intl/textdomain.c new file mode 100644 index 00000000..beb1f06d --- /dev/null +++ b/intl/textdomain.c @@ -0,0 +1,106 @@ +/* Implementation of the textdomain(3) function + Copyright (C) 1995, 1996, 1997 Free Software Foundation, Inc. + Written by Ulrich Drepper , 1995. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#ifdef HAVE_CONFIG_H +# include +#endif + +#if defined STDC_HEADERS || defined _LIBC +# include +#endif + +#if defined STDC_HEADERS || defined HAVE_STRING_H || defined _LIBC +# include +#else +# include +# ifndef memcpy +# define memcpy(Dst, Src, Num) bcopy (Src, Dst, Num) +# endif +#endif + +#ifdef _LIBC +# include +#else +# include "libgettext.h" +#endif + +/* @@ end of prolog @@ */ + +/* Name of the default text domain. */ +extern const char _nl_default_default_domain[]; + +/* Default text domain in which entries for gettext(3) are to be found. */ +extern const char *_nl_current_default_domain; + + +/* Names for the libintl functions are a problem. They must not clash + with existing names and they should follow ANSI C. But this source + code is also used in GNU C Library where the names have a __ + prefix. So we have to make a difference here. */ +#ifdef _LIBC +# define TEXTDOMAIN __textdomain +# define strdup(str) __strdup (str) +#else +# define TEXTDOMAIN textdomain__ +#endif + +/* Set the current default message catalog to DOMAINNAME. + If DOMAINNAME is null, return the current default. + If DOMAINNAME is "", reset to the default of "messages". */ +char * +TEXTDOMAIN (domainname) + const char *domainname; +{ + char *old; + + /* A NULL pointer requests the current setting. */ + if (domainname == NULL) + return (char *) _nl_current_default_domain; + + old = (char *) _nl_current_default_domain; + + /* If domain name is the null string set to default domain "messages". */ + if (domainname[0] == '\0' + || strcmp (domainname, _nl_default_default_domain) == 0) + _nl_current_default_domain = _nl_default_default_domain; + else + { + /* If the following malloc fails `_nl_current_default_domain' + will be NULL. This value will be returned and so signals we + are out of core. */ +#if defined _LIBC || defined HAVE_STRDUP + _nl_current_default_domain = strdup (domainname); +#else + size_t len = strlen (domainname) + 1; + char *cp = (char *) malloc (len); + if (cp != NULL) + memcpy (cp, domainname, len); + _nl_current_default_domain = cp; +#endif + } + + if (old != _nl_default_default_domain) + free (old); + + return (char *) _nl_current_default_domain; +} + +#ifdef _LIBC +/* Alias for function name in GNU C Library. */ +weak_alias (__textdomain, textdomain); +#endif diff --git a/intl/xopen-msg.sed b/intl/xopen-msg.sed new file mode 100644 index 00000000..b35588f0 --- /dev/null +++ b/intl/xopen-msg.sed @@ -0,0 +1,104 @@ +# po2msg.sed - Convert Uniforum style .po file to X/Open style .msg file +# Copyright (C) 1995 Free Software Foundation, Inc. +# Ulrich Drepper , 1995. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2, or (at your option) +# any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +# +# +# The first directive in the .msg should be the definition of the +# message set number. We use always set number 1. +# +1 { + i\ +$set 1 # Automatically created by po2msg.sed + h + s/.*/0/ + x +} +# +# We copy all comments into the .msg file. Perhaps they can help. +# +/^#/ s/^#[ ]*/$ /p +# +# We copy the original message as a comment into the .msg file. +# +/^msgid/ { +# Does not work now +# /"$/! { +# s/\\$// +# s/$/ ... (more lines following)"/ +# } + s/^msgid[ ]*"\(.*\)"$/$ Original Message: \1/ + p +} +# +# The .msg file contains, other then the .po file, only the translations +# but each given a unique ID. Starting from 1 and incrementing by 1 for +# each message we assign them to the messages. +# It is important that the .po file used to generate the cat-id-tbl.c file +# (with po-to-tbl) is the same as the one used here. (At least the order +# of declarations must not be changed.) +# +/^msgstr/ { + s/msgstr[ ]*"\(.*\)"/\1/ + x +# The following nice solution is by +# Bruno + td +# Increment a decimal number in pattern space. +# First hide trailing `9' digits. + :d + s/9\(_*\)$/_\1/ + td +# Assure at least one digit is available. + s/^\(_*\)$/0\1/ +# Increment the last digit. + s/8\(_*\)$/9\1/ + s/7\(_*\)$/8\1/ + s/6\(_*\)$/7\1/ + s/5\(_*\)$/6\1/ + s/4\(_*\)$/5\1/ + s/3\(_*\)$/4\1/ + s/2\(_*\)$/3\1/ + s/1\(_*\)$/2\1/ + s/0\(_*\)$/1\1/ +# Convert the hidden `9' digits to `0's. + s/_/0/g + x +# Bring the line in the format ` ' + G + s/^[^\n]*$/& / + s/\(.*\)\n\([0-9]*\)/\2 \1/ +# Clear flag from last substitution. + tb +# Append the next line. + :b + N +# Look whether second part is a continuation line. + s/\(.*\n\)"\(.*\)"/\1\2/ +# Yes, then branch. + ta + P + D +# Note that `D' includes a jump to the start!! +# We found a continuation line. But before printing insert '\'. + :a + s/\(.*\)\(\n.*\)/\1\\\2/ + P +# We cannot use the sed command `D' here + s/.*\n\(.*\)/\1/ + tb +} +d diff --git a/lib/ChangeLog b/lib/ChangeLog new file mode 100644 index 00000000..211133d4 --- /dev/null +++ b/lib/ChangeLog @@ -0,0 +1,30 @@ +Sun Jan 2 21:31:48 2000 Ben Pfaff + + * Makefile.am: (SUBDIRS) Only include gmp if libgmp not installed + on this system already. + +Sun May 31 00:55:51 1998 Ben Pfaff + + * Makefile.am: (SUBDIRS) Add gmp. + + * gmp/: New subdirectory, containing a subset of GNU libgmp2 just + big enough to support mpf_init_set_d(), mpf_get_str(), and + mpf_clear(). + +Fri Apr 24 12:52:07 1998 Ben Pfaff + + * Makefile.am: (SUBDIRS) Remove avllib. + + * avllib/: Removed. + +Wed Dec 24 22:36:50 1997 Ben Pfaff + + * Makefile.am: (SUBDIRS) Add dcdflib. + + * dcdflib: New subdirectory. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/lib/Makefile.am b/lib/Makefile.am new file mode 100644 index 00000000..99184378 --- /dev/null +++ b/lib/Makefile.am @@ -0,0 +1,6 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +SUBDIRS = julcal @GMP_SUBDIRS@ misc dcdflib +DIST_SUBDIRS = julcal gmp misc dcdflib + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/dcdflib/COPYING b/lib/dcdflib/COPYING new file mode 100644 index 00000000..173ab1a9 --- /dev/null +++ b/lib/dcdflib/COPYING @@ -0,0 +1,41 @@ +The following license applies *only* to the files cdflib.h, dcdflib.c, +and ipmpar.c. -blp + + LEGALITIES + +Code that appeared in an ACM publication is subject to their +algorithms policy: + + Submittal of an algorithm for publication in one of the ACM + Transactions implies that unrestricted use of the algorithm within a + computer is permissible. General permission to copy and distribute + the algorithm without fee is granted provided that the copies are not + made or distributed for direct commercial advantage. The ACM + copyright notice and the title of the publication and its date appear, + and notice is given that copying is by permission of the Association + for Computing Machinery. To copy otherwise, or to republish, requires + a fee and/or specific permission. + + Krogh, F. Algorithms Policy. ACM Tran. Math. Softw. 13(1987), + 183-186. + +We place the DCDFLIB code that we have written in the public domain. + + NO WARRANTY + + WE PROVIDE ABSOLUTELY NO WARRANTY OF ANY KIND EITHER EXPRESSED OR + IMPLIED, INCLUDING BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF + MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK + AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD + THIS PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY + SERVICING, REPAIR OR CORRECTION. + + IN NO EVENT SHALL THE UNIVERSITY OF TEXAS OR ANY OF ITS COMPONENT + INSTITUTIONS INCLUDING M. D. ANDERSON HOSPITAL BE LIABLE TO YOU FOR + DAMAGES, INCLUDING ANY LOST PROFITS, LOST MONIES, OR OTHER SPECIAL, + INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR + INABILITY TO USE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA OR + ITS ANALYSIS BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY THIRD + PARTIES) THE PROGRAM. + + (Above NO WARRANTY modified from the GNU NO WARRANTY statement.) diff --git a/lib/dcdflib/ChangeLog b/lib/dcdflib/ChangeLog new file mode 100644 index 00000000..6cef35fc --- /dev/null +++ b/lib/dcdflib/ChangeLog @@ -0,0 +1,32 @@ +Sun Aug 9 11:16:26 1998 Ben Pfaff + + * dcdflib.COPYING: Renamed COPYING. + +Sun Jul 5 00:14:51 1998 Ben Pfaff + + * cdflib.h: Move E0000, E0001 prototypes into dcdflib.c. + +Thu May 7 22:56:48 1998 Ben Pfaff + + * dcdflib.c: (E0000) Explicitly constant string to char * in call + to ftnstop() in order to alleviate warning from gcc. + +Sat Jan 3 17:08:58 1998 Ben Pfaff + + * README: New file. + +Wed Dec 24 22:37:21 1997 Ben Pfaff + + * Makefile.am: New file. + + * cdflib.h: New file from dcdflib.c-1.1. + + * dcdflib.COPYING: New file extracted from dcdflib.c-1.1 README. + + * dcdflib.c: New file from dcdflib.c-1.1. Minor changes + (parenthesization) to placate gcc warnings. + + * ipmpar.c: New file from dcdflib.c-1.1. Largely rewritten for + autoconf. + + diff --git a/lib/dcdflib/Makefile.am b/lib/dcdflib/Makefile.am new file mode 100644 index 00000000..e2ee995c --- /dev/null +++ b/lib/dcdflib/Makefile.am @@ -0,0 +1,13 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +noinst_LIBRARIES = libdcdflib.a + +INCLUDES = -I$(srcdir) -I$(top_srcdir)/src -I$(top_srcdir) \ +-I$(top_srcdir)/intl + +libdcdflib_a_SOURCES = dcdflib.c ipmpar.c +noinst_HEADERS = cdflib.h + +MAINTAINERCLEANFILES = Makefile.in + +EXTRA_DIST = COPYING diff --git a/lib/dcdflib/README b/lib/dcdflib/README new file mode 100644 index 00000000..cfafc4d4 --- /dev/null +++ b/lib/dcdflib/README @@ -0,0 +1,5 @@ +Please note that dcdflib is not part of PSPP. Instead, it is a +separate library that is included in the PSPP distribution for +convenience in compiling. + + -blp diff --git a/lib/dcdflib/cdflib.h b/lib/dcdflib/cdflib.h new file mode 100644 index 00000000..5f1ce3c2 --- /dev/null +++ b/lib/dcdflib/cdflib.h @@ -0,0 +1,80 @@ +double algdiv(double*,double*); +double alngam(double*); +double alnrel(double*); +double apser(double*,double*,double*,double*); +double basym(double*,double*,double*,double*); +double bcorr(double*,double*); +double betaln(double*,double*); +double bfrac(double*,double*,double*,double*,double*,double*); +void bgrat(double*,double*,double*,double*,double*,double*,int*i); +double bpser(double*,double*,double*,double*); +void bratio(double*,double*,double*,double*,double*,double*,int*); +double brcmp1(int*,double*,double*,double*,double*); +double brcomp(double*,double*,double*,double*); +double bup(double*,double*,double*,double*,int*,double*); +void cdfbet(int*,double*,double*,double*,double*,double*,double*, + int*,double*); +void cdfbin(int*,double*,double*,double*,double*,double*,double*, + int*,double*); +void cdfchi(int*,double*,double*,double*,double*,int*,double*); +void cdfchn(int*,double*,double*,double*,double*,double*,int*,double*); +void cdff(int*,double*,double*,double*,double*,double*,int*,double*); +void cdffnc(int*,double*,double*,double*,double*,double*,double*, + int*s,double*); +void cdfgam(int*,double*,double*,double*,double*,double*,int*,double*); +void cdfnbn(int*,double*,double*,double*,double*,double*,double*, + int*,double*); +void cdfnor(int*,double*,double*,double*,double*,double*,int*,double*); +void cdfpoi(int*,double*,double*,double*,double*,int*,double*); +void cdft(int*,double*,double*,double*,double*,int*,double*); +void cdftnc(int*,double*,double*,double*,double*,double*,int*,double*); +void cumbet(double*,double*,double*,double*,double*,double*); +void cumbin(double*,double*,double*,double*,double*,double*); +void cumchi(double*,double*,double*,double*); +void cumchn(double*,double*,double*,double*,double*); +void cumf(double*,double*,double*,double*,double*); +void cumfnc(double*,double*,double*,double*,double*,double*); +void cumgam(double*,double*,double*,double*); +void cumnbn(double*,double*,double*,double*,double*,double*); +void cumnor(double*,double*,double*); +void cumpoi(double*,double*,double*,double*); +void cumt(double*,double*,double*,double*); +void cumtnc(double*,double*,double*,double*,double*); +double devlpl(double [],int*,double*); +double dinvnr(double *p,double *q); +void dinvr(int*,double*,double*,unsigned long*,unsigned long*); +void dstinv(double*,double*,double*,double*,double*,double*, + double*); +double dt1(double*,double*,double*); +void dzror(int*,double*,double*,double*,double *, + unsigned long*,unsigned long*); +void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl); +double erf1(double*); +double erfc1(int*,double*); +double esum(int*,double*); +double exparg(int*); +double fpser(double*,double*,double*,double*); +double gam1(double*); +void gaminv(double*,double*,double*,double*,double*,int*); +double gamln(double*); +double gamln1(double*); +double Xgamm(double*); +void grat1(double*,double*,double*,double*,double*,double*); +void gratio(double*,double*,double*,double*,int*); +double gsumln(double*,double*); +double psi(double*); +double rcomp(double*,double*); +double rexp(double*); +double rlog(double*); +double rlog1(double*); +double spmpar(int*); +double stvaln(double*); +double fifdint(double); +double fifdmax1(double,double); +double fifdmin1(double,double); +double fifdsign(double,double); +long fifidint(double); +long fifmod(long,long); +void ftnstop(char*); +extern int ipmpar(int*); + diff --git a/lib/dcdflib/dcdflib.c b/lib/dcdflib/dcdflib.c new file mode 100644 index 00000000..91f606bc --- /dev/null +++ b/lib/dcdflib/dcdflib.c @@ -0,0 +1,9093 @@ +#include +#include +#include +#include "cdflib.h" + +static void E0000(int,int*,double*,double*,unsigned long*, + unsigned long*,double*,double*,double*, + double*,double*,double*,double*); +static void E0001(int,int*,double*,double*,double*,double*, + unsigned long*,unsigned long*,double*,double*, + double*,double*); + +/* + * A comment about ints and longs - whether ints or longs are used should + * make no difference, but where double r-values are assigned to ints the + * r-value is cast converted to a long, which is then assigned to the int + * to be compatible with the operation of fifidint. + */ +/* +----------------------------------------------------------------------- + + COMPUTATION OF LN(GAMMA(B)/GAMMA(A+B)) WHEN B .GE. 8 + + -------- + + IN THIS ALGORITHM, DEL(X) IS THE FUNCTION DEFINED BY + LN(GAMMA(X)) = (X - 0.5)*LN(X) - X + 0.5*LN(2*PI) + DEL(X). + +----------------------------------------------------------------------- +*/ +double algdiv(double *a,double *b) +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double algdiv,c,d,h,s11,s3,s5,s7,s9,t,u,v,w,x,x2,T1; +/* + .. + .. Executable Statements .. +*/ + if(*a <= *b) goto S10; + h = *b/ *a; + c = 1.0e0/(1.0e0+h); + x = h/(1.0e0+h); + d = *a+(*b-0.5e0); + goto S20; +S10: + h = *a/ *b; + c = h/(1.0e0+h); + x = 1.0e0/(1.0e0+h); + d = *b+(*a-0.5e0); +S20: +/* + SET SN = (1 - X**N)/(1 - X) +*/ + x2 = x*x; + s3 = 1.0e0+(x+x2); + s5 = 1.0e0+(x+x2*s3); + s7 = 1.0e0+(x+x2*s5); + s9 = 1.0e0+(x+x2*s7); + s11 = 1.0e0+(x+x2*s9); +/* + SET W = DEL(B) - DEL(A + B) +*/ + t = pow(1.0e0/ *b,2.0); + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; + w *= (c/ *b); +/* + COMBINE THE RESULTS +*/ + T1 = *a/ *b; + u = d*alnrel(&T1); + v = *a*(log(*b)-1.0e0); + if(u <= v) goto S30; + algdiv = w-v-u; + return algdiv; +S30: + algdiv = w-u-v; + return algdiv; +} +double alngam(double *x) +/* +********************************************************************** + + double alngam(double *x) + double precision LN of the GAMma function + + + Function + + + Returns the natural logarithm of GAMMA(X). + + + Arguments + + + X --> value at which scaled log gamma is to be returned + X is DOUBLE PRECISION + + + Method + + + If X .le. 6.0, then use recursion to get X below 3 + then apply rational approximation number 5236 of + Hart et al, Computer Approximations, John Wiley and + Sons, NY, 1968. + + If X .gt. 6.0, then use recursion to get X to at least 12 and + then use formula 5423 of the same source. + +********************************************************************** +*/ +{ +#define hln2pi 0.91893853320467274178e0 +static double coef[5] = { + 0.83333333333333023564e-1,-0.27777777768818808e-2,0.79365006754279e-3, + -0.594997310889e-3,0.8065880899e-3 +}; +static double scoefd[4] = { + 0.62003838007126989331e2,0.9822521104713994894e1,-0.8906016659497461257e1, + 0.1000000000000000000e1 +}; +static double scoefn[9] = { + 0.62003838007127258804e2,0.36036772530024836321e2,0.20782472531792126786e2, + 0.6338067999387272343e1,0.215994312846059073e1,0.3980671310203570498e0, + 0.1093115956710439502e0,0.92381945590275995e-2,0.29737866448101651e-2 +}; +static int K1 = 9; +static int K3 = 4; +static int K5 = 5; +static double alngam,offset,prod,xx; +static int i,n; +static double T2,T4,T6; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 6.0e0)) goto S70; + prod = 1.0e0; + xx = *x; + if(!(*x > 3.0e0)) goto S30; +S10: + if(!(xx > 3.0e0)) goto S20; + xx -= 1.0e0; + prod *= xx; + goto S10; +S30: +S20: + if(!(*x < 2.0e0)) goto S60; +S40: + if(!(xx < 2.0e0)) goto S50; + prod /= xx; + xx += 1.0e0; + goto S40; +S60: +S50: + T2 = xx-2.0e0; + T4 = xx-2.0e0; + alngam = devlpl(scoefn,&K1,&T2)/devlpl(scoefd,&K3,&T4); +/* + COMPUTE RATIONAL APPROXIMATION TO GAMMA(X) +*/ + alngam *= prod; + alngam = log(alngam); + goto S110; +S70: + offset = hln2pi; +/* + IF NECESSARY MAKE X AT LEAST 12 AND CARRY CORRECTION IN OFFSET +*/ + n = fifidint(12.0e0-*x); + if(!(n > 0)) goto S90; + prod = 1.0e0; + for(i=1; i<=n; i++) prod *= (*x+(double)(i-1)); + offset -= log(prod); + xx = *x+(double)n; + goto S100; +S90: + xx = *x; +S100: +/* + COMPUTE POWER SERIES +*/ + T6 = 1.0e0/pow(xx,2.0); + alngam = devlpl(coef,&K5,&T6)/xx; + alngam += (offset+(xx-0.5e0)*log(xx)-xx); +S110: + return alngam; +#undef hln2pi +} +double alnrel(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION LN(1 + A) +----------------------------------------------------------------------- +*/ +{ +static double p1 = -.129418923021993e+01; +static double p2 = .405303492862024e+00; +static double p3 = -.178874546012214e-01; +static double q1 = -.162752256355323e+01; +static double q2 = .747811014037616e+00; +static double q3 = -.845104217945565e-01; +static double alnrel,t,t2,w,x; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*a) > 0.375e0) goto S10; + t = *a/(*a+2.0e0); + t2 = t*t; + w = (((p3*t2+p2)*t2+p1)*t2+1.0e0)/(((q3*t2+q2)*t2+q1)*t2+1.0e0); + alnrel = 2.0e0*t*w; + return alnrel; +S10: + x = 1.e0+*a; + alnrel = log(x); + return alnrel; +} +double apser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + APSER YIELDS THE INCOMPLETE BETA RATIO I(SUB(1-X))(B,A) FOR + A .LE. MIN(EPS,EPS*B), B*X .LE. 1, AND X .LE. 0.5. USED WHEN + A IS VERY SMALL. USE ONLY IF ABOVE INEQUALITIES ARE SATISFIED. +----------------------------------------------------------------------- +*/ +{ +static double g = .577215664901533e0; +static double apser,aj,bx,c,j,s,t,tol; +/* + .. + .. Executable Statements .. +*/ + bx = *b**x; + t = *x-bx; + if(*b**eps > 2.e-2) goto S10; + c = log(*x)+psi(b)+g+t; + goto S20; +S10: + c = log(bx)+g+t; +S20: + tol = 5.0e0**eps*fabs(c); + j = 1.0e0; + s = 0.0e0; +S30: + j += 1.0e0; + t *= (*x-bx/j); + aj = t/j; + s += aj; + if(fabs(aj) > tol) goto S30; + apser = -(*a*(c+s)); + return apser; +} +double basym(double *a,double *b,double *lambda,double *eps) +/* +----------------------------------------------------------------------- + ASYMPTOTIC EXPANSION FOR IX(A,B) FOR LARGE A AND B. + LAMBDA = (A + B)*Y - B AND EPS IS THE TOLERANCE USED. + IT IS ASSUMED THAT LAMBDA IS NONNEGATIVE AND THAT + A AND B ARE GREATER THAN OR EQUAL TO 15. +----------------------------------------------------------------------- +*/ +{ +static double e0 = 1.12837916709551e0; +static double e1 = .353553390593274e0; +static int num = 20; +/* +------------------------ + ****** NUM IS THE MAXIMUM VALUE THAT N CAN TAKE IN THE DO LOOP + ENDING AT STATEMENT 50. IT IS REQUIRED THAT NUM BE EVEN. + THE ARRAYS A0, B0, C, D HAVE DIMENSION NUM + 1. +------------------------ + E0 = 2/SQRT(PI) + E1 = 2**(-3/2) +------------------------ +*/ +static int K3 = 1; +static double basym,bsum,dsum,f,h,h2,hn,j0,j1,r,r0,r1,s,sum,t,t0,t1,u,w,w0,z,z0, + z2,zn,znm1; +static int i,im1,imj,j,m,mm1,mmj,n,np1; +static double a0[21],b0[21],c[21],d[21],T1,T2; +/* + .. + .. Executable Statements .. +*/ + basym = 0.0e0; + if(*a >= *b) goto S10; + h = *a/ *b; + r0 = 1.0e0/(1.0e0+h); + r1 = (*b-*a)/ *b; + w0 = 1.0e0/sqrt(*a*(1.0e0+h)); + goto S20; +S10: + h = *b/ *a; + r0 = 1.0e0/(1.0e0+h); + r1 = (*b-*a)/ *a; + w0 = 1.0e0/sqrt(*b*(1.0e0+h)); +S20: + T1 = -(*lambda/ *a); + T2 = *lambda/ *b; + f = *a*rlog1(&T1)+*b*rlog1(&T2); + t = exp(-f); + if(t == 0.0e0) return basym; + z0 = sqrt(f); + z = 0.5e0*(z0/e1); + z2 = f+f; + a0[0] = 2.0e0/3.0e0*r1; + c[0] = -(0.5e0*a0[0]); + d[0] = -c[0]; + j0 = 0.5e0/e0*erfc1(&K3,&z0); + j1 = e1; + sum = j0+d[0]*w0*j1; + s = 1.0e0; + h2 = h*h; + hn = 1.0e0; + w = w0; + znm1 = z; + zn = z2; + for(n=2; n<=num; n+=2) { + hn = h2*hn; + a0[n-1] = 2.0e0*r0*(1.0e0+h*hn)/((double)n+2.0e0); + np1 = n+1; + s += hn; + a0[np1-1] = 2.0e0*r1*s/((double)n+3.0e0); + for(i=n; i<=np1; i++) { + r = -(0.5e0*((double)i+1.0e0)); + b0[0] = r*a0[0]; + for(m=2; m<=i; m++) { + bsum = 0.0e0; + mm1 = m-1; + for(j=1; j<=mm1; j++) { + mmj = m-j; + bsum += (((double)j*r-(double)mmj)*a0[j-1]*b0[mmj-1]); + } + b0[m-1] = r*a0[m-1]+bsum/(double)m; + } + c[i-1] = b0[i-1]/((double)i+1.0e0); + dsum = 0.0e0; + im1 = i-1; + for(j=1; j<=im1; j++) { + imj = i-j; + dsum += (d[imj-1]*c[j-1]); + } + d[i-1] = -(dsum+c[i-1]); + } + j0 = e1*znm1+((double)n-1.0e0)*j0; + j1 = e1*zn+(double)n*j1; + znm1 = z2*znm1; + zn = z2*zn; + w = w0*w; + t0 = d[n-1]*w*j0; + w = w0*w; + t1 = d[np1-1]*w*j1; + sum += (t0+t1); + if(fabs(t0)+fabs(t1) <= *eps*sum) goto S80; + } +S80: + u = exp(-bcorr(a,b)); + basym = e0*t*u*sum; + return basym; +} +double bcorr(double *a0,double *b0) +/* +----------------------------------------------------------------------- + + EVALUATION OF DEL(A0) + DEL(B0) - DEL(A0 + B0) WHERE + LN(GAMMA(A)) = (A - 0.5)*LN(A) - A + 0.5*LN(2*PI) + DEL(A). + IT IS ASSUMED THAT A0 .GE. 8 AND B0 .GE. 8. + +----------------------------------------------------------------------- +*/ +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double bcorr,a,b,c,h,s11,s3,s5,s7,s9,t,w,x,x2; +/* + .. + .. Executable Statements .. +*/ + a = fifdmin1(*a0,*b0); + b = fifdmax1(*a0,*b0); + h = a/b; + c = h/(1.0e0+h); + x = 1.0e0/(1.0e0+h); + x2 = x*x; +/* + SET SN = (1 - X**N)/(1 - X) +*/ + s3 = 1.0e0+(x+x2); + s5 = 1.0e0+(x+x2*s3); + s7 = 1.0e0+(x+x2*s5); + s9 = 1.0e0+(x+x2*s7); + s11 = 1.0e0+(x+x2*s9); +/* + SET W = DEL(B) - DEL(A + B) +*/ + t = pow(1.0e0/b,2.0); + w = ((((c5*s11*t+c4*s9)*t+c3*s7)*t+c2*s5)*t+c1*s3)*t+c0; + w *= (c/b); +/* + COMPUTE DEL(A) + W +*/ + t = pow(1.0e0/a,2.0); + bcorr = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/a+w; + return bcorr; +} +double betaln(double *a0,double *b0) +/* +----------------------------------------------------------------------- + EVALUATION OF THE LOGARITHM OF THE BETA FUNCTION +----------------------------------------------------------------------- + E = 0.5*LN(2*PI) +-------------------------- +*/ +{ +static double e = .918938533204673e0; +static double betaln,a,b,c,h,u,v,w,z; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + a = fifdmin1(*a0,*b0); + b = fifdmax1(*a0,*b0); + if(a >= 8.0e0) goto S100; + if(a >= 1.0e0) goto S20; +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .LT. 1 +----------------------------------------------------------------------- +*/ + if(b >= 8.0e0) goto S10; + T1 = a+b; + betaln = gamln(&a)+(gamln(&b)-gamln(&T1)); + return betaln; +S10: + betaln = gamln(&a)+algdiv(&a,&b); + return betaln; +S20: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN 1 .LE. A .LT. 8 +----------------------------------------------------------------------- +*/ + if(a > 2.0e0) goto S40; + if(b > 2.0e0) goto S30; + betaln = gamln(&a)+gamln(&b)-gsumln(&a,&b); + return betaln; +S30: + w = 0.0e0; + if(b < 8.0e0) goto S60; + betaln = gamln(&a)+algdiv(&a,&b); + return betaln; +S40: +/* + REDUCTION OF A WHEN B .LE. 1000 +*/ + if(b > 1000.0e0) goto S80; + n = (long)(a - 1.0e0); + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + h = a/b; + w *= (h/(1.0e0+h)); + } + w = log(w); + if(b < 8.0e0) goto S60; + betaln = w+gamln(&a)+algdiv(&a,&b); + return betaln; +S60: +/* + REDUCTION OF B WHEN B .LT. 8 +*/ + n = (long)(b - 1.0e0); + z = 1.0e0; + for(i=1; i<=n; i++) { + b -= 1.0e0; + z *= (b/(a+b)); + } + betaln = w+log(z)+(gamln(&a)+(gamln(&b)-gsumln(&a,&b))); + return betaln; +S80: +/* + REDUCTION OF A WHEN B .GT. 1000 +*/ + n = (long)(a - 1.0e0); + w = 1.0e0; + for(i=1; i<=n; i++) { + a -= 1.0e0; + w *= (a/(1.0e0+a/b)); + } + betaln = log(w)-(double)n*log(b)+(gamln(&a)+algdiv(&a,&b)); + return betaln; +S100: +/* +----------------------------------------------------------------------- + PROCEDURE WHEN A .GE. 8 +----------------------------------------------------------------------- +*/ + w = bcorr(&a,&b); + h = a/b; + c = h/(1.0e0+h); + u = -((a-0.5e0)*log(c)); + v = b*alnrel(&h); + if(u <= v) goto S110; + betaln = -(0.5e0*log(b))+e+w-v-u; + return betaln; +S110: + betaln = -(0.5e0*log(b))+e+w-u-v; + return betaln; +} +double bfrac(double *a,double *b,double *x,double *y,double *lambda, + double *eps) +/* +----------------------------------------------------------------------- + CONTINUED FRACTION EXPANSION FOR IX(A,B) WHEN A,B .GT. 1. + IT IS ASSUMED THAT LAMBDA = (A + B)*Y - B. +----------------------------------------------------------------------- +*/ +{ +static double bfrac,alpha,an,anp1,beta,bn,bnp1,c,c0,c1,e,n,p,r,r0,s,t,w,yp1; +/* + .. + .. Executable Statements .. +*/ + bfrac = brcomp(a,b,x,y); + if(bfrac == 0.0e0) return bfrac; + c = 1.0e0+*lambda; + c0 = *b/ *a; + c1 = 1.0e0+1.0e0/ *a; + yp1 = *y+1.0e0; + n = 0.0e0; + p = 1.0e0; + s = *a+1.0e0; + an = 0.0e0; + bn = anp1 = 1.0e0; + bnp1 = c/c1; + r = c1/c; +S10: +/* + CONTINUED FRACTION CALCULATION +*/ + n += 1.0e0; + t = n/ *a; + w = n*(*b-n)**x; + e = *a/s; + alpha = p*(p+c0)*e*e*(w**x); + e = (1.0e0+t)/(c1+t+t); + beta = n+w/s+e*(c+n*yp1); + p = 1.0e0+t; + s += 2.0e0; +/* + UPDATE AN, BN, ANP1, AND BNP1 +*/ + t = alpha*an+beta*anp1; + an = anp1; + anp1 = t; + t = alpha*bn+beta*bnp1; + bn = bnp1; + bnp1 = t; + r0 = r; + r = anp1/bnp1; + if(fabs(r-r0) <= *eps*r) goto S20; +/* + RESCALE AN, BN, ANP1, AND BNP1 +*/ + an /= bnp1; + bn /= bnp1; + anp1 = r; + bnp1 = 1.0e0; + goto S10; +S20: +/* + TERMINATION +*/ + bfrac *= r; + return bfrac; +} +void bgrat(double *a,double *b,double *x,double *y,double *w, + double *eps,int *ierr) +/* +----------------------------------------------------------------------- + ASYMPTOTIC EXPANSION FOR IX(A,B) WHEN A IS LARGER THAN B. + THE RESULT OF THE EXPANSION IS ADDED TO W. IT IS ASSUMED + THAT A .GE. 15 AND B .LE. 1. EPS IS THE TOLERANCE USED. + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. +----------------------------------------------------------------------- +*/ +{ +static double bm1,bp2n,cn,coef,dj,j,l,lnx,n2,nu,p,q,r,s,sum,t,t2,u,v,z; +static int i,n,nm1; +static double c[30],d[30],T1; +/* + .. + .. Executable Statements .. +*/ + bm1 = *b-0.5e0-0.5e0; + nu = *a+0.5e0*bm1; + if(*y > 0.375e0) goto S10; + T1 = -*y; + lnx = alnrel(&T1); + goto S20; +S10: + lnx = log(*x); +S20: + z = -(nu*lnx); + if(*b*z == 0.0e0) goto S70; +/* + COMPUTATION OF THE EXPANSION + SET R = EXP(-Z)*Z**B/GAMMA(B) +*/ + r = *b*(1.0e0+gam1(b))*exp(*b*log(z)); + r *= (exp(*a*lnx)*exp(0.5e0*bm1*lnx)); + u = algdiv(b,a)+*b*log(nu); + u = r*exp(-u); + if(u == 0.0e0) goto S70; + grat1(b,&z,&r,&p,&q,eps); + v = 0.25e0*pow(1.0e0/nu,2.0); + t2 = 0.25e0*lnx*lnx; + l = *w/u; + j = q/r; + sum = j; + t = cn = 1.0e0; + n2 = 0.0e0; + for(n=1; n<=30; n++) { + bp2n = *b+n2; + j = (bp2n*(bp2n+1.0e0)*j+(z+bp2n+1.0e0)*t)*v; + n2 += 2.0e0; + t *= t2; + cn /= (n2*(n2+1.0e0)); + c[n-1] = cn; + s = 0.0e0; + if(n == 1) goto S40; + nm1 = n-1; + coef = *b-(double)n; + for(i=1; i<=nm1; i++) { + s += (coef*c[i-1]*d[n-i-1]); + coef += *b; + } +S40: + d[n-1] = bm1*cn+s/(double)n; + dj = d[n-1]*j; + sum += dj; + if(sum <= 0.0e0) goto S70; + if(fabs(dj) <= *eps*(sum+l)) goto S60; + } +S60: +/* + ADD THE RESULTS TO W +*/ + *ierr = 0; + *w += (u*sum); + return; +S70: +/* + THE EXPANSION CANNOT BE COMPUTED +*/ + *ierr = 1; + return; +} +double bpser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + POWER SERIES EXPANSION FOR EVALUATING IX(A,B) WHEN B .LE. 1 + OR B*X .LE. 0.7. EPS IS THE TOLERANCE USED. +----------------------------------------------------------------------- +*/ +{ +static double bpser,a0,apb,b0,c,n,sum,t,tol,u,w,z; +static int i,m; +/* + .. + .. Executable Statements .. +*/ + bpser = 0.0e0; + if(*x == 0.0e0) return bpser; +/* +----------------------------------------------------------------------- + COMPUTE THE FACTOR X**A/(A*BETA(A,B)) +----------------------------------------------------------------------- +*/ + a0 = fifdmin1(*a,*b); + if(a0 < 1.0e0) goto S10; + z = *a*log(*x)-betaln(a,b); + bpser = exp(z)/ *a; + goto S100; +S10: + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S90; + if(b0 > 1.0e0) goto S40; +/* + PROCEDURE FOR A0 .LT. 1 AND B0 .LE. 1 +*/ + bpser = pow(*x,*a); + if(bpser == 0.0e0) return bpser; + apb = *a+*b; + if(apb > 1.0e0) goto S20; + z = 1.0e0+gam1(&apb); + goto S30; +S20: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S30: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + bpser *= (c*(*b/apb)); + goto S100; +S40: +/* + PROCEDURE FOR A0 .LT. 1 AND 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + m = (long)(b0 - 1.0e0); + if(m < 1) goto S60; + c = 1.0e0; + for(i=1; i<=m; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S60: + z = *a*log(*x)-u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S70; + t = 1.0e0+gam1(&apb); + goto S80; +S70: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S80: + bpser = exp(z)*(a0/ *a)*(1.0e0+gam1(&b0))/t; + goto S100; +S90: +/* + PROCEDURE FOR A0 .LT. 1 AND B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + z = *a*log(*x)-u; + bpser = a0/ *a*exp(z); +S100: + if(bpser == 0.0e0 || *a <= 0.1e0**eps) return bpser; +/* +----------------------------------------------------------------------- + COMPUTE THE SERIES +----------------------------------------------------------------------- +*/ + sum = n = 0.0e0; + c = 1.0e0; + tol = *eps/ *a; +S110: + n += 1.0e0; + c *= ((0.5e0+(0.5e0-*b/n))**x); + w = c/(*a+n); + sum += w; + if(fabs(w) > tol) goto S110; + bpser *= (1.0e0+*a*sum); + return bpser; +} +void bratio(double *a,double *b,double *x,double *y,double *w, + double *w1,int *ierr) +/* +----------------------------------------------------------------------- + + EVALUATION OF THE INCOMPLETE BETA FUNCTION IX(A,B) + + -------------------- + + IT IS ASSUMED THAT A AND B ARE NONNEGATIVE, AND THAT X .LE. 1 + AND Y = 1 - X. BRATIO ASSIGNS W AND W1 THE VALUES + + W = IX(A,B) + W1 = 1 - IX(A,B) + + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. + IF NO INPUT ERRORS ARE DETECTED THEN IERR IS SET TO 0 AND + W AND W1 ARE COMPUTED. OTHERWISE, IF AN ERROR IS DETECTED, + THEN W AND W1 ARE ASSIGNED THE VALUE 0 AND IERR IS SET TO + ONE OF THE FOLLOWING VALUES ... + + IERR = 1 IF A OR B IS NEGATIVE + IERR = 2 IF A = B = 0 + IERR = 3 IF X .LT. 0 OR X .GT. 1 + IERR = 4 IF Y .LT. 0 OR Y .GT. 1 + IERR = 5 IF X + Y .NE. 1 + IERR = 6 IF X = A = 0 + IERR = 7 IF Y = B = 0 + +-------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WARFARE CENTER + DAHLGREN, VIRGINIA + REVISED ... NOV 1991 +----------------------------------------------------------------------- +*/ +{ +static int K1 = 1; +static double a0,b0,eps,lambda,t,x0,y0,z; +static int ierr1,ind,n; +static double T2,T3,T4,T5; +/* + .. + .. Executable Statements .. +*/ +/* + ****** EPS IS A MACHINE DEPENDENT CONSTANT. EPS IS THE SMALLEST + FLOATING POINT NUMBER FOR WHICH 1.0 + EPS .GT. 1.0 +*/ + eps = spmpar(&K1); + *w = *w1 = 0.0e0; + if(*a < 0.0e0 || *b < 0.0e0) goto S270; + if(*a == 0.0e0 && *b == 0.0e0) goto S280; + if(*x < 0.0e0 || *x > 1.0e0) goto S290; + if(*y < 0.0e0 || *y > 1.0e0) goto S300; + z = *x+*y-0.5e0-0.5e0; + if(fabs(z) > 3.0e0*eps) goto S310; + *ierr = 0; + if(*x == 0.0e0) goto S210; + if(*y == 0.0e0) goto S230; + if(*a == 0.0e0) goto S240; + if(*b == 0.0e0) goto S220; + eps = fifdmax1(eps,1.e-15); + if(fifdmax1(*a,*b) < 1.e-3*eps) goto S260; + ind = 0; + a0 = *a; + b0 = *b; + x0 = *x; + y0 = *y; + if(fifdmin1(a0,b0) > 1.0e0) goto S40; +/* + PROCEDURE FOR A0 .LE. 1 OR B0 .LE. 1 +*/ + if(*x <= 0.5e0) goto S10; + ind = 1; + a0 = *b; + b0 = *a; + x0 = *y; + y0 = *x; +S10: + if(b0 < fifdmin1(eps,eps*a0)) goto S90; + if(a0 < fifdmin1(eps,eps*b0) && b0*x0 <= 1.0e0) goto S100; + if(fifdmax1(a0,b0) > 1.0e0) goto S20; + if(a0 >= fifdmin1(0.2e0,b0)) goto S110; + if(pow(x0,a0) <= 0.9e0) goto S110; + if(x0 >= 0.3e0) goto S120; + n = 20; + goto S140; +S20: + if(b0 <= 1.0e0) goto S110; + if(x0 >= 0.3e0) goto S120; + if(x0 >= 0.1e0) goto S30; + if(pow(x0*b0,a0) <= 0.7e0) goto S110; +S30: + if(b0 > 15.0e0) goto S150; + n = 20; + goto S140; +S40: +/* + PROCEDURE FOR A0 .GT. 1 AND B0 .GT. 1 +*/ + if(*a > *b) goto S50; + lambda = *a-(*a+*b)**x; + goto S60; +S50: + lambda = (*a+*b)**y-*b; +S60: + if(lambda >= 0.0e0) goto S70; + ind = 1; + a0 = *b; + b0 = *a; + x0 = *y; + y0 = *x; + lambda = fabs(lambda); +S70: + if(b0 < 40.0e0 && b0*x0 <= 0.7e0) goto S110; + if(b0 < 40.0e0) goto S160; + if(a0 > b0) goto S80; + if(a0 <= 100.0e0) goto S130; + if(lambda > 0.03e0*a0) goto S130; + goto S200; +S80: + if(b0 <= 100.0e0) goto S130; + if(lambda > 0.03e0*b0) goto S130; + goto S200; +S90: +/* + EVALUATION OF THE APPROPRIATE ALGORITHM +*/ + *w = fpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S100: + *w1 = apser(&a0,&b0,&x0,&eps); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S110: + *w = bpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S120: + *w1 = bpser(&b0,&a0,&y0,&eps); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S130: + T2 = 15.0e0*eps; + *w = bfrac(&a0,&b0,&x0,&y0,&lambda,&T2); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S140: + *w1 = bup(&b0,&a0,&y0,&x0,&n,&eps); + b0 += (double)n; +S150: + T3 = 15.0e0*eps; + bgrat(&b0,&a0,&y0,&x0,w1,&T3,&ierr1); + *w = 0.5e0+(0.5e0-*w1); + goto S250; +S160: + n = (long)(b0); + b0 -= (double)n; + if(b0 != 0.0e0) goto S170; + n -= 1; + b0 = 1.0e0; +S170: + *w = bup(&b0,&a0,&y0,&x0,&n,&eps); + if(x0 > 0.7e0) goto S180; + *w += bpser(&a0,&b0,&x0,&eps); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S180: + if(a0 > 15.0e0) goto S190; + n = 20; + *w += bup(&a0,&b0,&x0,&y0,&n,&eps); + a0 += (double)n; +S190: + T4 = 15.0e0*eps; + bgrat(&a0,&b0,&x0,&y0,w,&T4,&ierr1); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S200: + T5 = 100.0e0*eps; + *w = basym(&a0,&b0,&lambda,&T5); + *w1 = 0.5e0+(0.5e0-*w); + goto S250; +S210: +/* + TERMINATION OF THE PROCEDURE +*/ + if(*a == 0.0e0) goto S320; +S220: + *w = 0.0e0; + *w1 = 1.0e0; + return; +S230: + if(*b == 0.0e0) goto S330; +S240: + *w = 1.0e0; + *w1 = 0.0e0; + return; +S250: + if(ind == 0) return; + t = *w; + *w = *w1; + *w1 = t; + return; +S260: +/* + PROCEDURE FOR A AND B .LT. 1.E-3*EPS +*/ + *w = *b/(*a+*b); + *w1 = *a/(*a+*b); + return; +S270: +/* + ERROR RETURN +*/ + *ierr = 1; + return; +S280: + *ierr = 2; + return; +S290: + *ierr = 3; + return; +S300: + *ierr = 4; + return; +S310: + *ierr = 5; + return; +S320: + *ierr = 6; + return; +S330: + *ierr = 7; + return; +} +double brcmp1(int *mu,double *a,double *b,double *x,double *y) +/* +----------------------------------------------------------------------- + EVALUATION OF EXP(MU) * (X**A*Y**B/BETA(A,B)) +----------------------------------------------------------------------- +*/ +{ +static double Const = .398942280401433e0; +static double brcmp1,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; +static int i,n; +/* +----------------- + CONST = 1/SQRT(2*PI) +----------------- +*/ +static double T1,T2,T3,T4; +/* + .. + .. Executable Statements .. +*/ + a0 = fifdmin1(*a,*b); + if(a0 >= 8.0e0) goto S130; + if(*x > 0.375e0) goto S10; + lnx = log(*x); + T1 = -*x; + lny = alnrel(&T1); + goto S30; +S10: + if(*y > 0.375e0) goto S20; + T2 = -*y; + lnx = alnrel(&T2); + lny = log(*y); + goto S30; +S20: + lnx = log(*x); + lny = log(*y); +S30: + z = *a*lnx+*b*lny; + if(a0 < 1.0e0) goto S40; + z -= betaln(a,b); + brcmp1 = esum(mu,&z); + return brcmp1; +S40: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .LT. 1 OR B .LT. 1 +----------------------------------------------------------------------- +*/ + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S120; + if(b0 > 1.0e0) goto S70; +/* + ALGORITHM FOR B0 .LE. 1 +*/ + brcmp1 = esum(mu,&z); + if(brcmp1 == 0.0e0) return brcmp1; + apb = *a+*b; + if(apb > 1.0e0) goto S50; + z = 1.0e0+gam1(&apb); + goto S60; +S50: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S60: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + brcmp1 = brcmp1*(a0*c)/(1.0e0+a0/b0); + return brcmp1; +S70: +/* + ALGORITHM FOR 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + n = (long)(b0 - 1.0e0); + if(n < 1) goto S90; + c = 1.0e0; + for(i=1; i<=n; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S90: + z -= u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S100; + t = 1.0e0+gam1(&apb); + goto S110; +S100: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S110: + brcmp1 = a0*esum(mu,&z)*(1.0e0+gam1(&b0))/t; + return brcmp1; +S120: +/* + ALGORITHM FOR B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + T3 = z-u; + brcmp1 = a0*esum(mu,&T3); + return brcmp1; +S130: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .GE. 8 AND B .GE. 8 +----------------------------------------------------------------------- +*/ + if(*a > *b) goto S140; + h = *a/ *b; + x0 = h/(1.0e0+h); + y0 = 1.0e0/(1.0e0+h); + lambda = *a-(*a+*b)**x; + goto S150; +S140: + h = *b/ *a; + x0 = 1.0e0/(1.0e0+h); + y0 = h/(1.0e0+h); + lambda = (*a+*b)**y-*b; +S150: + e = -(lambda/ *a); + if(fabs(e) > 0.6e0) goto S160; + u = rlog1(&e); + goto S170; +S160: + u = e-log(*x/x0); +S170: + e = lambda/ *b; + if(fabs(e) > 0.6e0) goto S180; + v = rlog1(&e); + goto S190; +S180: + v = e-log(*y/y0); +S190: + T4 = -(*a*u+*b*v); + z = esum(mu,&T4); + brcmp1 = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); + return brcmp1; +} +double brcomp(double *a,double *b,double *x,double *y) +/* +----------------------------------------------------------------------- + EVALUATION OF X**A*Y**B/BETA(A,B) +----------------------------------------------------------------------- +*/ +{ +static double Const = .398942280401433e0; +static double brcomp,a0,apb,b0,c,e,h,lambda,lnx,lny,t,u,v,x0,y0,z; +static int i,n; +/* +----------------- + CONST = 1/SQRT(2*PI) +----------------- +*/ +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + brcomp = 0.0e0; + if(*x == 0.0e0 || *y == 0.0e0) return brcomp; + a0 = fifdmin1(*a,*b); + if(a0 >= 8.0e0) goto S130; + if(*x > 0.375e0) goto S10; + lnx = log(*x); + T1 = -*x; + lny = alnrel(&T1); + goto S30; +S10: + if(*y > 0.375e0) goto S20; + T2 = -*y; + lnx = alnrel(&T2); + lny = log(*y); + goto S30; +S20: + lnx = log(*x); + lny = log(*y); +S30: + z = *a*lnx+*b*lny; + if(a0 < 1.0e0) goto S40; + z -= betaln(a,b); + brcomp = exp(z); + return brcomp; +S40: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .LT. 1 OR B .LT. 1 +----------------------------------------------------------------------- +*/ + b0 = fifdmax1(*a,*b); + if(b0 >= 8.0e0) goto S120; + if(b0 > 1.0e0) goto S70; +/* + ALGORITHM FOR B0 .LE. 1 +*/ + brcomp = exp(z); + if(brcomp == 0.0e0) return brcomp; + apb = *a+*b; + if(apb > 1.0e0) goto S50; + z = 1.0e0+gam1(&apb); + goto S60; +S50: + u = *a+*b-1.e0; + z = (1.0e0+gam1(&u))/apb; +S60: + c = (1.0e0+gam1(a))*(1.0e0+gam1(b))/z; + brcomp = brcomp*(a0*c)/(1.0e0+a0/b0); + return brcomp; +S70: +/* + ALGORITHM FOR 1 .LT. B0 .LT. 8 +*/ + u = gamln1(&a0); + n = (long)(b0 - 1.0e0); + if(n < 1) goto S90; + c = 1.0e0; + for(i=1; i<=n; i++) { + b0 -= 1.0e0; + c *= (b0/(a0+b0)); + } + u = log(c)+u; +S90: + z -= u; + b0 -= 1.0e0; + apb = a0+b0; + if(apb > 1.0e0) goto S100; + t = 1.0e0+gam1(&apb); + goto S110; +S100: + u = a0+b0-1.e0; + t = (1.0e0+gam1(&u))/apb; +S110: + brcomp = a0*exp(z)*(1.0e0+gam1(&b0))/t; + return brcomp; +S120: +/* + ALGORITHM FOR B0 .GE. 8 +*/ + u = gamln1(&a0)+algdiv(&a0,&b0); + brcomp = a0*exp(z-u); + return brcomp; +S130: +/* +----------------------------------------------------------------------- + PROCEDURE FOR A .GE. 8 AND B .GE. 8 +----------------------------------------------------------------------- +*/ + if(*a > *b) goto S140; + h = *a/ *b; + x0 = h/(1.0e0+h); + y0 = 1.0e0/(1.0e0+h); + lambda = *a-(*a+*b)**x; + goto S150; +S140: + h = *b/ *a; + x0 = 1.0e0/(1.0e0+h); + y0 = h/(1.0e0+h); + lambda = (*a+*b)**y-*b; +S150: + e = -(lambda/ *a); + if(fabs(e) > 0.6e0) goto S160; + u = rlog1(&e); + goto S170; +S160: + u = e-log(*x/x0); +S170: + e = lambda/ *b; + if(fabs(e) > 0.6e0) goto S180; + v = rlog1(&e); + goto S190; +S180: + v = e-log(*y/y0); +S190: + z = exp(-(*a*u+*b*v)); + brcomp = Const*sqrt(*b*x0)*z*exp(-bcorr(a,b)); + return brcomp; +} +double bup(double *a,double *b,double *x,double *y,int *n,double *eps) +/* +----------------------------------------------------------------------- + EVALUATION OF IX(A,B) - IX(A+N,B) WHERE N IS A POSITIVE INTEGER. + EPS IS THE TOLERANCE USED. +----------------------------------------------------------------------- +*/ +{ +static int K1 = 1; +static int K2 = 0; +static double bup,ap1,apb,d,l,r,t,w; +static int i,k,kp1,mu,nm1; +/* + .. + .. Executable Statements .. +*/ +/* + OBTAIN THE SCALING FACTOR EXP(-MU) AND + EXP(MU)*(X**A*Y**B/BETA(A,B))/A +*/ + apb = *a+*b; + ap1 = *a+1.0e0; + mu = 0; + d = 1.0e0; + if(*n == 1 || *a < 1.0e0) goto S10; + if(apb < 1.1e0*ap1) goto S10; + mu = (long)(fabs(exparg(&K1))); + k = (long)(exparg(&K2)); + if(k < mu) mu = k; + t = mu; + d = exp(-t); +S10: + bup = brcmp1(&mu,a,b,x,y)/ *a; + if(*n == 1 || bup == 0.0e0) return bup; + nm1 = *n-1; + w = d; +/* + LET K BE THE INDEX OF THE MAXIMUM TERM +*/ + k = 0; + if(*b <= 1.0e0) goto S50; + if(*y > 1.e-4) goto S20; + k = nm1; + goto S30; +S20: + r = (*b-1.0e0)**x/ *y-*a; + if(r < 1.0e0) goto S50; + t = nm1; + k = (long)(t); + if(r < t) k = (long)(r); +S30: +/* + ADD THE INCREASING TERMS OF THE SERIES +*/ + for(i=1; i<=k; i++) { + l = i-1; + d = (apb+l)/(ap1+l)**x*d; + w += d; + } + if(k == nm1) goto S70; +S50: +/* + ADD THE REMAINING TERMS OF THE SERIES +*/ + kp1 = k+1; + for(i=kp1; i<=nm1; i++) { + l = i-1; + d = (apb+l)/(ap1+l)**x*d; + w += d; + if(d <= *eps*w) goto S70; + } +S70: +/* + TERMINATE THE PROCEDURE +*/ + bup *= w; + return bup; +} +void cdfbet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) +/********************************************************************** + + void cdfbet(int *which,double *p,double *q,double *x,double *y, + double *a,double *b,int *status,double *bound) + + Cumulative Distribution Function + BETa Distribution + + + Function + + + Calculates any one parameter of the beta distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,Y,A and B + iwhich = 2 : Calculate X and Y from P,Q,A and B + iwhich = 3 : Calculate A from P,Q,X,Y and B + iwhich = 4 : Calculate B from P,Q,X,Y and A + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of beta density. + Input range: [0,1]. + Search range: [0,1] + + Y <--> 1-X. + Input range: [0,1]. + Search range: [0,1] + X + Y = 1.0. + + A <--> The first parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-100,1D100] + + B <--> The second parameter of the beta density. + Input range: (0, +infinity). + Search range: [1D-100,1D100] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if X + Y .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + code associated with the following reference. + + DiDinato, A. R. and Morris, A. H. Algorithm 708: Significant + Digit Computation of the Incomplete Beta Function Ratios. ACM + Trans. Math. Softw. 18 (1993), 360-373. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + The beta density is proportional to + t^(A-1) * (1-t)^(B-1) + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define inf 1.0e100 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K3 = 1.0e0; +static double K8 = 0.5e0; +static double K9 = 5.0e0; +static double fx,xhi,xlo,cum,ccum,xy,pq; +static unsigned long qhi,qleft,qporq; +static double T4,T5,T6,T7,T10,T11,T12,T13,T14,T15; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q < 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S150; +/* + X +*/ + if(!(*x < 0.0e0 || *x > 1.0e0)) goto S140; + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + goto S130; +S120: + *bound = 1.0e0; +S130: + *status = -4; + return; +S150: +S140: + if(*which == 2) goto S190; +/* + Y +*/ + if(!(*y < 0.0e0 || *y > 1.0e0)) goto S180; + if(!(*y < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = -5; + return; +S190: +S180: + if(*which == 3) goto S210; +/* + A +*/ + if(!(*a <= 0.0e0)) goto S200; + *bound = 0.0e0; + *status = -6; + return; +S210: +S200: + if(*which == 4) goto S230; +/* + B +*/ + if(!(*b <= 0.0e0)) goto S220; + *bound = 0.0e0; + *status = -7; + return; +S230: +S220: + if(*which == 1) goto S270; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; + if(!(pq < 0.0e0)) goto S240; + *bound = 0.0e0; + goto S250; +S240: + *bound = 1.0e0; +S250: + *status = 3; + return; +S270: +S260: + if(*which == 2) goto S310; +/* + X + Y +*/ + xy = *x+*y; + if(!(fabs(xy-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; + if(!(xy < 0.0e0)) goto S280; + *bound = 0.0e0; + goto S290; +S280: + *bound = 1.0e0; +S290: + *status = 4; + return; +S310: +S300: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + cumbet(x,y,a,b,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating X and Y +*/ + T4 = atol; + T5 = tol; + dstzr(&K2,&K3,&T4,&T5); + if(!qporq) goto S340; + *status = 0; + dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); + *y = one-*x; +S320: + if(!(*status == 1)) goto S330; + cumbet(x,y,a,b,&cum,&ccum); + fx = cum-*p; + dzror(status,x,&fx,&xlo,&xhi,&qleft,&qhi); + *y = one-*x; + goto S320; +S330: + goto S370; +S340: + *status = 0; + dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); + *x = one-*y; +S350: + if(!(*status == 1)) goto S360; + cumbet(x,y,a,b,&cum,&ccum); + fx = ccum-*q; + dzror(status,y,&fx,&xlo,&xhi,&qleft,&qhi); + *x = one-*y; + goto S350; +S370: +S360: + if(!(*status == -1)) goto S400; + if(!qleft) goto S380; + *status = 1; + *bound = 0.0e0; + goto S390; +S380: + *status = 2; + *bound = 1.0e0; +S400: +S390: + ; + } + else if(3 == *which) { +/* + Computing A +*/ + *a = 5.0e0; + T6 = zero; + T7 = inf; + T10 = atol; + T11 = tol; + dstinv(&T6,&T7,&K8,&K8,&K9,&T10,&T11); + *status = 0; + dinvr(status,a,&fx,&qleft,&qhi); +S410: + if(!(*status == 1)) goto S440; + cumbet(x,y,a,b,&cum,&ccum); + if(!qporq) goto S420; + fx = cum-*p; + goto S430; +S420: + fx = ccum-*q; +S430: + dinvr(status,a,&fx,&qleft,&qhi); + goto S410; +S440: + if(!(*status == -1)) goto S470; + if(!qleft) goto S450; + *status = 1; + *bound = zero; + goto S460; +S450: + *status = 2; + *bound = inf; +S470: +S460: + ; + } + else if(4 == *which) { +/* + Computing B +*/ + *b = 5.0e0; + T12 = zero; + T13 = inf; + T14 = atol; + T15 = tol; + dstinv(&T12,&T13,&K8,&K8,&K9,&T14,&T15); + *status = 0; + dinvr(status,b,&fx,&qleft,&qhi); +S480: + if(!(*status == 1)) goto S510; + cumbet(x,y,a,b,&cum,&ccum); + if(!qporq) goto S490; + fx = cum-*p; + goto S500; +S490: + fx = ccum-*q; +S500: + dinvr(status,b,&fx,&qleft,&qhi); + goto S480; +S510: + if(!(*status == -1)) goto S540; + if(!qleft) goto S520; + *status = 1; + *bound = zero; + goto S530; +S520: + *status = 2; + *bound = inf; +S530: + ; + } +S540: + return; +#undef tol +#undef atol +#undef zero +#undef inf +#undef one +} +void cdfbin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) +/********************************************************************** + + void cdfbin(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + BINomial distribution + + + Function + + + Calculates any one parameter of the binomial + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the binomial distribution. + (Probablility of S or fewer successes in XN trials each + with probability of success PR.) + Input range: [0,1]. + + Q <--> 1-P. + Input range: [0, 1]. + P + Q = 1.0. + + S <--> The number of successes observed. + Input range: [0, XN] + Search range: [0, XN] + + XN <--> The number of binomial trials. + Input range: (0, +infinity). + Search range: [1E-100, 1E100] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1] + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.24 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the binomial + distribution to the cumulative incomplete beta distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + +**********************************************************************/ +{ +#define atol 1.0e-50 +#define tol 1.0e-8 +#define zero 1.0e-100 +#define inf 1.0e100 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double K11 = 1.0e0; +static double fx,xhi,xlo,cum,ccum,pq,prompr; +static unsigned long qhi,qleft,qporq; +static double T5,T6,T7,T8,T9,T10,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 && *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q < 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q < 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 3) goto S130; +/* + XN +*/ + if(!(*xn <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -5; + return; +S130: +S120: + if(*which == 2) goto S170; +/* + S +*/ + if(!(*s < 0.0e0 || (*which != 3 && *s > *xn))) goto S160; + if(!(*s < 0.0e0)) goto S140; + *bound = 0.0e0; + goto S150; +S140: + *bound = *xn; +S150: + *status = -4; + return; +S170: +S160: + if(*which == 4) goto S210; +/* + PR +*/ + if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S200; + if(!(*pr < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = -6; + return; +S210: +S200: + if(*which == 4) goto S250; +/* + OMPR +*/ + if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S240; + if(!(*ompr < 0.0e0)) goto S220; + *bound = 0.0e0; + goto S230; +S220: + *bound = 1.0e0; +S230: + *status = -7; + return; +S250: +S240: + if(*which == 1) goto S290; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S280; + if(!(pq < 0.0e0)) goto S260; + *bound = 0.0e0; + goto S270; +S260: + *bound = 1.0e0; +S270: + *status = 3; + return; +S290: +S280: + if(*which == 4) goto S330; +/* + PR + OMPR +*/ + prompr = *pr+*ompr; + if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S320; + if(!(prompr < 0.0e0)) goto S300; + *bound = 0.0e0; + goto S310; +S300: + *bound = 1.0e0; +S310: + *status = 4; + return; +S330: +S320: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumbin(s,xn,pr,ompr,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T5 = atol; + T6 = tol; + dstinv(&K2,xn,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S340: + if(!(*status == 1)) goto S370; + cumbin(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S350; + fx = cum-*p; + goto S360; +S350: + fx = ccum-*q; +S360: + dinvr(status,s,&fx,&qleft,&qhi); + goto S340; +S370: + if(!(*status == -1)) goto S400; + if(!qleft) goto S380; + *status = 1; + *bound = 0.0e0; + goto S390; +S380: + *status = 2; + *bound = *xn; +S400: +S390: + ; + } + else if(3 == *which) { +/* + Calculating XN +*/ + *xn = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,xn,&fx,&qleft,&qhi); +S410: + if(!(*status == 1)) goto S440; + cumbin(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S420; + fx = cum-*p; + goto S430; +S420: + fx = ccum-*q; +S430: + dinvr(status,xn,&fx,&qleft,&qhi); + goto S410; +S440: + if(!(*status == -1)) goto S470; + if(!qleft) goto S450; + *status = 1; + *bound = zero; + goto S460; +S450: + *status = 2; + *bound = inf; +S470: +S460: + ; + } + else if(4 == *which) { +/* + Calculating PR and OMPR +*/ + T12 = atol; + T13 = tol; + dstzr(&K2,&K11,&T12,&T13); + if(!qporq) goto S500; + *status = 0; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; +S480: + if(!(*status == 1)) goto S490; + cumbin(s,xn,pr,ompr,&cum,&ccum); + fx = cum-*p; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; + goto S480; +S490: + goto S530; +S500: + *status = 0; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; +S510: + if(!(*status == 1)) goto S520; + cumbin(s,xn,pr,ompr,&cum,&ccum); + fx = ccum-*q; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; + goto S510; +S530: +S520: + if(!(*status == -1)) goto S560; + if(!qleft) goto S540; + *status = 1; + *bound = 0.0e0; + goto S550; +S540: + *status = 2; + *bound = 1.0e0; +S550: + ; + } +S560: + return; +#undef atol +#undef tol +#undef zero +#undef inf +#undef one +} +void cdfchi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) +/********************************************************************** + + void cdfchi(int *which,double *p,double *q,double *x,double *df, + int *status,double *bound) + + Cumulative Distribution Function + CHI-Square distribution + + + Function + + + Calculates any one parameter of the chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and X + + P <--> The integral from 0 to X of the chi-square + distribution. + Input range: [0, 1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E100] + + DF <--> Degrees of freedom of the + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 indicates error returned from cumgam. See + references in cdfgam + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.19 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the chisqure + distribution to the incomplete distribution. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define inf 1.0e100 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq,porq; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T11; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + X +*/ + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 1) goto S190; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; + if(!(pq < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = 3; + return; +S190: +S180: + if(*which == 1) goto S220; +/* + Select the minimum of P or Q +*/ + qporq = *p <= *q; + if(!qporq) goto S200; + porq = *p; + goto S210; +S200: + porq = *q; +S220: +S210: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + *status = 0; + cumchi(x,df,p,q); + if(porq > 1.5e0) { + *status = 10; + return; + } + } + else if(2 == *which) { +/* + Calculating X +*/ + *x = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,x,&fx,&qleft,&qhi); +S230: + if(!(*status == 1)) goto S270; + cumchi(x,df,&cum,&ccum); + if(!qporq) goto S240; + fx = cum-*p; + goto S250; +S240: + fx = ccum-*q; +S250: + if(!(fx+porq > 1.5e0)) goto S260; + *status = 10; + return; +S260: + dinvr(status,x,&fx,&qleft,&qhi); + goto S230; +S270: + if(!(*status == -1)) goto S300; + if(!qleft) goto S280; + *status = 1; + *bound = 0.0e0; + goto S290; +S280: + *status = 2; + *bound = inf; +S300: +S290: + ; + } + else if(3 == *which) { +/* + Calculating DF +*/ + *df = 5.0e0; + T8 = zero; + T9 = inf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S310: + if(!(*status == 1)) goto S350; + cumchi(x,df,&cum,&ccum); + if(!qporq) goto S320; + fx = cum-*p; + goto S330; +S320: + fx = ccum-*q; +S330: + if(!(fx+porq > 1.5e0)) goto S340; + *status = 10; + return; +S340: + dinvr(status,df,&fx,&qleft,&qhi); + goto S310; +S350: + if(!(*status == -1)) goto S380; + if(!qleft) goto S360; + *status = 1; + *bound = zero; + goto S370; +S360: + *status = 2; + *bound = inf; +S370: + ; + } +S380: + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdfchn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) +/********************************************************************** + + void cdfchn(int *which,double *p,double *q,double *x,double *df, + double *pnonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central Chi-Square + + + Function + + + Calculates any one parameter of the non-central chi-square + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next three argument + values is to be calculated from the others. + Input range: 1..4 + iwhich = 1 : Calculate P and Q from X and DF + iwhich = 2 : Calculate X from P,DF and PNONC + iwhich = 3 : Calculate DF from P,X and PNONC + iwhich = 3 : Calculate PNONC from P,X and DF + + P <--> The integral from 0 to X of the non-central chi-square + distribution. + Input range: [0, 1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf* routines. + + X <--> Upper limit of integration of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E100] + + DF <--> Degrees of freedom of the non-central + chi-square distribution. + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + PNONC <--> Non-centrality parameter of the non-central + chi-square distribution. + Input range: [0, +infinity). + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.25 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + +**********************************************************************/ +{ +#define tent4 1.0e4 +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define one ( 1.0e0 - 1.0e-16 ) +#define inf 1.0e100 +static double K1 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double fx,cum,ccum; +static unsigned long qhi,qleft; +static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > one)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = one; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 2) goto S90; +/* + X +*/ + if(!(*x < 0.0e0)) goto S80; + *bound = 0.0e0; + *status = -4; + return; +S90: +S80: + if(*which == 3) goto S110; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S100; + *bound = 0.0e0; + *status = -5; + return; +S110: +S100: + if(*which == 4) goto S130; +/* + PNONC +*/ + if(!(*pnonc < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -6; + return; +S130: +S120: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P and Q +*/ + cumchn(x,df,pnonc,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating X +*/ + *x = 5.0e0; + T2 = inf; + T5 = atol; + T6 = tol; + dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,x,&fx,&qleft,&qhi); +S140: + if(!(*status == 1)) goto S150; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,x,&fx,&qleft,&qhi); + goto S140; +S150: + if(!(*status == -1)) goto S180; + if(!qleft) goto S160; + *status = 1; + *bound = 0.0e0; + goto S170; +S160: + *status = 2; + *bound = inf; +S180: +S170: + ; + } + else if(3 == *which) { +/* + Calculating DF +*/ + *df = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S190: + if(!(*status == 1)) goto S200; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,df,&fx,&qleft,&qhi); + goto S190; +S200: + if(!(*status == -1)) goto S230; + if(!qleft) goto S210; + *status = 1; + *bound = zero; + goto S220; +S210: + *status = 2; + *bound = inf; +S230: +S220: + ; + } + else if(4 == *which) { +/* + Calculating PNONC +*/ + *pnonc = 5.0e0; + T11 = tent4; + T12 = atol; + T13 = tol; + dstinv(&K1,&T11,&K3,&K3,&K4,&T12,&T13); + *status = 0; + dinvr(status,pnonc,&fx,&qleft,&qhi); +S240: + if(!(*status == 1)) goto S250; + cumchn(x,df,pnonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,pnonc,&fx,&qleft,&qhi); + goto S240; +S250: + if(!(*status == -1)) goto S280; + if(!qleft) goto S260; + *status = 1; + *bound = zero; + goto S270; +S260: + *status = 2; + *bound = tent4; +S270: + ; + } +S280: + return; +#undef tent4 +#undef tol +#undef atol +#undef zero +#undef one +#undef inf +} +void cdff(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) +/********************************************************************** + + void cdff(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,int *status,double *bound) + + Cumulative Distribution Function + F distribution + + + Function + + + Calculates any one parameter of the F distribution + given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from F,DFN and DFD + iwhich = 2 : Calculate F from P,Q,DFN and DFD + iwhich = 3 : Calculate DFN from P,Q,F and DFD + iwhich = 4 : Calculate DFD from P,Q,F and DFN + + P <--> The integral from 0 to F of the f-density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + F <--> Upper limit of integration of the f-density. + Input range: [0, +infinity). + Search range: [0,1E100] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.2 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function for the F variate to + that of an incomplete beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The value of the cumulative F distribution is not necessarily + monotone in either degrees of freedom. There thus may be two + values that provide a given CDF value. This routine assumes + monotonicity and will find an arbitrary one of the two values. + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define inf 1.0e100 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double pq,fx,cum,ccum; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + F +*/ + if(!(*f < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + DFN +*/ + if(!(*dfn <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + DFD +*/ + if(!(*dfd <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: + if(*which == 1) goto S210; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; + if(!(pq < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = 3; + return; +S210: +S200: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumf(f,dfn,dfd,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating F +*/ + *f = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,f,&fx,&qleft,&qhi); +S220: + if(!(*status == 1)) goto S250; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S230; + fx = cum-*p; + goto S240; +S230: + fx = ccum-*q; +S240: + dinvr(status,f,&fx,&qleft,&qhi); + goto S220; +S250: + if(!(*status == -1)) goto S280; + if(!qleft) goto S260; + *status = 1; + *bound = 0.0e0; + goto S270; +S260: + *status = 2; + *bound = inf; +S280: +S270: + ; + } + else if(3 == *which) { +/* + Calculating DFN +*/ + *dfn = 5.0e0; + T8 = zero; + T9 = inf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,dfn,&fx,&qleft,&qhi); +S290: + if(!(*status == 1)) goto S320; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S300; + fx = cum-*p; + goto S310; +S300: + fx = ccum-*q; +S310: + dinvr(status,dfn,&fx,&qleft,&qhi); + goto S290; +S320: + if(!(*status == -1)) goto S350; + if(!qleft) goto S330; + *status = 1; + *bound = zero; + goto S340; +S330: + *status = 2; + *bound = inf; +S350: +S340: + ; + } + else if(4 == *which) { +/* + Calculating DFD +*/ + *dfd = 5.0e0; + T12 = zero; + T13 = inf; + T14 = atol; + T15 = tol; + dstinv(&T12,&T13,&K4,&K4,&K5,&T14,&T15); + *status = 0; + dinvr(status,dfd,&fx,&qleft,&qhi); +S360: + if(!(*status == 1)) goto S390; + cumf(f,dfn,dfd,&cum,&ccum); + if(!qporq) goto S370; + fx = cum-*p; + goto S380; +S370: + fx = ccum-*q; +S380: + dinvr(status,dfd,&fx,&qleft,&qhi); + goto S360; +S390: + if(!(*status == -1)) goto S420; + if(!qleft) goto S400; + *status = 1; + *bound = zero; + goto S410; +S400: + *status = 2; + *bound = inf; +S410: + ; + } +S420: + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdffnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) +/********************************************************************** + + void cdffnc(int *which,double *p,double *q,double *f,double *dfn, + double *dfd,double *phonc,int *status,double *bound) + + Cumulative Distribution Function + Non-central F distribution + + + Function + + + Calculates any one parameter of the Non-central F + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next five argument + values is to be calculated from the others. + Legal range: 1..5 + iwhich = 1 : Calculate P and Q from F,DFN,DFD and PNONC + iwhich = 2 : Calculate F from P,Q,DFN,DFD and PNONC + iwhich = 3 : Calculate DFN from P,Q,F,DFD and PNONC + iwhich = 4 : Calculate DFD from P,Q,F,DFN and PNONC + iwhich = 5 : Calculate PNONC from P,Q,F,DFN and DFD + + P <--> The integral from 0 to F of the non-central f-density. + Input range: [0,1-1E-16). + + Q <--> 1-P. + Q is not used by this subroutine and is only included + for similarity with other cdf* routines. + + F <--> Upper limit of integration of the non-central f-density. + Input range: [0, +infinity). + Search range: [0,1E100] + + DFN < --> Degrees of freedom of the numerator sum of squares. + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + DFD < --> Degrees of freedom of the denominator sum of squares. + Must be in range: (0, +infinity). + Input range: (0, +infinity). + Search range: [ 1E-100, 1E100] + + PNONC <-> The non-centrality parameter + Input range: [0,infinity) + Search range: [0,1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.6.20 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to compute the cumulative + distribution function. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + WARNING + + The computation time required for this routine is proportional + to the noncentrality parameter (PNONC). Very large values of + this parameter can consume immense computer resources. This is + why the search range is bounded by 10,000. + + WARNING + + The value of the cumulative noncentral F distribution is not + necessarily monotone in either degrees of freedom. There thus + may be two values that provide a given CDF value. This routine + assumes monotonicity and will find an arbitrary one of the two + values. + +**********************************************************************/ +{ +#define tent4 1.0e4 +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define one ( 1.0e0 - 1.0e-16 ) +#define inf 1.0e100 +static double K1 = 0.0e0; +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double fx,cum,ccum; +static unsigned long qhi,qleft; +static double T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14,T15,T16,T17; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 5)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 5.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > one)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = one; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 2) goto S90; +/* + F +*/ + if(!(*f < 0.0e0)) goto S80; + *bound = 0.0e0; + *status = -4; + return; +S90: +S80: + if(*which == 3) goto S110; +/* + DFN +*/ + if(!(*dfn <= 0.0e0)) goto S100; + *bound = 0.0e0; + *status = -5; + return; +S110: +S100: + if(*which == 4) goto S130; +/* + DFD +*/ + if(!(*dfd <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -6; + return; +S130: +S120: + if(*which == 5) goto S150; +/* + PHONC +*/ + if(!(*phonc < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -7; + return; +S150: +S140: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumfnc(f,dfn,dfd,phonc,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating F +*/ + *f = 5.0e0; + T2 = inf; + T5 = atol; + T6 = tol; + dstinv(&K1,&T2,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,f,&fx,&qleft,&qhi); +S160: + if(!(*status == 1)) goto S170; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,f,&fx,&qleft,&qhi); + goto S160; +S170: + if(!(*status == -1)) goto S200; + if(!qleft) goto S180; + *status = 1; + *bound = 0.0e0; + goto S190; +S180: + *status = 2; + *bound = inf; +S200: +S190: + ; + } + else if(3 == *which) { +/* + Calculating DFN +*/ + *dfn = 5.0e0; + T7 = zero; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,dfn,&fx,&qleft,&qhi); +S210: + if(!(*status == 1)) goto S220; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,dfn,&fx,&qleft,&qhi); + goto S210; +S220: + if(!(*status == -1)) goto S250; + if(!qleft) goto S230; + *status = 1; + *bound = zero; + goto S240; +S230: + *status = 2; + *bound = inf; +S250: +S240: + ; + } + else if(4 == *which) { +/* + Calculating DFD +*/ + *dfd = 5.0e0; + T11 = zero; + T12 = inf; + T13 = atol; + T14 = tol; + dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14); + *status = 0; + dinvr(status,dfd,&fx,&qleft,&qhi); +S260: + if(!(*status == 1)) goto S270; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,dfd,&fx,&qleft,&qhi); + goto S260; +S270: + if(!(*status == -1)) goto S300; + if(!qleft) goto S280; + *status = 1; + *bound = zero; + goto S290; +S280: + *status = 2; + *bound = inf; +S300: +S290: + ; + } + else if(5 == *which) { +/* + Calculating PHONC +*/ + *phonc = 5.0e0; + T15 = tent4; + T16 = atol; + T17 = tol; + dstinv(&K1,&T15,&K3,&K3,&K4,&T16,&T17); + *status = 0; + dinvr(status,phonc,&fx,&qleft,&qhi); +S310: + if(!(*status == 1)) goto S320; + cumfnc(f,dfn,dfd,phonc,&cum,&ccum); + fx = cum-*p; + dinvr(status,phonc,&fx,&qleft,&qhi); + goto S310; +S320: + if(!(*status == -1)) goto S350; + if(!qleft) goto S330; + *status = 1; + *bound = 0.0e0; + goto S340; +S330: + *status = 2; + *bound = tent4; +S340: + ; + } +S350: + return; +#undef tent4 +#undef tol +#undef atol +#undef zero +#undef one +#undef inf +} +void cdfgam(int *which,double *p,double *q,double *x,double *shape, + double *scale,int *status,double *bound) +/********************************************************************** + + void cdfgam(int *which,double *p,double *q,double *x,double *shape, + double *scale,int *status,double *bound) + + Cumulative Distribution Function + GAMma Distribution + + + Function + + + Calculates any one parameter of the gamma + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,SHAPE and SCALE + iwhich = 2 : Calculate X from P,Q,SHAPE and SCALE + iwhich = 3 : Calculate SHAPE from P,Q,X and SCALE + iwhich = 4 : Calculate SCALE from P,Q,X and SHAPE + + P <--> The integral from 0 to X of the gamma density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X <--> The upper limit of integration of the gamma density. + Input range: [0, +infinity). + Search range: [0,1E100] + + SHAPE <--> The shape parameter of the gamma density. + Input range: (0, +infinity). + Search range: [1E-100,1E100] + + SCALE <--> The scale parameter of the gamma density. + Input range: (0, +infinity). + Search range: (1E-100,1E100] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 10 if the gamma or inverse gamma routine cannot + compute the answer. Usually happens only for + X and SHAPE very large (gt 1E10 or more) + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Cumulative distribution function (P) is calculated directly by + the code associated with: + + DiDinato, A. R. and Morris, A. H. Computation of the incomplete + gamma function ratios and their inverse. ACM Trans. Math. + Softw. 12 (1986), 377-393. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + + + Note + + + + The gamma density is proportional to + T**(SHAPE - 1) * EXP(- SCALE * T) + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define inf 1.0e100 +static int K1 = 1; +static double K5 = 0.5e0; +static double K6 = 5.0e0; +static double xx,fx,xscale,cum,ccum,pq,porq; +static int ierr; +static unsigned long qhi,qleft,qporq; +static double T2,T3,T4,T7,T8,T9; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + X +*/ + if(!(*x < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + SHAPE +*/ + if(!(*shape <= 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + SCALE +*/ + if(!(*scale <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: + if(*which == 1) goto S210; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S200; + if(!(pq < 0.0e0)) goto S180; + *bound = 0.0e0; + goto S190; +S180: + *bound = 1.0e0; +S190: + *status = 3; + return; +S210: +S200: + if(*which == 1) goto S240; +/* + Select the minimum of P or Q +*/ + qporq = *p <= *q; + if(!qporq) goto S220; + porq = *p; + goto S230; +S220: + porq = *q; +S240: +S230: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + *status = 0; + xscale = *x**scale; + cumgam(&xscale,shape,p,q); + if(porq > 1.5e0) *status = 10; + } + else if(2 == *which) { +/* + Computing X +*/ + T2 = -1.0e0; + gaminv(shape,&xx,&T2,p,q,&ierr); + if(ierr < 0.0e0) { + *status = 10; + return; + } + else { + *x = xx/ *scale; + *status = 0; + } + } + else if(3 == *which) { +/* + Computing SHAPE +*/ + *shape = 5.0e0; + xscale = *x**scale; + T3 = zero; + T4 = inf; + T7 = atol; + T8 = tol; + dstinv(&T3,&T4,&K5,&K5,&K6,&T7,&T8); + *status = 0; + dinvr(status,shape,&fx,&qleft,&qhi); +S250: + if(!(*status == 1)) goto S290; + cumgam(&xscale,shape,&cum,&ccum); + if(!qporq) goto S260; + fx = cum-*p; + goto S270; +S260: + fx = ccum-*q; +S270: + if(!((qporq && cum > 1.5e0) || (!qporq && ccum > 1.5e0))) goto S280; + *status = 10; + return; +S280: + dinvr(status,shape,&fx,&qleft,&qhi); + goto S250; +S290: + if(!(*status == -1)) goto S320; + if(!qleft) goto S300; + *status = 1; + *bound = zero; + goto S310; +S300: + *status = 2; + *bound = inf; +S320: +S310: + ; + } + else if(4 == *which) { +/* + Computing SCALE +*/ + T9 = -1.0e0; + gaminv(shape,&xx,&T9,p,q,&ierr); + if(ierr < 0.0e0) { + *status = 10; + return; + } + else { + *scale = xx/ *x; + *status = 0; + } + } + return; +#undef tol +#undef atol +#undef zero +#undef inf +} +void cdfnbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) +/********************************************************************** + + void cdfnbn(int *which,double *p,double *q,double *s,double *xn, + double *pr,double *ompr,int *status,double *bound) + + Cumulative Distribution Function + Negative BiNomial distribution + + + Function + + + Calculates any one parameter of the negative binomial + distribution given values for the others. + + The cumulative negative binomial distribution returns the + probability that there will be F or fewer failures before the + XNth success in binomial trials each of which has probability of + success PR. + + The individual term of the negative binomial is the probability of + S failures before XN successes and is + Choose( S, XN+S-1 ) * PR^(XN) * (1-PR)^S + + + Arguments + + + WHICH --> Integer indicating which of the next four argument + values is to be calculated from the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from S,XN,PR and OMPR + iwhich = 2 : Calculate S from P,Q,XN,PR and OMPR + iwhich = 3 : Calculate XN from P,Q,S,PR and OMPR + iwhich = 4 : Calculate PR and OMPR from P,Q,S and XN + + P <--> The cumulation from 0 to S of the negative + binomial distribution. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> The upper limit of cumulation of the binomial distribution. + There are F or fewer failures before the XNth success. + Input range: [0, +infinity). + Search range: [0, 1E100] + + XN <--> The number of successes. + Input range: [0, +infinity). + Search range: [0, 1E100] + + PR <--> The probability of success in each binomial trial. + Input range: [0,1]. + Search range: [0,1]. + + OMPR <--> 1-PR + Input range: [0,1]. + Search range: [0,1] + PR + OMPR = 1.0 + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + 4 if PR + OMPR .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.26 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce calculation of + the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define inf 1.0e100 +#define one 1.0e0 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double K11 = 1.0e0; +static double fx,xhi,xlo,pq,prompr,cum,ccum; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10,T12,T13; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + S +*/ + if(!(*s < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + XN +*/ + if(!(*xn < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 4) goto S190; +/* + PR +*/ + if(!(*pr < 0.0e0 || *pr > 1.0e0)) goto S180; + if(!(*pr < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = -6; + return; +S190: +S180: + if(*which == 4) goto S230; +/* + OMPR +*/ + if(!(*ompr < 0.0e0 || *ompr > 1.0e0)) goto S220; + if(!(*ompr < 0.0e0)) goto S200; + *bound = 0.0e0; + goto S210; +S200: + *bound = 1.0e0; +S210: + *status = -7; + return; +S230: +S220: + if(*which == 1) goto S270; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S260; + if(!(pq < 0.0e0)) goto S240; + *bound = 0.0e0; + goto S250; +S240: + *bound = 1.0e0; +S250: + *status = 3; + return; +S270: +S260: + if(*which == 4) goto S310; +/* + PR + OMPR +*/ + prompr = *pr+*ompr; + if(!(fabs(prompr-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S300; + if(!(prompr < 0.0e0)) goto S280; + *bound = 0.0e0; + goto S290; +S280: + *bound = 1.0e0; +S290: + *status = 4; + return; +S310: +S300: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumnbn(s,xn,pr,ompr,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S320: + if(!(*status == 1)) goto S350; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S330; + fx = cum-*p; + goto S340; +S330: + fx = ccum-*q; +S340: + dinvr(status,s,&fx,&qleft,&qhi); + goto S320; +S350: + if(!(*status == -1)) goto S380; + if(!qleft) goto S360; + *status = 1; + *bound = 0.0e0; + goto S370; +S360: + *status = 2; + *bound = inf; +S380: +S370: + ; + } + else if(3 == *which) { +/* + Calculating XN +*/ + *xn = 5.0e0; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); + *status = 0; + dinvr(status,xn,&fx,&qleft,&qhi); +S390: + if(!(*status == 1)) goto S420; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + if(!qporq) goto S400; + fx = cum-*p; + goto S410; +S400: + fx = ccum-*q; +S410: + dinvr(status,xn,&fx,&qleft,&qhi); + goto S390; +S420: + if(!(*status == -1)) goto S450; + if(!qleft) goto S430; + *status = 1; + *bound = 0.0e0; + goto S440; +S430: + *status = 2; + *bound = inf; +S450: +S440: + ; + } + else if(4 == *which) { +/* + Calculating PR and OMPR +*/ + T12 = atol; + T13 = tol; + dstzr(&K2,&K11,&T12,&T13); + if(!qporq) goto S480; + *status = 0; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; +S460: + if(!(*status == 1)) goto S470; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + fx = cum-*p; + dzror(status,pr,&fx,&xlo,&xhi,&qleft,&qhi); + *ompr = one-*pr; + goto S460; +S470: + goto S510; +S480: + *status = 0; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; +S490: + if(!(*status == 1)) goto S500; + cumnbn(s,xn,pr,ompr,&cum,&ccum); + fx = ccum-*q; + dzror(status,ompr,&fx,&xlo,&xhi,&qleft,&qhi); + *pr = one-*ompr; + goto S490; +S510: +S500: + if(!(*status == -1)) goto S540; + if(!qleft) goto S520; + *status = 1; + *bound = 0.0e0; + goto S530; +S520: + *status = 2; + *bound = 1.0e0; +S530: + ; + } +S540: + return; +#undef tol +#undef atol +#undef inf +#undef one +} +void cdfnor(int *which,double *p,double *q,double *x,double *mean, + double *sd,int *status,double *bound) +/********************************************************************** + + void cdfnor(int *which,double *p,double *q,double *x,double *mean, + double *sd,int *status,double *bound) + + Cumulative Distribution Function + NORmal distribution + + + Function + + + Calculates any one parameter of the normal + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which of the next parameter + values is to be calculated using values of the others. + Legal range: 1..4 + iwhich = 1 : Calculate P and Q from X,MEAN and SD + iwhich = 2 : Calculate X from P,Q,MEAN and SD + iwhich = 3 : Calculate MEAN from P,Q,X and SD + iwhich = 4 : Calculate SD from P,Q,X and MEAN + + P <--> The integral from -infinity to X of the normal density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + X < --> Upper limit of integration of the normal-density. + Input range: ( -infinity, +infinity) + + MEAN <--> The mean of the normal density. + Input range: (-infinity, +infinity) + + SD <--> Standard Deviation of the normal density. + Input range: (0, +infinity). + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + + + A slightly modified version of ANORM from + + Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN + Package of Special Function Routines and Test Drivers" + acm Transactions on Mathematical Software. 19, 22-32. + + is used to calulate the cumulative standard normal distribution. + + The rational functions from pages 90-95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY, 1980 are used as + starting values to Newton's Iterations which compute the inverse + standard normal. Therefore no searches are necessary for any + parameter. + + For X < -15, the asymptotic expansion for the normal is used as + the starting value in finding the inverse standard normal. + This is formula 26.2.12 of Abramowitz and Stegun. + + + Note + + + The normal density is proportional to + exp( - 0.5 * (( X - MEAN)/SD)**2) + +**********************************************************************/ +{ +static int K1 = 1; +static double z,pq; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + *status = 0; + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 4.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p <= 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 1) goto S150; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S140; + if(!(pq < 0.0e0)) goto S120; + *bound = 0.0e0; + goto S130; +S120: + *bound = 1.0e0; +S130: + *status = 3; + return; +S150: +S140: + if(*which == 4) goto S170; +/* + SD +*/ + if(!(*sd <= 0.0e0)) goto S160; + *bound = 0.0e0; + *status = -6; + return; +S170: +S160: +/* + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Computing P +*/ + z = (*x-*mean)/ *sd; + cumnor(&z,p,q); + } + else if(2 == *which) { +/* + Computing X +*/ + z = dinvnr(p,q); + *x = *sd*z+*mean; + } + else if(3 == *which) { +/* + Computing the MEAN +*/ + z = dinvnr(p,q); + *mean = *x-*sd*z; + } + else if(4 == *which) { +/* + Computing SD +*/ + z = dinvnr(p,q); + *sd = (*x-*mean)/z; + } + return; +} +void cdfpoi(int *which,double *p,double *q,double *s,double *xlam, + int *status,double *bound) +/********************************************************************** + + void cdfpoi(int *which,double *p,double *q,double *s,double *xlam, + int *status,double *bound) + + Cumulative Distribution Function + POIsson distribution + + + Function + + + Calculates any one parameter of the Poisson + distribution given values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + value is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from S and XLAM + iwhich = 2 : Calculate A from P,Q and XLAM + iwhich = 3 : Calculate XLAM from P,Q and S + + P <--> The cumulation from 0 to S of the poisson density. + Input range: [0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + S <--> Upper limit of cumulation of the Poisson. + Input range: [0, +infinity). + Search range: [0,1E100] + + XLAM <--> Mean of the Poisson distribution. + Input range: [0, +infinity). + Search range: [0,1E100] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.4.21 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of computing a + chi-square, hence an incomplete gamma function. + + Cumulative distribution function (P) is calculated directly. + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define inf 1.0e100 +static int K1 = 1; +static double K2 = 0.0e0; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq; +static unsigned long qhi,qleft,qporq; +static double T3,T6,T7,T8,T9,T10; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p < 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 2) goto S130; +/* + S +*/ + if(!(*s < 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -4; + return; +S130: +S120: + if(*which == 3) goto S150; +/* + XLAM +*/ + if(!(*xlam < 0.0e0)) goto S140; + *bound = 0.0e0; + *status = -5; + return; +S150: +S140: + if(*which == 1) goto S190; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S180; + if(!(pq < 0.0e0)) goto S160; + *bound = 0.0e0; + goto S170; +S160: + *bound = 1.0e0; +S170: + *status = 3; + return; +S190: +S180: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Calculating P +*/ + cumpoi(s,xlam,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Calculating S +*/ + *s = 5.0e0; + T3 = inf; + T6 = atol; + T7 = tol; + dstinv(&K2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,s,&fx,&qleft,&qhi); +S200: + if(!(*status == 1)) goto S230; + cumpoi(s,xlam,&cum,&ccum); + if(!qporq) goto S210; + fx = cum-*p; + goto S220; +S210: + fx = ccum-*q; +S220: + dinvr(status,s,&fx,&qleft,&qhi); + goto S200; +S230: + if(!(*status == -1)) goto S260; + if(!qleft) goto S240; + *status = 1; + *bound = 0.0e0; + goto S250; +S240: + *status = 2; + *bound = inf; +S260: +S250: + ; + } + else if(3 == *which) { +/* + Calculating XLAM +*/ + *xlam = 5.0e0; + T8 = inf; + T9 = atol; + T10 = tol; + dstinv(&K2,&T8,&K4,&K4,&K5,&T9,&T10); + *status = 0; + dinvr(status,xlam,&fx,&qleft,&qhi); +S270: + if(!(*status == 1)) goto S300; + cumpoi(s,xlam,&cum,&ccum); + if(!qporq) goto S280; + fx = cum-*p; + goto S290; +S280: + fx = ccum-*q; +S290: + dinvr(status,xlam,&fx,&qleft,&qhi); + goto S270; +S300: + if(!(*status == -1)) goto S330; + if(!qleft) goto S310; + *status = 1; + *bound = 0.0e0; + goto S320; +S310: + *status = 2; + *bound = inf; +S320: + ; + } +S330: + return; +#undef tol +#undef atol +#undef inf +} +void cdft(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) +/********************************************************************** + + void cdft(int *which,double *p,double *q,double *t,double *df, + int *status,double *bound) + + Cumulative Distribution Function + T distribution + + + Function + + + Calculates any one parameter of the t distribution given + values for the others. + + + Arguments + + + WHICH --> Integer indicating which argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from T and DF + iwhich = 2 : Calculate T from P,Q and DF + iwhich = 3 : Calculate DF from P,Q and T + + P <--> The integral from -infinity to t of the t-density. + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + T <--> Upper limit of integration of the t-density. + Input range: ( -infinity, +infinity). + Search range: [ -1E100, 1E100 ] + + DF <--> Degrees of freedom of the t-distribution. + Input range: (0 , +infinity). + Search range: [1e-100, 1E10] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + + Method + + + Formula 26.5.27 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the computation + of the cumulative distribution function to that of an incomplete + beta. + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define inf 1.0e100 +#define rtinf 1.0e100 +#define maxdf 1.0e10 +static int K1 = 1; +static double K4 = 0.5e0; +static double K5 = 5.0e0; +static double fx,cum,ccum,pq; +static unsigned long qhi,qleft,qporq; +static double T2,T3,T6,T7,T8,T9,T10,T11; +/* + .. + .. Executable Statements .. +*/ +/* + Check arguments +*/ + if(!(*which < 1 || *which > 3)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 3.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; +/* + P +*/ + if(!(*p <= 0.0e0 || *p > 1.0e0)) goto S60; + if(!(*p <= 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = 1.0e0; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 1) goto S110; +/* + Q +*/ + if(!(*q <= 0.0e0 || *q > 1.0e0)) goto S100; + if(!(*q <= 0.0e0)) goto S80; + *bound = 0.0e0; + goto S90; +S80: + *bound = 1.0e0; +S90: + *status = -3; + return; +S110: +S100: + if(*which == 3) goto S130; +/* + DF +*/ + if(!(*df <= 0.0e0)) goto S120; + *bound = 0.0e0; + *status = -5; + return; +S130: +S120: + if(*which == 1) goto S170; +/* + P + Q +*/ + pq = *p+*q; + if(!(fabs(pq-0.5e0-0.5e0) > 3.0e0*spmpar(&K1))) goto S160; + if(!(pq < 0.0e0)) goto S140; + *bound = 0.0e0; + goto S150; +S140: + *bound = 1.0e0; +S150: + *status = 3; + return; +S170: +S160: + if(!(*which == 1)) qporq = *p <= *q; +/* + Select the minimum of P or Q + Calculate ANSWERS +*/ + if(1 == *which) { +/* + Computing P and Q +*/ + cumt(t,df,p,q); + *status = 0; + } + else if(2 == *which) { +/* + Computing T + .. Get initial approximation for T +*/ + *t = dt1(p,q,df); + T2 = -rtinf; + T3 = rtinf; + T6 = atol; + T7 = tol; + dstinv(&T2,&T3,&K4,&K4,&K5,&T6,&T7); + *status = 0; + dinvr(status,t,&fx,&qleft,&qhi); +S180: + if(!(*status == 1)) goto S210; + cumt(t,df,&cum,&ccum); + if(!qporq) goto S190; + fx = cum-*p; + goto S200; +S190: + fx = ccum-*q; +S200: + dinvr(status,t,&fx,&qleft,&qhi); + goto S180; +S210: + if(!(*status == -1)) goto S240; + if(!qleft) goto S220; + *status = 1; + *bound = -rtinf; + goto S230; +S220: + *status = 2; + *bound = rtinf; +S240: +S230: + ; + } + else if(3 == *which) { +/* + Computing DF +*/ + *df = 5.0e0; + T8 = zero; + T9 = maxdf; + T10 = atol; + T11 = tol; + dstinv(&T8,&T9,&K4,&K4,&K5,&T10,&T11); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S250: + if(!(*status == 1)) goto S280; + cumt(t,df,&cum,&ccum); + if(!qporq) goto S260; + fx = cum-*p; + goto S270; +S260: + fx = ccum-*q; +S270: + dinvr(status,df,&fx,&qleft,&qhi); + goto S250; +S280: + if(!(*status == -1)) goto S310; + if(!qleft) goto S290; + *status = 1; + *bound = zero; + goto S300; +S290: + *status = 2; + *bound = maxdf; +S300: + ; + } +S310: + return; +#undef tol +#undef atol +#undef zero +#undef inf +#undef rtinf +#undef maxdf +} +void cdftnc(int *which,double *p,double *q,double *t,double *df, + double *pnonc,int *status,double *bound) +/********************************************************************** + + void cdftnc(int *which,double *p,double *q,double *t,double *df, + double *pnonc,int *status,double *bound) + + Cumulative Distribution Function + Non-Central T distribution + + Function + + Calculates any one parameter of the noncentral t distribution give + values for the others. + + Arguments + + WHICH --> Integer indicating which argument + values is to be calculated from the others. + Legal range: 1..3 + iwhich = 1 : Calculate P and Q from T,DF,PNONC + iwhich = 2 : Calculate T from P,Q,DF,PNONC + iwhich = 3 : Calculate DF from P,Q,T + iwhich = 4 : Calculate PNONC from P,Q,DF,T + + P <--> The integral from -infinity to t of the noncentral t-den + Input range: (0,1]. + + Q <--> 1-P. + Input range: (0, 1]. + P + Q = 1.0. + + T <--> Upper limit of integration of the noncentral t-density. + Input range: ( -infinity, +infinity). + Search range: [ -1E100, 1E100 ] + + DF <--> Degrees of freedom of the noncentral t-distribution. + Input range: (0 , +infinity). + Search range: [1e-100, 1E10] + + PNONC <--> Noncentrality parameter of the noncentral t-distributio + Input range: [-infinity , +infinity). + Search range: [-1e4, 1E4] + + STATUS <-- 0 if calculation completed correctly + -I if input parameter number I is out of range + 1 if answer appears to be lower than lowest + search bound + 2 if answer appears to be higher than greatest + search bound + 3 if P + Q .ne. 1 + + BOUND <-- Undefined if STATUS is 0 + + Bound exceeded by parameter number I if STATUS + is negative. + + Lower search bound if STATUS is 1. + + Upper search bound if STATUS is 2. + + Method + + Upper tail of the cumulative noncentral t is calculated usin + formulae from page 532 of Johnson, Kotz, Balakrishnan, Coninuou + Univariate Distributions, Vol 2, 2nd Edition. Wiley (1995) + + Computation of other parameters involve a seach for a value that + produces the desired value of P. The search relies on the + monotinicity of P with the other parameter. + +**********************************************************************/ +{ +#define tent4 1.0e4 +#define tol 1.0e-8 +#define atol 1.0e-50 +#define zero 1.0e-100 +#define one ( 1.0e0 - 1.0e-16 ) +#define inf 1.0e100 +static double K3 = 0.5e0; +static double K4 = 5.0e0; +static double ccum,cum,fx; +static unsigned long qhi,qleft; +static double T1,T2,T5,T6,T7,T8,T9,T10,T11,T12,T13,T14; +/* + .. + .. Executable Statements .. +*/ + if(!(*which < 1 || *which > 4)) goto S30; + if(!(*which < 1)) goto S10; + *bound = 1.0e0; + goto S20; +S10: + *bound = 5.0e0; +S20: + *status = -1; + return; +S30: + if(*which == 1) goto S70; + if(!(*p < 0.0e0 || *p > one)) goto S60; + if(!(*p < 0.0e0)) goto S40; + *bound = 0.0e0; + goto S50; +S40: + *bound = one; +S50: + *status = -2; + return; +S70: +S60: + if(*which == 3) goto S90; + if(!(*df <= 0.0e0)) goto S80; + *bound = 0.0e0; + *status = -5; + return; +S90: +S80: + if(*which == 4) goto S100; +S100: + if(1 == *which) { + cumtnc(t,df,pnonc,p,q); + *status = 0; + } + else if(2 == *which) { + *t = 5.0e0; + T1 = -inf; + T2 = inf; + T5 = atol; + T6 = tol; + dstinv(&T1,&T2,&K3,&K3,&K4,&T5,&T6); + *status = 0; + dinvr(status,t,&fx,&qleft,&qhi); +S110: + if(!(*status == 1)) goto S120; + cumtnc(t,df,pnonc,&cum,&ccum); + fx = cum - *p; + dinvr(status,t,&fx,&qleft,&qhi); + goto S110; +S120: + if(!(*status == -1)) goto S150; + if(!qleft) goto S130; + *status = 1; + *bound = -inf; + goto S140; +S130: + *status = 2; + *bound = inf; +S150: +S140: + ; + } + else if(3 == *which) { + *df = 5.0e0; + T7 = zero; + T8 = tent4; + T9 = atol; + T10 = tol; + dstinv(&T7,&T8,&K3,&K3,&K4,&T9,&T10); + *status = 0; + dinvr(status,df,&fx,&qleft,&qhi); +S160: + if(!(*status == 1)) goto S170; + cumtnc(t,df,pnonc,&cum,&ccum); + fx = cum - *p; + dinvr(status,df,&fx,&qleft,&qhi); + goto S160; +S170: + if(!(*status == -1)) goto S200; + if(!qleft) goto S180; + *status = 1; + *bound = zero; + goto S190; +S180: + *status = 2; + *bound = inf; +S200: +S190: + ; + } + else if(4 == *which) { + *pnonc = 5.0e0; + T11 = -tent4; + T12 = tent4; + T13 = atol; + T14 = tol; + dstinv(&T11,&T12,&K3,&K3,&K4,&T13,&T14); + *status = 0; + dinvr(status,pnonc,&fx,&qleft,&qhi); +S210: + if(!(*status == 1)) goto S220; + cumtnc(t,df,pnonc,&cum,&ccum); + fx = cum - *p; + dinvr(status,pnonc,&fx,&qleft,&qhi); + goto S210; +S220: + if(!(*status == -1)) goto S250; + if(!qleft) goto S230; + *status = 1; + *bound = 0.0e0; + goto S240; +S230: + *status = 2; + *bound = tent4; +S240: + ; + } +S250: + return; +#undef tent4 +#undef tol +#undef atol +#undef zero +#undef one +#undef inf +} +void cumbet(double *x,double *y,double *a,double *b,double *cum, + double *ccum) +/* +********************************************************************** + + void cumbet(double *x,double *y,double *a,double *b,double *cum, + double *ccum) + + Double precision cUMulative incomplete BETa distribution + + + Function + + + Calculates the cdf to X of the incomplete beta distribution + with parameters a and b. This is the integral from 0 to x + of (1/B(a,b))*f(t)) where f(t) = t**(a-1) * (1-t)**(b-1) + + + Arguments + + + X --> Upper limit of integration. + X is DOUBLE PRECISION + + Y --> 1 - X. + Y is DOUBLE PRECISION + + A --> First parameter of the beta distribution. + A is DOUBLE PRECISION + + B --> Second parameter of the beta distribution. + B is DOUBLE PRECISION + + CUM <-- Cumulative incomplete beta distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative incomplete beta distribution. + CCUM is DOUBLE PRECISION + + + Method + + + Calls the routine BRATIO. + + References + + Didonato, Armido R. and Morris, Alfred H. Jr. (1992) Algorithim + 708 Significant Digit Computation of the Incomplete Beta Function + Ratios. ACM ToMS, Vol.18, No. 3, Sept. 1992, 360-373. + +********************************************************************** +*/ +{ +static int ierr; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*y <= 0.0e0)) goto S20; + *cum = 1.0e0; + *ccum = 0.0e0; + return; +S20: + bratio(a,b,x,y,cum,ccum,&ierr); +/* + Call bratio routine +*/ + return; +} +void cumbin(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) +/* +********************************************************************** + + void cumbin(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) + + CUmulative BINomial distribution + + + Function + + + Returns the probability of 0 to S successes in XN binomial + trials, each of which has a probability of success, PBIN. + + + Arguments + + + S --> The upper limit of cumulation of the binomial distribution. + S is DOUBLE PRECISION + + XN --> The number of binomial trials. + XN is DOUBLE PRECISIO + + PBIN --> The probability of success in each binomial trial. + PBIN is DOUBLE PRECIS + + OMPR --> 1 - PBIN + OMPR is DOUBLE PRECIS + + CUM <-- Cumulative binomial distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative binomial distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.24 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the binomial + distribution to the cumulative beta distribution. + +********************************************************************** +*/ +{ +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + if(!(*s < *xn)) goto S10; + T1 = *s+1.0e0; + T2 = *xn-*s; + cumbet(pr,ompr,&T1,&T2,ccum,cum); + goto S20; +S10: + *cum = 1.0e0; + *ccum = 0.0e0; +S20: + return; +} +void cumchi(double *x,double *df,double *cum,double *ccum) +/* +********************************************************************** + + void cumchi(double *x,double *df,double *cum,double *ccum) + CUMulative of the CHi-square distribution + + + Function + + + Calculates the cumulative chi-square distribution. + + + Arguments + + + X --> Upper limit of integration of the + chi-square distribution. + X is DOUBLE PRECISION + + DF --> Degrees of freedom of the + chi-square distribution. + DF is DOUBLE PRECISION + + CUM <-- Cumulative chi-square distribution. + CUM is DOUBLE PRECISIO + + CCUM <-- Compliment of Cumulative chi-square distribution. + CCUM is DOUBLE PRECISI + + + Method + + + Calls incomplete gamma function (CUMGAM) + +********************************************************************** +*/ +{ +static double a,xx; +/* + .. + .. Executable Statements .. +*/ + a = *df*0.5e0; + xx = *x*0.5e0; + cumgam(&xx,&a,cum,ccum); + return; +} +void cumchn(double *x,double *df,double *pnonc,double *cum, + double *ccum) +/********************************************************************** + + void cumchn(double *x,double *df,double *pnonc,double *cum, + double *ccum) + + CUMulative of the Non-central CHi-square distribution + + Function + + Calculates the cumulative non-central chi-square + distribution, i.e., the probability that a random variable + which follows the non-central chi-square distribution, with + non-centrality parameter PNONC and continuous degrees of + freedom DF, is less than or equal to X. + + Arguments + + X --> Upper limit of integration of the non-central + chi-square distribution. + + DF --> Degrees of freedom of the non-central + chi-square distribution. + + PNONC --> Non-centrality parameter of the non-central + chi-square distribution. + + CUM <-- Cumulative non-central chi-square distribution. + + CCUM <-- Compliment of Cumulative non-central chi-square distribut + + + Method + + Uses formula 26.4.25 of Abramowitz and Stegun, Handbook of + Mathematical Functions, US NBS (1966) to calculate the + non-central chi-square. + + Variables + + EPS --- Convergence criterion. The sum stops when a + term is less than EPS*SUM. + + CCUM <-- Compliment of Cumulative non-central + chi-square distribution. + +**********************************************************************/ +{ +#define dg(i) (*df + 2.0e0 * (double)(i)) +#define qsmall(xx) (int)(sum < 1.0e-20 || (xx) < eps * sum) +static double eps = 1.0e-5; +static double adj,centaj,centwt,chid2,dfd2,lcntaj,lcntwt,lfact,pcent,pterm,sum, + sumadj,term,wt,xnonc; +static int i,icent; +static double T1,T2,T3; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*pnonc <= 1.0e-10 )) goto S20; +/* + When non-centrality parameter is (essentially) zero, + use cumulative chi-square distribution +*/ + cumchi(x,df,cum,ccum); + return; +S20: + xnonc = *pnonc / 2.0e0; +/* +*********************************************************************** + The following code calcualtes the weight, chi-square, and + adjustment term for the central term in the infinite series. + The central term is the one in which the poisson weight is + greatest. The adjustment term is the amount that must + be subtracted from the chi-square to move up two degrees + of freedom. +*********************************************************************** +*/ + icent = fifidint(xnonc); + if(icent == 0) icent = 1; + chid2 = *x / 2.0e0; +/* + Calculate central weight term +*/ + T1 = (double)(icent + 1); + lfact = alngam(&T1); + lcntwt = -xnonc + (double)icent * log(xnonc) - lfact; + centwt = exp(lcntwt); +/* + Calculate central chi-square +*/ + T2 = dg(icent); + cumchi(x,&T2,&pcent,ccum); +/* + Calculate central adjustment term +*/ + dfd2 = dg(icent) / 2.0e0; + T3 = 1.0e0 + dfd2; + lfact = alngam(&T3); + lcntaj = dfd2 * log(chid2) - chid2 - lfact; + centaj = exp(lcntaj); + sum = centwt * pcent; +/* +*********************************************************************** + Sum backwards from the central term towards zero. + Quit whenever either + (1) the zero term is reached, or + (2) the term gets small relative to the sum +*********************************************************************** +*/ + sumadj = 0.0e0; + adj = centaj; + wt = centwt; + i = icent; + goto S40; +S30: + if(qsmall(term) || i == 0) goto S50; +S40: + dfd2 = dg(i) / 2.0e0; +/* + Adjust chi-square for two fewer degrees of freedom. + The adjusted value ends up in PTERM. +*/ + adj = adj * dfd2 / chid2; + sumadj += adj; + pterm = pcent + sumadj; +/* + Adjust poisson weight for J decreased by one +*/ + wt *= ((double)i / xnonc); + term = wt * pterm; + sum += term; + i -= 1; + goto S30; +S50: +/* +*********************************************************************** + Now sum forward from the central term towards infinity. + Quit when either + (1) the term gets small relative to the sum, or +*********************************************************************** +*/ + sumadj = adj = centaj; + wt = centwt; + i = icent; + goto S70; +S60: + if(qsmall(term)) goto S80; +S70: +/* + Update weights for next higher J +*/ + wt *= (xnonc / (double)(i + 1)); +/* + Calculate PTERM and add term to sum +*/ + pterm = pcent - sumadj; + term = wt * pterm; + sum += term; +/* + Update adjustment term for DF for next iteration +*/ + i += 1; + dfd2 = dg(i) / 2.0e0; + adj = adj * chid2 / dfd2; + sumadj += adj; + goto S60; +S80: + *cum = sum; + *ccum = 0.5e0 + (0.5e0 - *cum); + return; +#undef dg +#undef qsmall +} +void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) +/* +********************************************************************** + + void cumf(double *f,double *dfn,double *dfd,double *cum,double *ccum) + CUMulative F distribution + + + Function + + + Computes the integral from 0 to F of the f-density with DFN + and DFD degrees of freedom. + + + Arguments + + + F --> Upper limit of integration of the f-density. + F is DOUBLE PRECISION + + DFN --> Degrees of freedom of the numerator sum of squares. + DFN is DOUBLE PRECISI + + DFD --> Degrees of freedom of the denominator sum of squares. + DFD is DOUBLE PRECISI + + CUM <-- Cumulative f distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative f distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.28 of Abramowitz and Stegun is used to reduce + the cumulative F to a cumulative beta distribution. + + + Note + + + If F is less than or equal to 0, 0 is returned. + +********************************************************************** +*/ +{ +#define half 0.5e0 +#define done 1.0e0 +static double dsum,prod,xx,yy; +static int ierr; +static double T1,T2; +/* + .. + .. Executable Statements .. +*/ + if(!(*f <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + prod = *dfn**f; +/* + XX is such that the incomplete beta with parameters + DFD/2 and DFN/2 evaluated at XX is 1 - CUM or CCUM + YY is 1 - XX + Calculate the smaller of XX and YY accurately +*/ + dsum = *dfd+prod; + xx = *dfd/dsum; + if(xx > half) { + yy = prod/dsum; + xx = done-yy; + } + else yy = done-xx; + T1 = *dfd*half; + T2 = *dfn*half; + bratio(&T1,&T2,&xx,&yy,ccum,cum,&ierr); + return; +#undef half +#undef done +} +void cumfnc(double *f,double *dfn,double *dfd,double *pnonc, + double *cum,double *ccum) +/* +********************************************************************** + + F -NON- -C-ENTRAL F DISTRIBUTION + + + + Function + + + COMPUTES NONCENTRAL F DISTRIBUTION WITH DFN AND DFD + DEGREES OF FREEDOM AND NONCENTRALITY PARAMETER PNONC + + + Arguments + + + X --> UPPER LIMIT OF INTEGRATION OF NONCENTRAL F IN EQUATION + + DFN --> DEGREES OF FREEDOM OF NUMERATOR + + DFD --> DEGREES OF FREEDOM OF DENOMINATOR + + PNONC --> NONCENTRALITY PARAMETER. + + CUM <-- CUMULATIVE NONCENTRAL F DISTRIBUTION + + CCUM <-- COMPLIMENT OF CUMMULATIVE + + + Method + + + USES FORMULA 26.6.20 OF REFERENCE FOR INFINITE SERIES. + SERIES IS CALCULATED BACKWARD AND FORWARD FROM J = LAMBDA/2 + (THIS IS THE TERM WITH THE LARGEST POISSON WEIGHT) UNTIL + THE CONVERGENCE CRITERION IS MET. + + FOR SPEED, THE INCOMPLETE BETA FUNCTIONS ARE EVALUATED + BY FORMULA 26.5.16. + + + REFERENCE + + + HANDBOOD OF MATHEMATICAL FUNCTIONS + EDITED BY MILTON ABRAMOWITZ AND IRENE A. STEGUN + NATIONAL BUREAU OF STANDARDS APPLIED MATEMATICS SERIES - 55 + MARCH 1965 + P 947, EQUATIONS 26.6.17, 26.6.18 + + + Note + + + THE SUM CONTINUES UNTIL A SUCCEEDING TERM IS LESS THAN EPS + TIMES THE SUM (OR THE SUM IS LESS THAN 1.0E-20). EPS IS + SET TO 1.0E-4 IN A DATA STATEMENT WHICH CAN BE CHANGED. + +********************************************************************** +*/ +{ +#define qsmall(x) (int)(sum < 1.0e-20 || (x) < eps*sum) +#define half 0.5e0 +#define done 1.0e0 +static double eps = 1.0e-4; +static double dsum,dummy,prod,xx,yy,adn,aup,b,betdn,betup,centwt,dnterm,sum, + upterm,xmult,xnonc; +static int i,icent,ierr; +static double T1,T2,T3,T4,T5,T6; +/* + .. + .. Executable Statements .. +*/ + if(!(*f <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + if(!(*pnonc < 1.0e-10)) goto S20; +/* + Handle case in which the non-centrality parameter is + (essentially) zero. +*/ + cumf(f,dfn,dfd,cum,ccum); + return; +S20: + xnonc = *pnonc/2.0e0; +/* + Calculate the central term of the poisson weighting factor. +*/ + icent = (long)(xnonc); + if(icent == 0) icent = 1; +/* + Compute central weight term +*/ + T1 = (double)(icent+1); + centwt = exp(-xnonc+(double)icent*log(xnonc)-alngam(&T1)); +/* + Compute central incomplete beta term + Assure that minimum of arg to beta and 1 - arg is computed + accurately. +*/ + prod = *dfn**f; + dsum = *dfd+prod; + yy = *dfd/dsum; + if(yy > half) { + xx = prod/dsum; + yy = done-xx; + } + else xx = done-yy; + T2 = *dfn*half+(double)icent; + T3 = *dfd*half; + bratio(&T2,&T3,&xx,&yy,&betdn,&dummy,&ierr); + adn = *dfn/2.0e0+(double)icent; + aup = adn; + b = *dfd/2.0e0; + betup = betdn; + sum = centwt*betdn; +/* + Now sum terms backward from icent until convergence or all done +*/ + xmult = centwt; + i = icent; + T4 = adn+b; + T5 = adn+1.0e0; + dnterm = exp(alngam(&T4)-alngam(&T5)-alngam(&b)+adn*log(xx)+b*log(yy)); +S30: + if(qsmall(xmult*betdn) || i <= 0) goto S40; + xmult *= ((double)i/xnonc); + i -= 1; + adn -= 1.0; + dnterm = (adn+1.0)/((adn+b)*xx)*dnterm; + betdn += dnterm; + sum += (xmult*betdn); + goto S30; +S40: + i = icent+1; +/* + Now sum forwards until convergence +*/ + xmult = centwt; + if(aup-1.0+b == 0) upterm = exp(-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+ + b*log(yy)); + else { + T6 = aup-1.0+b; + upterm = exp(alngam(&T6)-alngam(&aup)-alngam(&b)+(aup-1.0)*log(xx)+b* + log(yy)); + } + goto S60; +S50: + if(qsmall(xmult*betup)) goto S70; +S60: + xmult *= (xnonc/(double)i); + i += 1; + aup += 1.0; + upterm = (aup+b-2.0e0)*xx/(aup-1.0)*upterm; + betup -= upterm; + sum += (xmult*betup); + goto S50; +S70: + *cum = sum; + *ccum = 0.5e0+(0.5e0-*cum); + return; +#undef qsmall +#undef half +#undef done +} +void cumgam(double *x,double *a,double *cum,double *ccum) +/* +********************************************************************** + + void cumgam(double *x,double *a,double *cum,double *ccum) + Double precision cUMulative incomplete GAMma distribution + + + Function + + + Computes the cumulative of the incomplete gamma + distribution, i.e., the integral from 0 to X of + (1/GAM(A))*EXP(-T)*T**(A-1) DT + where GAM(A) is the complete gamma function of A, i.e., + GAM(A) = integral from 0 to infinity of + EXP(-T)*T**(A-1) DT + + + Arguments + + + X --> The upper limit of integration of the incomplete gamma. + X is DOUBLE PRECISION + + A --> The shape parameter of the incomplete gamma. + A is DOUBLE PRECISION + + CUM <-- Cumulative incomplete gamma distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative incomplete gamma distribution. + CCUM is DOUBLE PRECISIO + + + Method + + + Calls the routine GRATIO. + +********************************************************************** +*/ +{ +static int K1 = 0; +/* + .. + .. Executable Statements .. +*/ + if(!(*x <= 0.0e0)) goto S10; + *cum = 0.0e0; + *ccum = 1.0e0; + return; +S10: + gratio(a,x,cum,ccum,&K1); +/* + Call gratio routine +*/ + return; +} +void cumnbn(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) +/* +********************************************************************** + + void cumnbn(double *s,double *xn,double *pr,double *ompr, + double *cum,double *ccum) + + CUmulative Negative BINomial distribution + + + Function + + + Returns the probability that it there will be S or fewer failures + before there are XN successes, with each binomial trial having + a probability of success PR. + + Prob(# failures = S | XN successes, PR) = + ( XN + S - 1 ) + ( ) * PR^XN * (1-PR)^S + ( S ) + + + Arguments + + + S --> The number of failures + S is DOUBLE PRECISION + + XN --> The number of successes + XN is DOUBLE PRECISIO + + PR --> The probability of success in each binomial trial. + PR is DOUBLE PRECISIO + + OMPR --> 1 - PR + OMPR is DOUBLE PRECIS + + CUM <-- Cumulative negative binomial distribution. + CUM is DOUBLE PRECISI + + CCUM <-- Compliment of Cumulative negative binomial distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.26 of Abramowitz and Stegun, Handbook of + Mathematical Functions (1966) is used to reduce the negative + binomial distribution to the cumulative beta distribution. + +********************************************************************** +*/ +{ +static double T1; +/* + .. + .. Executable Statements .. +*/ + T1 = *s+1.e0; + cumbet(pr,ompr,xn,&T1,cum,ccum); + return; +} +void cumnor(double *arg,double *result,double *ccum) +/* +********************************************************************** + + void cumnor(double *arg,double *result,double *ccum) + + + Function + + + Computes the cumulative of the normal distribution, i.e., + the integral from -infinity to x of + (1/sqrt(2*pi)) exp(-u*u/2) du + + X --> Upper limit of integration. + X is DOUBLE PRECISION + + RESULT <-- Cumulative normal distribution. + RESULT is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative normal distribution. + CCUM is DOUBLE PRECISION + + Renaming of function ANORM from: + + Cody, W.D. (1993). "ALGORITHM 715: SPECFUN - A Portabel FORTRAN + Package of Special Function Routines and Test Drivers" + acm Transactions on Mathematical Software. 19, 22-32. + + with slight modifications to return ccum and to deal with + machine constants. + +********************************************************************** + Original Comments: +------------------------------------------------------------------ + + This function evaluates the normal distribution function: + + / x + 1 | -t*t/2 + P(x) = ----------- | e dt + sqrt(2 pi) | + /-oo + + The main computation evaluates near-minimax approximations + derived from those in "Rational Chebyshev approximations for + the error function" by W. J. Cody, Math. Comp., 1969, 631-637. + This transportable program uses rational functions that + theoretically approximate the normal distribution function to + at least 18 significant decimal digits. The accuracy achieved + depends on the arithmetic system, the compiler, the intrinsic + functions, and proper selection of the machine-dependent + constants. + +******************************************************************* +******************************************************************* + + Explanation of machine-dependent constants. + + MIN = smallest machine representable number. + + EPS = argument below which anorm(x) may be represented by + 0.5 and above which x*x will not underflow. + A conservative value is the largest machine number X + such that 1.0 + X = 1.0 to machine precision. +******************************************************************* +******************************************************************* + + Error returns + + The program returns ANORM = 0 for ARG .LE. XLOW. + + + Intrinsic functions required are: + + ABS, AINT, EXP + + + Author: W. J. Cody + Mathematics and Computer Science Division + Argonne National Laboratory + Argonne, IL 60439 + + Latest modification: March 15, 1992 + +------------------------------------------------------------------ +*/ +{ +static double a[5] = { + 2.2352520354606839287e00,1.6102823106855587881e02,1.0676894854603709582e03, + 1.8154981253343561249e04,6.5682337918207449113e-2 +}; +static double b[4] = { + 4.7202581904688241870e01,9.7609855173777669322e02,1.0260932208618978205e04, + 4.5507789335026729956e04 +}; +static double c[9] = { + 3.9894151208813466764e-1,8.8831497943883759412e00,9.3506656132177855979e01, + 5.9727027639480026226e02,2.4945375852903726711e03,6.8481904505362823326e03, + 1.1602651437647350124e04,9.8427148383839780218e03,1.0765576773720192317e-8 +}; +static double d[8] = { + 2.2266688044328115691e01,2.3538790178262499861e02,1.5193775994075548050e03, + 6.4855582982667607550e03,1.8615571640885098091e04,3.4900952721145977266e04, + 3.8912003286093271411e04,1.9685429676859990727e04 +}; +static double half = 0.5e0; +static double p[6] = { + 2.1589853405795699e-1,1.274011611602473639e-1,2.2235277870649807e-2, + 1.421619193227893466e-3,2.9112874951168792e-5,2.307344176494017303e-2 +}; +static double one = 1.0e0; +static double q[5] = { + 1.28426009614491121e00,4.68238212480865118e-1,6.59881378689285515e-2, + 3.78239633202758244e-3,7.29751555083966205e-5 +}; +static double sixten = 1.60e0; +static double sqrpi = 3.9894228040143267794e-1; +static double thrsh = 0.66291e0; +static double root32 = 5.656854248e0; +static double zero = 0.0e0; +static int K1 = 1; +static int K2 = 2; +static int i; +static double del,eps,temp,x,xden,xnum,y,xsq,min; +/* +------------------------------------------------------------------ + Machine dependent constants +------------------------------------------------------------------ +*/ + eps = spmpar(&K1)*0.5e0; + min = spmpar(&K2); + x = *arg; + y = fabs(x); + if(y <= thrsh) { +/* +------------------------------------------------------------------ + Evaluate anorm for |X| <= 0.66291 +------------------------------------------------------------------ +*/ + xsq = zero; + if(y > eps) xsq = x*x; + xnum = a[4]*xsq; + xden = xsq; + for(i=0; i<3; i++) { + xnum = (xnum+a[i])*xsq; + xden = (xden+b[i])*xsq; + } + *result = x*(xnum+a[3])/(xden+b[3]); + temp = *result; + *result = half+temp; + *ccum = half-temp; + } +/* +------------------------------------------------------------------ + Evaluate anorm for 0.66291 <= |X| <= sqrt(32) +------------------------------------------------------------------ +*/ + else if(y <= root32) { + xnum = c[8]*y; + xden = y; + for(i=0; i<7; i++) { + xnum = (xnum+c[i])*y; + xden = (xden+d[i])*y; + } + *result = (xnum+c[7])/(xden+d[7]); + xsq = fifdint(y*sixten)/sixten; + del = (y-xsq)*(y+xsq); + *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; + *ccum = one-*result; + if(x > zero) { + temp = *result; + *result = *ccum; + *ccum = temp; + } + } +/* +------------------------------------------------------------------ + Evaluate anorm for |X| > sqrt(32) +------------------------------------------------------------------ +*/ + else { + *result = zero; + xsq = one/(x*x); + xnum = p[5]*xsq; + xden = xsq; + for(i=0; i<4; i++) { + xnum = (xnum+p[i])*xsq; + xden = (xden+q[i])*xsq; + } + *result = xsq*(xnum+p[4])/(xden+q[4]); + *result = (sqrpi-*result)/y; + xsq = fifdint(x*sixten)/sixten; + del = (x-xsq)*(x+xsq); + *result = exp(-(xsq*xsq*half))*exp(-(del*half))**result; + *ccum = one-*result; + if(x > zero) { + temp = *result; + *result = *ccum; + *ccum = temp; + } + } + if(*result < min) *result = 0.0e0; +/* +------------------------------------------------------------------ + Fix up for negative argument, erf, etc. +------------------------------------------------------------------ +----------Last card of ANORM ---------- +*/ + if(*ccum < min) *ccum = 0.0e0; +} +void cumpoi(double *s,double *xlam,double *cum,double *ccum) +/* +********************************************************************** + + void cumpoi(double *s,double *xlam,double *cum,double *ccum) + CUMulative POIsson distribution + + + Function + + + Returns the probability of S or fewer events in a Poisson + distribution with mean XLAM. + + + Arguments + + + S --> Upper limit of cumulation of the Poisson. + S is DOUBLE PRECISION + + XLAM --> Mean of the Poisson distribution. + XLAM is DOUBLE PRECIS + + CUM <-- Cumulative poisson distribution. + CUM is DOUBLE PRECISION + + CCUM <-- Compliment of Cumulative poisson distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Uses formula 26.4.21 of Abramowitz and Stegun, Handbook of + Mathematical Functions to reduce the cumulative Poisson to + the cumulative chi-square distribution. + +********************************************************************** +*/ +{ +static double chi,df; +/* + .. + .. Executable Statements .. +*/ + df = 2.0e0*(*s+1.0e0); + chi = 2.0e0**xlam; + cumchi(&chi,&df,ccum,cum); + return; +} +void cumt(double *t,double *df,double *cum,double *ccum) +/* +********************************************************************** + + void cumt(double *t,double *df,double *cum,double *ccum) + CUMulative T-distribution + + + Function + + + Computes the integral from -infinity to T of the t-density. + + + Arguments + + + T --> Upper limit of integration of the t-density. + T is DOUBLE PRECISION + + DF --> Degrees of freedom of the t-distribution. + DF is DOUBLE PRECISIO + + CUM <-- Cumulative t-distribution. + CCUM is DOUBLE PRECIS + + CCUM <-- Compliment of Cumulative t-distribution. + CCUM is DOUBLE PRECIS + + + Method + + + Formula 26.5.27 of Abramowitz and Stegun, Handbook of + Mathematical Functions is used to reduce the t-distribution + to an incomplete beta. + +********************************************************************** +*/ +{ +static double K2 = 0.5e0; +static double xx,a,oma,tt,yy,dfptt,T1; +/* + .. + .. Executable Statements .. +*/ + tt = *t**t; + dfptt = *df+tt; + xx = *df/dfptt; + yy = tt/dfptt; + T1 = 0.5e0**df; + cumbet(&xx,&yy,&T1,&K2,&a,&oma); + if(!(*t <= 0.0e0)) goto S10; + *cum = 0.5e0*a; + *ccum = oma+*cum; + goto S20; +S10: + *ccum = 0.5e0*a; + *cum = oma+*ccum; +S20: + return; +} +void cumtnc(double *t,double *df,double *pnonc,double *cum, + double *ccum) +/********************************************************************** + + void cumtnc(double *t,double *df,double *pnonc,double *cum, + double *ccum) + + CUMulative Non-Central T-distribution + + + Function + + + Computes the integral from -infinity to T of the non-central + t-density. + + + Arguments + + + T --> Upper limit of integration of the non-central t-density. + + DF --> Degrees of freedom of the non-central t-distribution. + + PNONC --> Non-centrality parameter of the non-central t distibutio + + CUM <-- Cumulative t-distribution. + + CCUM <-- Compliment of Cumulative t-distribution. + + + Method + + Upper tail of the cumulative noncentral t using + formulae from page 532 of Johnson, Kotz, Balakrishnan, Coninuous + Univariate Distributions, Vol 2, 2nd Edition. Wiley (1995) + + This implementation starts the calculation at i = lambda, + which is near the largest Di. It then sums forward and backward. +**********************************************************************/ +{ +#define one 1.0e0 +#define zero 0.0e0 +#define half 0.5e0 +#define two 2.0e0 +#define onep5 1.5e0 +#define conv 1.0e-7 +#define tiny 1.0e-10 +static double alghdf,b,bb,bbcent,bcent,cent,d,dcent,dpnonc,dum1,dum2,e,ecent, + halfdf,lambda,lnomx,lnx,omx,pnonc2,s,scent,ss,sscent,t2,term,tt,twoi,x,xi, + xlnd,xlne; +static int ierr; +static unsigned long qrevs; +static double T1,T2,T3,T4,T5,T6,T7,T8,T9,T10; +/* + .. + .. Executable Statements .. +*/ +/* + Case pnonc essentially zero +*/ + if(fabs(*pnonc) <= tiny) { + cumt(t,df,cum,ccum); + return; + } + qrevs = *t < zero; + if(qrevs) { + tt = -*t; + dpnonc = -*pnonc; + } + else { + tt = *t; + dpnonc = *pnonc; + } + pnonc2 = dpnonc * dpnonc; + t2 = tt * tt; + if(fabs(tt) <= tiny) { + T1 = -*pnonc; + cumnor(&T1,cum,ccum); + return; + } + lambda = half * pnonc2; + x = *df / (*df + t2); + omx = one - x; + lnx = log(x); + lnomx = log(omx); + halfdf = half * *df; + alghdf = gamln(&halfdf); +/* + ******************** Case i = lambda +*/ + cent = fifidint(lambda); + if(cent < one) cent = one; +/* + Compute d=T(2i) in log space and offset by exp(-lambda) +*/ + T2 = cent + one; + xlnd = cent * log(lambda) - gamln(&T2) - lambda; + dcent = exp(xlnd); +/* + Compute e=t(2i+1) in log space offset by exp(-lambda) +*/ + T3 = cent + onep5; + xlne = (cent + half) * log(lambda) - gamln(&T3) - lambda; + ecent = exp(xlne); + if(dpnonc < zero) ecent = -ecent; +/* + Compute bcent=B(2*cent) +*/ + T4 = cent + half; + bratio(&halfdf,&T4,&x,&omx,&bcent,&dum1,&ierr); +/* + compute bbcent=B(2*cent+1) +*/ + T5 = cent + one; + bratio(&halfdf,&T5,&x,&omx,&bbcent,&dum2,&ierr); +/* + Case bcent and bbcent are essentially zero + Thus t is effectively infinite +*/ + if(bcent + bbcent < tiny) { + if(qrevs) { + *cum = zero; + *ccum = one; + } + else { + *cum = one; + *ccum = zero; + } + return; + } +/* + Case bcent and bbcent are essentially one + Thus t is effectively zero +*/ + if(dum1 + dum2 < tiny) { + T6 = -*pnonc; + cumnor(&T6,cum,ccum); + return; + } +/* + First term in ccum is D*B + E*BB +*/ + *ccum = dcent * bcent + ecent * bbcent; +/* + compute s(cent) = B(2*(cent+1)) - B(2*cent)) +*/ + T7 = halfdf + cent + half; + T8 = cent + onep5; + scent = gamln(&T7) - gamln(&T8) - alghdf + halfdf * lnx + (cent + half) * + lnomx; + scent = exp(scent); +/* + compute ss(cent) = B(2*cent+3) - B(2*cent+1) +*/ + T9 = halfdf + cent + one; + T10 = cent + two; + sscent = gamln(&T9) - gamln(&T10) - alghdf + halfdf * lnx + (cent + one) * + lnomx; + sscent = exp(sscent); +/* + ******************** Sum Forward +*/ + xi = cent + one; + twoi = two * xi; + d = dcent; + e = ecent; + b = bcent; + bb = bbcent; + s = scent; + ss = sscent; +S10: + b += s; + bb += ss; + d = lambda / xi * d; + e = lambda / (xi + half) * e; + term = d * b + e * bb; + *ccum += term; + s = s * omx * (*df + twoi - one) / (twoi + one); + ss = ss * omx * (*df + twoi) / (twoi + two); + xi += one; + twoi = two * xi; + if(fabs(term) > conv * *ccum) goto S10; +/* + ******************** Sum Backward +*/ + xi = cent; + twoi = two * xi; + d = dcent; + e = ecent; + b = bcent; + bb = bbcent; + s = scent * (one + twoi) / ((*df + twoi - one) * omx); + ss = sscent * (two + twoi) / ((*df + twoi) * omx); +S20: + b -= s; + bb -= ss; + d *= (xi / lambda); + e *= ((xi + half) / lambda); + term = d * b + e * bb; + *ccum += term; + xi -= one; + if(xi < half) goto S30; + twoi = two * xi; + s = s * (one + twoi) / ((*df + twoi - one) * omx); + ss = ss * (two + twoi) / ((*df + twoi) * omx); + if(fabs(term) > conv * *ccum) goto S20; +S30: + if(qrevs) { + *cum = half * *ccum; + *ccum = one - *cum; + } + else { + *ccum = half * *ccum; + *cum = one - *ccum; + } +/* + Due to roundoff error the answer may not lie between zero and one + Force it to do so +*/ + *cum = fifdmax1(fifdmin1(*cum,one),zero); + *ccum = fifdmax1(fifdmin1(*ccum,one),zero); + return; +#undef one +#undef zero +#undef half +#undef two +#undef onep5 +#undef conv +#undef tiny +} +double devlpl(double a[],int *n,double *x) +/* +********************************************************************** + + double devlpl(double a[],int *n,double *x) + Double precision EVALuate a PoLynomial at X + + + Function + + + returns + A(1) + A(2)*X + ... + A(N)*X**(N-1) + + + Arguments + + + A --> Array of coefficients of the polynomial. + A is DOUBLE PRECISION(N) + + N --> Length of A, also degree of polynomial - 1. + N is INTEGER + + X --> Point at which the polynomial is to be evaluated. + X is DOUBLE PRECISION + +********************************************************************** +*/ +{ +static double devlpl,term; +static int i; +/* + .. + .. Executable Statements .. +*/ + term = a[*n-1]; + for(i= *n-1-1; i>=0; i--) term = a[i]+term**x; + devlpl = term; + return devlpl; +} +double dinvnr(double *p,double *q) +/* +********************************************************************** + + double dinvnr(double *p,double *q) + Double precision NoRmal distribution INVerse + + + Function + + + Returns X such that CUMNOR(X) = P, i.e., the integral from - + infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P + + + Arguments + + + P --> The probability whose normal deviate is sought. + P is DOUBLE PRECISION + + Q --> 1-P + P is DOUBLE PRECISION + + + Method + + + The rational function on page 95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY , 1980 is used as a start + value for the Newton method of finding roots. + + + Note + + + If P or Q .lt. machine EPS returns +/- DINVNR(EPS) + +********************************************************************** +*/ +{ +#define maxit 100 +#define eps 1.0e-13 +#define r2pi 0.3989422804014326e0 +#define nhalf -0.5e0 +#define dennor(x) (r2pi*exp(nhalf*(x)*(x))) +static double dinvnr,strtx,xcur,cum,ccum,pp,dx; +static int i; +static unsigned long qporq; +/* + .. + .. Executable Statements .. +*/ +/* + FIND MINIMUM OF P AND Q +*/ + qporq = *p <= *q; + if(!qporq) goto S10; + pp = *p; + goto S20; +S10: + pp = *q; +S20: +/* + INITIALIZATION STEP +*/ + strtx = stvaln(&pp); + xcur = strtx; +/* + NEWTON INTERATIONS +*/ + for(i=1; i<=maxit; i++) { + cumnor(&xcur,&cum,&ccum); + dx = (cum-pp)/dennor(xcur); + xcur -= dx; + if(fabs(dx/xcur) < eps) goto S40; + } + dinvnr = strtx; +/* + IF WE GET HERE, NEWTON HAS FAILED +*/ + if(!qporq) dinvnr = -dinvnr; + return dinvnr; +S40: +/* + IF WE GET HERE, NEWTON HAS SUCCEDED +*/ + dinvnr = xcur; + if(!qporq) dinvnr = -dinvnr; + return dinvnr; +#undef maxit +#undef eps +#undef r2pi +#undef nhalf +#undef dennor +} +/* DEFINE DINVR */ +static void E0000(int IENTRY,int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi,double *zabsst, + double *zabsto,double *zbig,double *zrelst, + double *zrelto,double *zsmall,double *zstpmu) +{ +#define qxmon(zx,zy,zz) (int)((zx) <= (zy) && (zy) <= (zz)) +static double absstp,abstol,big,fbig,fsmall,relstp,reltol,small,step,stpmul,xhi, + xlb,xlo,xsave,xub,yy; +static int i99999; +static unsigned long qbdd,qcond,qdum1,qdum2,qincr,qlim,qok,qup; + switch(IENTRY){case 0: goto DINVR; case 1: goto DSTINV;} +DINVR: + if(*status > 0) goto S310; + qcond = !qxmon(small,*x,big); + if(qcond) ftnstop((char *) " SMALL, X, BIG not monotone in INVR"); + xsave = *x; +/* + See that SMALL and BIG bound the zero and set QINCR +*/ + *x = small; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 1; + goto S300; +S10: + fsmall = *fx; + *x = big; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 2; + goto S300; +S20: + fbig = *fx; + qincr = fbig > fsmall; + if(!qincr) goto S50; + if(fsmall <= 0.0e0) goto S30; + *status = -1; + *qleft = *qhi = 1; + return; +S30: + if(fbig >= 0.0e0) goto S40; + *status = -1; + *qleft = *qhi = 0; + return; +S40: + goto S80; +S50: + if(fsmall >= 0.0e0) goto S60; + *status = -1; + *qleft = 1; + *qhi = 0; + return; +S60: + if(fbig <= 0.0e0) goto S70; + *status = -1; + *qleft = 0; + *qhi = 1; + return; +S80: +S70: + *x = xsave; + step = fifdmax1(absstp,relstp*fabs(*x)); +/* + YY = F(X) - Y + GET-FUNCTION-VALUE +*/ + i99999 = 3; + goto S300; +S90: + yy = *fx; + if(!(yy == 0.0e0)) goto S100; + *status = 0; + qok = 1; + return; +S100: + qup = (qincr && yy < 0.0e0) || (!qincr && yy > 0.0e0); +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + HANDLE CASE IN WHICH WE MUST STEP HIGHER +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + if(!qup) goto S170; + xlb = xsave; + xub = fifdmin1(xlb+step,big); + goto S120; +S110: + if(qcond) goto S150; +S120: +/* + YY = F(XUB) - Y +*/ + *x = xub; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 4; + goto S300; +S130: + yy = *fx; + qbdd = (qincr && yy >= 0.0e0) || (!qincr && yy <= 0.0e0); + qlim = xub >= big; + qcond = qbdd || qlim; + if(qcond) goto S140; + step = stpmul*step; + xlb = xub; + xub = fifdmin1(xlb+step,big); +S140: + goto S110; +S150: + if(!(qlim && !qbdd)) goto S160; + *status = -1; + *qleft = 0; + *qhi = !qincr; + *x = big; + return; +S160: + goto S240; +S170: +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + HANDLE CASE IN WHICH WE MUST STEP LOWER +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + xub = xsave; + xlb = fifdmax1(xub-step,small); + goto S190; +S180: + if(qcond) goto S220; +S190: +/* + YY = F(XLB) - Y +*/ + *x = xlb; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 5; + goto S300; +S200: + yy = *fx; + qbdd = (qincr && yy <= 0.0e0) || (!qincr && yy >= 0.0e0); + qlim = xlb <= small; + qcond = qbdd || qlim; + if(qcond) goto S210; + step = stpmul*step; + xub = xlb; + xlb = fifdmax1(xub-step,small); +S210: + goto S180; +S220: + if(!(qlim && !qbdd)) goto S230; + *status = -1; + *qleft = 1; + *qhi = qincr; + *x = small; + return; +S240: +S230: + dstzr(&xlb,&xub,&abstol,&reltol); +/* +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + IF WE REACH HERE, XLB AND XUB BOUND THE ZERO OF F. +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +*/ + *status = 0; + goto S260; +S250: + if(!(*status == 1)) goto S290; +S260: + dzror(status,x,fx,&xlo,&xhi,&qdum1,&qdum2); + if(!(*status == 1)) goto S280; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 6; + goto S300; +S280: +S270: + goto S250; +S290: + *x = xlo; + *status = 0; + return; +DSTINV: + small = *zsmall; + big = *zbig; + absstp = *zabsst; + relstp = *zrelst; + stpmul = *zstpmu; + abstol = *zabsto; + reltol = *zrelto; + return; +S300: +/* + TO GET-FUNCTION-VALUE +*/ + *status = 1; + return; +S310: + switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S90;case + 4: goto S130;case 5: goto S200;case 6: goto S270;default: break;} +#undef qxmon +} +void dinvr(int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi) +/* +********************************************************************** + + void dinvr(int *status,double *x,double *fx, + unsigned long *qleft,unsigned long *qhi) + + Double precision + bounds the zero of the function and invokes zror + Reverse Communication + + + Function + + + Bounds the function and invokes ZROR to perform the zero + finding. STINVR must have been called before this routine + in order to set its parameters. + + + Arguments + + + STATUS <--> At the beginning of a zero finding problem, STATUS + should be set to 0 and INVR invoked. (The value + of parameters other than X will be ignored on this cal + + When INVR needs the function evaluated, it will set + STATUS to 1 and return. The value of the function + should be set in FX and INVR again called without + changing any of its other parameters. + + When INVR has finished without error, it will return + with STATUS 0. In that case X is approximately a root + of F(X). + + If INVR cannot bound the function, it returns status + -1 and sets QLEFT and QHI. + INTEGER STATUS + + X <-- The value of X at which F(X) is to be evaluated. + DOUBLE PRECISION X + + FX --> The value of F(X) calculated when INVR returns with + STATUS = 1. + DOUBLE PRECISION FX + + QLEFT <-- Defined only if QMFINV returns .FALSE. In that + case it is .TRUE. If the stepping search terminated + unsucessfully at SMALL. If it is .FALSE. the search + terminated unsucessfully at BIG. + QLEFT is LOGICAL + + QHI <-- Defined only if QMFINV returns .FALSE. In that + case it is .TRUE. if F(X) .GT. Y at the termination + of the search and .FALSE. if F(X) .LT. Y at the + termination of the search. + QHI is LOGICAL + +********************************************************************** +*/ +{ + E0000(0,status,x,fx,qleft,qhi,NULL,NULL,NULL,NULL,NULL,NULL,NULL); +} +void dstinv(double *zsmall,double *zbig,double *zabsst, + double *zrelst,double *zstpmu,double *zabsto, + double *zrelto) +/* +********************************************************************** + void dstinv(double *zsmall,double *zbig,double *zabsst, + double *zrelst,double *zstpmu,double *zabsto, + double *zrelto) + + Double Precision - SeT INverse finder - Reverse Communication + Function + Concise Description - Given a monotone function F finds X + such that F(X) = Y. Uses Reverse communication -- see invr. + This routine sets quantities needed by INVR. + More Precise Description of INVR - + F must be a monotone function, the results of QMFINV are + otherwise undefined. QINCR must be .TRUE. if F is non- + decreasing and .FALSE. if F is non-increasing. + QMFINV will return .TRUE. if and only if F(SMALL) and + F(BIG) bracket Y, i. e., + QINCR is .TRUE. and F(SMALL).LE.Y.LE.F(BIG) or + QINCR is .FALSE. and F(BIG).LE.Y.LE.F(SMALL) + if QMFINV returns .TRUE., then the X returned satisfies + the following condition. let + TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) + then if QINCR is .TRUE., + F(X-TOL(X)) .LE. Y .LE. F(X+TOL(X)) + and if QINCR is .FALSE. + F(X-TOL(X)) .GE. Y .GE. F(X+TOL(X)) + Arguments + SMALL --> The left endpoint of the interval to be + searched for a solution. + SMALL is DOUBLE PRECISION + BIG --> The right endpoint of the interval to be + searched for a solution. + BIG is DOUBLE PRECISION + ABSSTP, RELSTP --> The initial step size in the search + is MAX(ABSSTP,RELSTP*ABS(X)). See algorithm. + ABSSTP is DOUBLE PRECISION + RELSTP is DOUBLE PRECISION + STPMUL --> When a step doesn't bound the zero, the step + size is multiplied by STPMUL and another step + taken. A popular value is 2.0 + DOUBLE PRECISION STPMUL + ABSTOL, RELTOL --> Two numbers that determine the accuracy + of the solution. See function for a precise definition. + ABSTOL is DOUBLE PRECISION + RELTOL is DOUBLE PRECISION + Method + Compares F(X) with Y for the input value of X then uses QINCR + to determine whether to step left or right to bound the + desired x. the initial step size is + MAX(ABSSTP,RELSTP*ABS(S)) for the input value of X. + Iteratively steps right or left until it bounds X. + At each step which doesn't bound X, the step size is doubled. + The routine is careful never to step beyond SMALL or BIG. If + it hasn't bounded X at SMALL or BIG, QMFINV returns .FALSE. + after setting QLEFT and QHI. + If X is successfully bounded then Algorithm R of the paper + 'Two Efficient Algorithms with Guaranteed Convergence for + Finding a Zero of a Function' by J. C. P. Bus and + T. J. Dekker in ACM Transactions on Mathematical + Software, Volume 1, No. 4 page 330 (DEC. '75) is employed + to find the zero of the function F(X)-Y. This is routine + QRZERO. +********************************************************************** +*/ +{ + E0000(1,NULL,NULL,NULL,NULL,NULL,zabsst,zabsto,zbig,zrelst,zrelto,zsmall, + zstpmu); +} +double dt1(double *p,double *q,double *df) +/* +********************************************************************** + + double dt1(double *p,double *q,double *df) + Double precision Initalize Approximation to + INVerse of the cumulative T distribution + + + Function + + + Returns the inverse of the T distribution function, i.e., + the integral from 0 to INVT of the T density is P. This is an + initial approximation + + + Arguments + + + P --> The p-value whose inverse from the T distribution is + desired. + P is DOUBLE PRECISION + + Q --> 1-P. + Q is DOUBLE PRECISION + + DF --> Degrees of freedom of the T distribution. + DF is DOUBLE PRECISION + +********************************************************************** +*/ +{ +static double coef[4][5] = { + {1.0e0,1.0e0,0.0e0,0.0e0,0.0e0}, + {3.0e0,16.0e0,5.0e0,0.0e0,0.0e0}, + {-15.0e0,17.0e0,19.0e0,3.0e0,0.0e0}, + {-945.0e0,-1920.0e0,1482.0e0,776.0e0,79.0e0} +}; +static double denom[4] = { + 4.0e0,96.0e0,384.0e0,92160.0e0 +}; +static int ideg[4] = { + 2,3,4,5 +}; +static double dt1,denpow,sum,term,x,xp,xx; +static int i; +/* + .. + .. Executable Statements .. +*/ + x = fabs(dinvnr(p,q)); + xx = x*x; + sum = x; + denpow = 1.0e0; + for(i=0; i<4; i++) { + term = devlpl(&coef[i][0],&ideg[i],&xx)*x; + denpow *= *df; + sum += (term/(denpow*denom[i])); + } + if(!(*p >= 0.5e0)) goto S20; + xp = sum; + goto S30; +S20: + xp = -sum; +S30: + dt1 = xp; + return dt1; +} +/* DEFINE DZROR */ +static void E0001(int IENTRY,int *status,double *x,double *fx, + double *xlo,double *xhi,unsigned long *qleft, + unsigned long *qhi,double *zabstl,double *zreltl, + double *zxhi,double *zxlo) +{ +#define ftol(zx) (0.5e0*fifdmax1(abstol,reltol*fabs((zx)))) +static double a,abstol,b,c,d,fa,fb,fc,fd,fda,fdb,m,mb,p,q,reltol,tol,w,xxhi,xxlo; +static int ext,i99999; +static unsigned long first,qrzero; + switch(IENTRY){case 0: goto DZROR; case 1: goto DSTZR;} +DZROR: + if(*status > 0) goto S280; + *xlo = xxlo; + *xhi = xxhi; + b = *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 1; + goto S270; +S10: + fb = *fx; + *xlo = *xhi; + a = *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 2; + goto S270; +S20: +/* + Check that F(ZXLO) < 0 < F(ZXHI) or + F(ZXLO) > 0 > F(ZXHI) +*/ + if(!(fb < 0.0e0)) goto S40; + if(!(*fx < 0.0e0)) goto S30; + *status = -1; + *qleft = *fx < fb; + *qhi = 0; + return; +S40: +S30: + if(!(fb > 0.0e0)) goto S60; + if(!(*fx > 0.0e0)) goto S50; + *status = -1; + *qleft = *fx > fb; + *qhi = 1; + return; +S60: +S50: + fa = *fx; + first = 1; +S70: + c = a; + fc = fa; + ext = 0; +S80: + if(!(fabs(fc) < fabs(fb))) goto S100; + if(!(c != a)) goto S90; + d = a; + fd = fa; +S90: + a = b; + fa = fb; + *xlo = c; + b = *xlo; + fb = fc; + c = a; + fc = fa; +S100: + tol = ftol(*xlo); + m = (c+b)*.5e0; + mb = m-b; + if(!(fabs(mb) > tol)) goto S240; + if(!(ext > 3)) goto S110; + w = mb; + goto S190; +S110: + tol = fifdsign(tol,mb); + p = (b-a)*fb; + if(!first) goto S120; + q = fa-fb; + first = 0; + goto S130; +S120: + fdb = (fd-fb)/(d-b); + fda = (fd-fa)/(d-a); + p = fda*p; + q = fdb*fa-fda*fb; +S130: + if(!(p < 0.0e0)) goto S140; + p = -p; + q = -q; +S140: + if(ext == 3) p *= 2.0e0; + if(!(p*1.0e0 == 0.0e0 || p <= q*tol)) goto S150; + w = tol; + goto S180; +S150: + if(!(p < mb*q)) goto S160; + w = p/q; + goto S170; +S160: + w = mb; +S190: +S180: +S170: + d = a; + fd = fa; + a = b; + fa = fb; + b += w; + *xlo = b; + *x = *xlo; +/* + GET-FUNCTION-VALUE +*/ + i99999 = 3; + goto S270; +S200: + fb = *fx; + if(!(fc*fb >= 0.0e0)) goto S210; + goto S70; +S210: + if(!(w == mb)) goto S220; + ext = 0; + goto S230; +S220: + ext += 1; +S230: + goto S80; +S240: + *xhi = c; + qrzero = (fc >= 0.0e0 && fb <= 0.0e0) || (fc < 0.0e0 && fb >= 0.0e0); + if(!qrzero) goto S250; + *status = 0; + goto S260; +S250: + *status = -1; +S260: + return; +DSTZR: + xxlo = *zxlo; + xxhi = *zxhi; + abstol = *zabstl; + reltol = *zreltl; + return; +S270: +/* + TO GET-FUNCTION-VALUE +*/ + *status = 1; + return; +S280: + switch((int)i99999){case 1: goto S10;case 2: goto S20;case 3: goto S200; + default: break;} +#undef ftol +} +void dzror(int *status,double *x,double *fx,double *xlo, + double *xhi,unsigned long *qleft,unsigned long *qhi) +/* +********************************************************************** + + void dzror(int *status,double *x,double *fx,double *xlo, + double *xhi,unsigned long *qleft,unsigned long *qhi) + + Double precision ZeRo of a function -- Reverse Communication + + + Function + + + Performs the zero finding. STZROR must have been called before + this routine in order to set its parameters. + + + Arguments + + + STATUS <--> At the beginning of a zero finding problem, STATUS + should be set to 0 and ZROR invoked. (The value + of other parameters will be ignored on this call.) + + When ZROR needs the function evaluated, it will set + STATUS to 1 and return. The value of the function + should be set in FX and ZROR again called without + changing any of its other parameters. + + When ZROR has finished without error, it will return + with STATUS 0. In that case (XLO,XHI) bound the answe + + If ZROR finds an error (which implies that F(XLO)-Y an + F(XHI)-Y have the same sign, it returns STATUS -1. In + this case, XLO and XHI are undefined. + INTEGER STATUS + + X <-- The value of X at which F(X) is to be evaluated. + DOUBLE PRECISION X + + FX --> The value of F(X) calculated when ZROR returns with + STATUS = 1. + DOUBLE PRECISION FX + + XLO <-- When ZROR returns with STATUS = 0, XLO bounds the + inverval in X containing the solution below. + DOUBLE PRECISION XLO + + XHI <-- When ZROR returns with STATUS = 0, XHI bounds the + inverval in X containing the solution above. + DOUBLE PRECISION XHI + + QLEFT <-- .TRUE. if the stepping search terminated unsucessfully + at XLO. If it is .FALSE. the search terminated + unsucessfully at XHI. + QLEFT is LOGICAL + + QHI <-- .TRUE. if F(X) .GT. Y at the termination of the + search and .FALSE. if F(X) .LT. Y at the + termination of the search. + QHI is LOGICAL + +********************************************************************** +*/ +{ + E0001(0,status,x,fx,xlo,xhi,qleft,qhi,NULL,NULL,NULL,NULL); +} +void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) +/* +********************************************************************** + void dstzr(double *zxlo,double *zxhi,double *zabstl,double *zreltl) + Double precision SeT ZeRo finder - Reverse communication version + Function + Sets quantities needed by ZROR. The function of ZROR + and the quantities set is given here. + Concise Description - Given a function F + find XLO such that F(XLO) = 0. + More Precise Description - + Input condition. F is a double precision function of a single + double precision argument and XLO and XHI are such that + F(XLO)*F(XHI) .LE. 0.0 + If the input condition is met, QRZERO returns .TRUE. + and output values of XLO and XHI satisfy the following + F(XLO)*F(XHI) .LE. 0. + ABS(F(XLO) .LE. ABS(F(XHI) + ABS(XLO-XHI) .LE. TOL(X) + where + TOL(X) = MAX(ABSTOL,RELTOL*ABS(X)) + If this algorithm does not find XLO and XHI satisfying + these conditions then QRZERO returns .FALSE. This + implies that the input condition was not met. + Arguments + XLO --> The left endpoint of the interval to be + searched for a solution. + XLO is DOUBLE PRECISION + XHI --> The right endpoint of the interval to be + for a solution. + XHI is DOUBLE PRECISION + ABSTOL, RELTOL --> Two numbers that determine the accuracy + of the solution. See function for a + precise definition. + ABSTOL is DOUBLE PRECISION + RELTOL is DOUBLE PRECISION + Method + Algorithm R of the paper 'Two Efficient Algorithms with + Guaranteed Convergence for Finding a Zero of a Function' + by J. C. P. Bus and T. J. Dekker in ACM Transactions on + Mathematical Software, Volume 1, no. 4 page 330 + (Dec. '75) is employed to find the zero of F(X)-Y. +********************************************************************** +*/ +{ + E0001(1,NULL,NULL,NULL,NULL,NULL,NULL,NULL,zabstl,zreltl,zxhi,zxlo); +} +double erf1(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE REAL ERROR FUNCTION +----------------------------------------------------------------------- +*/ +{ +static double c = .564189583547756e0; +static double a[5] = { + .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, + .479137145607681e-01,.128379167095513e+00 +}; +static double b[3] = { + .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 +}; +static double p[8] = { + -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, + 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, + 4.51918953711873e+02,3.00459261020162e+02 +}; +static double q[8] = { + 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, + 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, + 7.90950925327898e+02,3.00459260956983e+02 +}; +static double r[5] = { + 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, + 4.65807828718470e+00,2.82094791773523e-01 +}; +static double s[4] = { + 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, + 1.80124575948747e+01 +}; +static double erf1,ax,bot,t,top,x2; +/* + .. + .. Executable Statements .. +*/ + ax = fabs(*x); + if(ax > 0.5e0) goto S10; + t = *x**x; + top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; + bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; + erf1 = *x*(top/bot); + return erf1; +S10: + if(ax > 4.0e0) goto S20; + top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ + 7]; + bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ + 7]; + erf1 = 0.5e0+(0.5e0-exp(-(*x**x))*top/bot); + if(*x < 0.0e0) erf1 = -erf1; + return erf1; +S20: + if(ax >= 5.8e0) goto S30; + x2 = *x**x; + t = 1.0e0/x2; + top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; + bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; + erf1 = (c-top/(x2*bot))/ax; + erf1 = 0.5e0+(0.5e0-exp(-x2)*erf1); + if(*x < 0.0e0) erf1 = -erf1; + return erf1; +S30: + erf1 = fifdsign(1.0e0,*x); + return erf1; +} +double erfc1(int *ind,double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE COMPLEMENTARY ERROR FUNCTION + + ERFC1(IND,X) = ERFC(X) IF IND = 0 + ERFC1(IND,X) = EXP(X*X)*ERFC(X) OTHERWISE +----------------------------------------------------------------------- +*/ +{ +static double c = .564189583547756e0; +static double a[5] = { + .771058495001320e-04,-.133733772997339e-02,.323076579225834e-01, + .479137145607681e-01,.128379167095513e+00 +}; +static double b[3] = { + .301048631703895e-02,.538971687740286e-01,.375795757275549e+00 +}; +static double p[8] = { + -1.36864857382717e-07,5.64195517478974e-01,7.21175825088309e+00, + 4.31622272220567e+01,1.52989285046940e+02,3.39320816734344e+02, + 4.51918953711873e+02,3.00459261020162e+02 +}; +static double q[8] = { + 1.00000000000000e+00,1.27827273196294e+01,7.70001529352295e+01, + 2.77585444743988e+02,6.38980264465631e+02,9.31354094850610e+02, + 7.90950925327898e+02,3.00459260956983e+02 +}; +static double r[5] = { + 2.10144126479064e+00,2.62370141675169e+01,2.13688200555087e+01, + 4.65807828718470e+00,2.82094791773523e-01 +}; +static double s[4] = { + 9.41537750555460e+01,1.87114811799590e+02,9.90191814623914e+01, + 1.80124575948747e+01 +}; +static int K1 = 1; +static double erfc1,ax,bot,e,t,top,w; +/* + .. + .. Executable Statements .. +*/ +/* + ABS(X) .LE. 0.5 +*/ + ax = fabs(*x); + if(ax > 0.5e0) goto S10; + t = *x**x; + top = (((a[0]*t+a[1])*t+a[2])*t+a[3])*t+a[4]+1.0e0; + bot = ((b[0]*t+b[1])*t+b[2])*t+1.0e0; + erfc1 = 0.5e0+(0.5e0-*x*(top/bot)); + if(*ind != 0) erfc1 = exp(t)*erfc1; + return erfc1; +S10: +/* + 0.5 .LT. ABS(X) .LE. 4 +*/ + if(ax > 4.0e0) goto S20; + top = ((((((p[0]*ax+p[1])*ax+p[2])*ax+p[3])*ax+p[4])*ax+p[5])*ax+p[6])*ax+p[ + 7]; + bot = ((((((q[0]*ax+q[1])*ax+q[2])*ax+q[3])*ax+q[4])*ax+q[5])*ax+q[6])*ax+q[ + 7]; + erfc1 = top/bot; + goto S40; +S20: +/* + ABS(X) .GT. 4 +*/ + if(*x <= -5.6e0) goto S60; + if(*ind != 0) goto S30; + if(*x > 100.0e0) goto S70; + if(*x**x > -exparg(&K1)) goto S70; +S30: + t = pow(1.0e0/ *x,2.0); + top = (((r[0]*t+r[1])*t+r[2])*t+r[3])*t+r[4]; + bot = (((s[0]*t+s[1])*t+s[2])*t+s[3])*t+1.0e0; + erfc1 = (c-t*top/bot)/ax; +S40: +/* + FINAL ASSEMBLY +*/ + if(*ind == 0) goto S50; + if(*x < 0.0e0) erfc1 = 2.0e0*exp(*x**x)-erfc1; + return erfc1; +S50: + w = *x**x; + t = w; + e = w-t; + erfc1 = (0.5e0+(0.5e0-e))*exp(-t)*erfc1; + if(*x < 0.0e0) erfc1 = 2.0e0-erfc1; + return erfc1; +S60: +/* + LIMIT VALUE FOR LARGE NEGATIVE X +*/ + erfc1 = 2.0e0; + if(*ind != 0) erfc1 = 2.0e0*exp(*x**x); + return erfc1; +S70: +/* + LIMIT VALUE FOR LARGE POSITIVE X + WHEN IND = 0 +*/ + erfc1 = 0.0e0; + return erfc1; +} +double esum(int *mu,double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF EXP(MU + X) +----------------------------------------------------------------------- +*/ +{ +static double esum,w; +/* + .. + .. Executable Statements .. +*/ + if(*x > 0.0e0) goto S10; + if(*mu < 0) goto S20; + w = (double)*mu+*x; + if(w > 0.0e0) goto S20; + esum = exp(w); + return esum; +S10: + if(*mu > 0) goto S20; + w = (double)*mu+*x; + if(w < 0.0e0) goto S20; + esum = exp(w); + return esum; +S20: + w = *mu; + esum = exp(w)*exp(*x); + return esum; +} +double exparg(int *l) +/* +-------------------------------------------------------------------- + IF L = 0 THEN EXPARG(L) = THE LARGEST POSITIVE W FOR WHICH + EXP(W) CAN BE COMPUTED. + + IF L IS NONZERO THEN EXPARG(L) = THE LARGEST NEGATIVE W FOR + WHICH THE COMPUTED VALUE OF EXP(W) IS NONZERO. + + NOTE... ONLY AN APPROXIMATE VALUE FOR EXPARG(L) IS NEEDED. +-------------------------------------------------------------------- +*/ +{ +static int K1 = 4; +static int K2 = 9; +static int K3 = 10; +static double exparg,lnb; +static int b,m; +/* + .. + .. Executable Statements .. +*/ + b = ipmpar(&K1); + if(b != 2) goto S10; + lnb = .69314718055995e0; + goto S40; +S10: + if(b != 8) goto S20; + lnb = 2.0794415416798e0; + goto S40; +S20: + if(b != 16) goto S30; + lnb = 2.7725887222398e0; + goto S40; +S30: + lnb = log((double)b); +S40: + if(*l == 0) goto S50; + m = ipmpar(&K2)-1; + exparg = 0.99999e0*((double)m*lnb); + return exparg; +S50: + m = ipmpar(&K3); + exparg = 0.99999e0*((double)m*lnb); + return exparg; +} +double fpser(double *a,double *b,double *x,double *eps) +/* +----------------------------------------------------------------------- + + EVALUATION OF I (A,B) + X + + FOR B .LT. MIN(EPS,EPS*A) AND X .LE. 0.5. + +----------------------------------------------------------------------- + + SET FPSER = X**A +*/ +{ +static int K1 = 1; +static double fpser,an,c,s,t,tol; +/* + .. + .. Executable Statements .. +*/ + fpser = 1.0e0; + if(*a <= 1.e-3**eps) goto S10; + fpser = 0.0e0; + t = *a*log(*x); + if(t < exparg(&K1)) return fpser; + fpser = exp(t); +S10: +/* + NOTE THAT 1/B(A,B) = B +*/ + fpser = *b/ *a*fpser; + tol = *eps/ *a; + an = *a+1.0e0; + t = *x; + s = t/an; +S20: + an += 1.0e0; + t = *x*t; + c = t/an; + s += c; + if(fabs(c) > tol) goto S20; + fpser *= (1.0e0+*a*s); + return fpser; +} +double gam1(double *a) +/* + ------------------------------------------------------------------ + COMPUTATION OF 1/GAMMA(A+1) - 1 FOR -0.5 .LE. A .LE. 1.5 + ------------------------------------------------------------------ +*/ +{ +static double s1 = .273076135303957e+00; +static double s2 = .559398236957378e-01; +static double p[7] = { + .577215664901533e+00,-.409078193005776e+00,-.230975380857675e+00, + .597275330452234e-01,.766968181649490e-02,-.514889771323592e-02, + .589597428611429e-03 +}; +static double q[5] = { + .100000000000000e+01,.427569613095214e+00,.158451672430138e+00, + .261132021441447e-01,.423244297896961e-02 +}; +static double r[9] = { + -.422784335098468e+00,-.771330383816272e+00,-.244757765222226e+00, + .118378989872749e+00,.930357293360349e-03,-.118290993445146e-01, + .223047661158249e-02,.266505979058923e-03,-.132674909766242e-03 +}; +static double gam1,bot,d,t,top,w,T1; +/* + .. + .. Executable Statements .. +*/ + t = *a; + d = *a-0.5e0; + if(d > 0.0e0) t = d-0.5e0; + T1 = t; + if(T1 < 0) goto S40; + else if(T1 == 0) goto S10; + else goto S20; +S10: + gam1 = 0.0e0; + return gam1; +S20: + top = (((((p[6]*t+p[5])*t+p[4])*t+p[3])*t+p[2])*t+p[1])*t+p[0]; + bot = (((q[4]*t+q[3])*t+q[2])*t+q[1])*t+1.0e0; + w = top/bot; + if(d > 0.0e0) goto S30; + gam1 = *a*w; + return gam1; +S30: + gam1 = t/ *a*(w-0.5e0-0.5e0); + return gam1; +S40: + top = (((((((r[8]*t+r[7])*t+r[6])*t+r[5])*t+r[4])*t+r[3])*t+r[2])*t+r[1])*t+ + r[0]; + bot = (s2*t+s1)*t+1.0e0; + w = top/bot; + if(d > 0.0e0) goto S50; + gam1 = *a*(w+0.5e0+0.5e0); + return gam1; +S50: + gam1 = t*w/ *a; + return gam1; +} +void gaminv(double *a,double *x,double *x0,double *p,double *q, + int *ierr) +/* + ---------------------------------------------------------------------- + INVERSE INCOMPLETE GAMMA RATIO FUNCTION + + GIVEN POSITIVE A, AND NONEGATIVE P AND Q WHERE P + Q = 1. + THEN X IS COMPUTED WHERE P(A,X) = P AND Q(A,X) = Q. SCHRODER + ITERATION IS EMPLOYED. THE ROUTINE ATTEMPTS TO COMPUTE X + TO 10 SIGNIFICANT DIGITS IF THIS IS POSSIBLE FOR THE + PARTICULAR COMPUTER ARITHMETIC BEING USED. + + ------------ + + X IS A VARIABLE. IF P = 0 THEN X IS ASSIGNED THE VALUE 0, + AND IF Q = 0 THEN X IS SET TO THE LARGEST FLOATING POINT + NUMBER AVAILABLE. OTHERWISE, GAMINV ATTEMPTS TO OBTAIN + A SOLUTION FOR P(A,X) = P AND Q(A,X) = Q. IF THE ROUTINE + IS SUCCESSFUL THEN THE SOLUTION IS STORED IN X. + + X0 IS AN OPTIONAL INITIAL APPROXIMATION FOR X. IF THE USER + DOES NOT WISH TO SUPPLY AN INITIAL APPROXIMATION, THEN SET + X0 .LE. 0. + + IERR IS A VARIABLE THAT REPORTS THE STATUS OF THE RESULTS. + WHEN THE ROUTINE TERMINATES, IERR HAS ONE OF THE FOLLOWING + VALUES ... + + IERR = 0 THE SOLUTION WAS OBTAINED. ITERATION WAS + NOT USED. + IERR.GT.0 THE SOLUTION WAS OBTAINED. IERR ITERATIONS + WERE PERFORMED. + IERR = -2 (INPUT ERROR) A .LE. 0 + IERR = -3 NO SOLUTION WAS OBTAINED. THE RATIO Q/A + IS TOO LARGE. + IERR = -4 (INPUT ERROR) P + Q .NE. 1 + IERR = -6 20 ITERATIONS WERE PERFORMED. THE MOST + RECENT VALUE OBTAINED FOR X IS GIVEN. + THIS CANNOT OCCUR IF X0 .LE. 0. + IERR = -7 ITERATION FAILED. NO VALUE IS GIVEN FOR X. + THIS MAY OCCUR WHEN X IS APPROXIMATELY 0. + IERR = -8 A VALUE FOR X HAS BEEN OBTAINED, BUT THE + ROUTINE IS NOT CERTAIN OF ITS ACCURACY. + ITERATION CANNOT BE PERFORMED IN THIS + CASE. IF X0 .LE. 0, THIS CAN OCCUR ONLY + WHEN P OR Q IS APPROXIMATELY 0. IF X0 IS + POSITIVE THEN THIS CAN OCCUR WHEN A IS + EXCEEDINGLY CLOSE TO X AND A IS EXTREMELY + LARGE (SAY A .GE. 1.E20). + ---------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA + ------------------- +*/ +{ +static double a0 = 3.31125922108741e0; +static double a1 = 11.6616720288968e0; +static double a2 = 4.28342155967104e0; +static double a3 = .213623493715853e0; +static double b1 = 6.61053765625462e0; +static double b2 = 6.40691597760039e0; +static double b3 = 1.27364489782223e0; +static double b4 = .036117081018842e0; +static double c = .577215664901533e0; +static double ln10 = 2.302585e0; +static double tol = 1.e-5; +static double amin[2] = { + 500.0e0,100.0e0 +}; +static double bmin[2] = { + 1.e-28,1.e-13 +}; +static double dmin[2] = { + 1.e-06,1.e-04 +}; +static double emin[2] = { + 2.e-03,6.e-03 +}; +static double eps0[2] = { + 1.e-10,1.e-08 +}; +static int K1 = 1; +static int K2 = 2; +static int K3 = 3; +static int K8 = 0; +static double am1,amax,ap1,ap2,ap3,apn,b,c1,c2,c3,c4,c5,d,e,e2,eps,g,h,pn,qg,qn, + r,rta,s,s2,sum,t,u,w,xmax,xmin,xn,y,z; +static int iop; +static double T4,T5,T6,T7,T9; +/* + .. + .. Executable Statements .. +*/ +/* + ****** E, XMIN, AND XMAX ARE MACHINE DEPENDENT CONSTANTS. + E IS THE SMALLEST NUMBER FOR WHICH 1.0 + E .GT. 1.0. + XMIN IS THE SMALLEST POSITIVE NUMBER AND XMAX IS THE + LARGEST POSITIVE NUMBER. +*/ + e = spmpar(&K1); + xmin = spmpar(&K2); + xmax = spmpar(&K3); + *x = 0.0e0; + if(*a <= 0.0e0) goto S300; + t = *p+*q-1.e0; + if(fabs(t) > e) goto S320; + *ierr = 0; + if(*p == 0.0e0) return; + if(*q == 0.0e0) goto S270; + if(*a == 1.0e0) goto S280; + e2 = 2.0e0*e; + amax = 0.4e-10/(e*e); + iop = 1; + if(e > 1.e-10) iop = 2; + eps = eps0[iop-1]; + xn = *x0; + if(*x0 > 0.0e0) goto S160; +/* + SELECTION OF THE INITIAL APPROXIMATION XN OF X + WHEN A .LT. 1 +*/ + if(*a > 1.0e0) goto S80; + T4 = *a+1.0e0; + g = Xgamm(&T4); + qg = *q*g; + if(qg == 0.0e0) goto S360; + b = qg/ *a; + if(qg > 0.6e0**a) goto S40; + if(*a >= 0.30e0 || b < 0.35e0) goto S10; + t = exp(-(b+c)); + u = t*exp(t); + xn = t*exp(u); + goto S160; +S10: + if(b >= 0.45e0) goto S40; + if(b == 0.0e0) goto S360; + y = -log(b); + s = 0.5e0+(0.5e0-*a); + z = log(y); + t = y-s*z; + if(b < 0.15e0) goto S20; + xn = y-s*log(t)-log(1.0e0+s/(t+1.0e0)); + goto S220; +S20: + if(b <= 0.01e0) goto S30; + u = ((t+2.0e0*(3.0e0-*a))*t+(2.0e0-*a)*(3.0e0-*a))/((t+(5.0e0-*a))*t+2.0e0); + xn = y-s*log(t)-log(u); + goto S220; +S30: + c1 = -(s*z); + c2 = -(s*(1.0e0+c1)); + c3 = s*((0.5e0*c1+(2.0e0-*a))*c1+(2.5e0-1.5e0**a)); + c4 = -(s*(((c1/3.0e0+(2.5e0-1.5e0**a))*c1+((*a-6.0e0)**a+7.0e0))*c1+( + (11.0e0**a-46.0)**a+47.0e0)/6.0e0)); + c5 = -(s*((((-(c1/4.0e0)+(11.0e0**a-17.0e0)/6.0e0)*c1+((-(3.0e0**a)+13.0e0)* + *a-13.0e0))*c1+0.5e0*(((2.0e0**a-25.0e0)**a+72.0e0)**a-61.0e0))*c1+(( + (25.0e0**a-195.0e0)**a+477.0e0)**a-379.0e0)/12.0e0)); + xn = (((c5/y+c4)/y+c3)/y+c2)/y+c1+y; + if(*a > 1.0e0) goto S220; + if(b > bmin[iop-1]) goto S220; + *x = xn; + return; +S40: + if(b**q > 1.e-8) goto S50; + xn = exp(-(*q/ *a+c)); + goto S70; +S50: + if(*p <= 0.9e0) goto S60; + T5 = -*q; + xn = exp((alnrel(&T5)+gamln1(a))/ *a); + goto S70; +S60: + xn = exp(log(*p*g)/ *a); +S70: + if(xn == 0.0e0) goto S310; + t = 0.5e0+(0.5e0-xn/(*a+1.0e0)); + xn /= t; + goto S160; +S80: +/* + SELECTION OF THE INITIAL APPROXIMATION XN OF X + WHEN A .GT. 1 +*/ + if(*q <= 0.5e0) goto S90; + w = log(*p); + goto S100; +S90: + w = log(*q); +S100: + t = sqrt(-(2.0e0*w)); + s = t-(((a3*t+a2)*t+a1)*t+a0)/((((b4*t+b3)*t+b2)*t+b1)*t+1.0e0); + if(*q > 0.5e0) s = -s; + rta = sqrt(*a); + s2 = s*s; + xn = *a+s*rta+(s2-1.0e0)/3.0e0+s*(s2-7.0e0)/(36.0e0*rta)-((3.0e0*s2+7.0e0)* + s2-16.0e0)/(810.0e0**a)+s*((9.0e0*s2+256.0e0)*s2-433.0e0)/(38880.0e0**a* + rta); + xn = fifdmax1(xn,0.0e0); + if(*a < amin[iop-1]) goto S110; + *x = xn; + d = 0.5e0+(0.5e0-*x/ *a); + if(fabs(d) <= dmin[iop-1]) return; +S110: + if(*p <= 0.5e0) goto S130; + if(xn < 3.0e0**a) goto S220; + y = -(w+gamln(a)); + d = fifdmax1(2.0e0,*a*(*a-1.0e0)); + if(y < ln10*d) goto S120; + s = 1.0e0-*a; + z = log(y); + goto S30; +S120: + t = *a-1.0e0; + T6 = -(t/(xn+1.0e0)); + xn = y+t*log(xn)-alnrel(&T6); + T7 = -(t/(xn+1.0e0)); + xn = y+t*log(xn)-alnrel(&T7); + goto S220; +S130: + ap1 = *a+1.0e0; + if(xn > 0.70e0*ap1) goto S170; + w += gamln(&ap1); + if(xn > 0.15e0*ap1) goto S140; + ap2 = *a+2.0e0; + ap3 = *a+3.0e0; + *x = exp((w+*x)/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2)))/ *a); + *x = exp((w+*x-log(1.0e0+*x/ap1*(1.0e0+*x/ap2*(1.0e0+*x/ap3))))/ *a); + xn = *x; + if(xn > 1.e-2*ap1) goto S140; + if(xn <= emin[iop-1]*ap1) return; + goto S170; +S140: + apn = ap1; + t = xn/apn; + sum = 1.0e0+t; +S150: + apn += 1.0e0; + t *= (xn/apn); + sum += t; + if(t > 1.e-4) goto S150; + t = w-log(sum); + xn = exp((xn+t)/ *a); + xn *= (1.0e0-(*a*log(xn)-xn-t)/(*a-xn)); + goto S170; +S160: +/* + SCHRODER ITERATION USING P +*/ + if(*p > 0.5e0) goto S220; +S170: + if(*p <= 1.e10*xmin) goto S350; + am1 = *a-0.5e0-0.5e0; +S180: + if(*a <= amax) goto S190; + d = 0.5e0+(0.5e0-xn/ *a); + if(fabs(d) <= e2) goto S350; +S190: + if(*ierr >= 20) goto S330; + *ierr += 1; + gratio(a,&xn,&pn,&qn,&K8); + if(pn == 0.0e0 || qn == 0.0e0) goto S350; + r = rcomp(a,&xn); + if(r == 0.0e0) goto S350; + t = (pn-*p)/r; + w = 0.5e0*(am1-xn); + if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S200; + *x = xn*(1.0e0-t); + if(*x <= 0.0e0) goto S340; + d = fabs(t); + goto S210; +S200: + h = t*(1.0e0+w*t); + *x = xn*(1.0e0-h); + if(*x <= 0.0e0) goto S340; + if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; + d = fabs(h); +S210: + xn = *x; + if(d > tol) goto S180; + if(d <= eps) return; + if(fabs(*p-pn) <= tol**p) return; + goto S180; +S220: +/* + SCHRODER ITERATION USING Q +*/ + if(*q <= 1.e10*xmin) goto S350; + am1 = *a-0.5e0-0.5e0; +S230: + if(*a <= amax) goto S240; + d = 0.5e0+(0.5e0-xn/ *a); + if(fabs(d) <= e2) goto S350; +S240: + if(*ierr >= 20) goto S330; + *ierr += 1; + gratio(a,&xn,&pn,&qn,&K8); + if(pn == 0.0e0 || qn == 0.0e0) goto S350; + r = rcomp(a,&xn); + if(r == 0.0e0) goto S350; + t = (*q-qn)/r; + w = 0.5e0*(am1-xn); + if(fabs(t) <= 0.1e0 && fabs(w*t) <= 0.1e0) goto S250; + *x = xn*(1.0e0-t); + if(*x <= 0.0e0) goto S340; + d = fabs(t); + goto S260; +S250: + h = t*(1.0e0+w*t); + *x = xn*(1.0e0-h); + if(*x <= 0.0e0) goto S340; + if(fabs(w) >= 1.0e0 && fabs(w)*t*t <= eps) return; + d = fabs(h); +S260: + xn = *x; + if(d > tol) goto S230; + if(d <= eps) return; + if(fabs(*q-qn) <= tol**q) return; + goto S230; +S270: +/* + SPECIAL CASES +*/ + *x = xmax; + return; +S280: + if(*q < 0.9e0) goto S290; + T9 = -*p; + *x = -alnrel(&T9); + return; +S290: + *x = -log(*q); + return; +S300: +/* + ERROR RETURN +*/ + *ierr = -2; + return; +S310: + *ierr = -3; + return; +S320: + *ierr = -4; + return; +S330: + *ierr = -6; + return; +S340: + *ierr = -7; + return; +S350: + *x = xn; + *ierr = -8; + return; +S360: + *x = xmax; + *ierr = -8; + return; +} +double gamln(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF LN(GAMMA(A)) FOR POSITIVE A +----------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS + NAVAL SURFACE WARFARE CENTER + DAHLGREN, VIRGINIA +-------------------------- + D = 0.5*(LN(2*PI) - 1) +-------------------------- +*/ +{ +static double c0 = .833333333333333e-01; +static double c1 = -.277777777760991e-02; +static double c2 = .793650666825390e-03; +static double c3 = -.595202931351870e-03; +static double c4 = .837308034031215e-03; +static double c5 = -.165322962780713e-02; +static double d = .418938533204673e0; +static double gamln,t,w; +static int i,n; +static double T1; +/* + .. + .. Executable Statements .. +*/ + if(*a > 0.8e0) goto S10; + gamln = gamln1(a)-log(*a); + return gamln; +S10: + if(*a > 2.25e0) goto S20; + t = *a-0.5e0-0.5e0; + gamln = gamln1(&t); + return gamln; +S20: + if(*a >= 10.0e0) goto S40; + n = (long)(*a - 1.25e0); + t = *a; + w = 1.0e0; + for(i=1; i<=n; i++) { + t -= 1.0e0; + w = t*w; + } + T1 = t-1.0e0; + gamln = gamln1(&T1)+log(w); + return gamln; +S40: + t = pow(1.0e0/ *a,2.0); + w = (((((c5*t+c4)*t+c3)*t+c2)*t+c1)*t+c0)/ *a; + gamln = d+w+(*a-0.5e0)*(log(*a)-1.0e0); + return gamln; +} +double gamln1(double *a) +/* +----------------------------------------------------------------------- + EVALUATION OF LN(GAMMA(1 + A)) FOR -0.2 .LE. A .LE. 1.25 +----------------------------------------------------------------------- +*/ +{ +static double p0 = .577215664901533e+00; +static double p1 = .844203922187225e+00; +static double p2 = -.168860593646662e+00; +static double p3 = -.780427615533591e+00; +static double p4 = -.402055799310489e+00; +static double p5 = -.673562214325671e-01; +static double p6 = -.271935708322958e-02; +static double q1 = .288743195473681e+01; +static double q2 = .312755088914843e+01; +static double q3 = .156875193295039e+01; +static double q4 = .361951990101499e+00; +static double q5 = .325038868253937e-01; +static double q6 = .667465618796164e-03; +static double r0 = .422784335098467e+00; +static double r1 = .848044614534529e+00; +static double r2 = .565221050691933e+00; +static double r3 = .156513060486551e+00; +static double r4 = .170502484022650e-01; +static double r5 = .497958207639485e-03; +static double s1 = .124313399877507e+01; +static double s2 = .548042109832463e+00; +static double s3 = .101552187439830e+00; +static double s4 = .713309612391000e-02; +static double s5 = .116165475989616e-03; +static double gamln1,w,x; +/* + .. + .. Executable Statements .. +*/ + if(*a >= 0.6e0) goto S10; + w = ((((((p6**a+p5)**a+p4)**a+p3)**a+p2)**a+p1)**a+p0)/((((((q6**a+q5)**a+ + q4)**a+q3)**a+q2)**a+q1)**a+1.0e0); + gamln1 = -(*a*w); + return gamln1; +S10: + x = *a-0.5e0-0.5e0; + w = (((((r5*x+r4)*x+r3)*x+r2)*x+r1)*x+r0)/(((((s5*x+s4)*x+s3)*x+s2)*x+s1)*x + +1.0e0); + gamln1 = x*w; + return gamln1; +} +double Xgamm(double *a) +/* +----------------------------------------------------------------------- + + EVALUATION OF THE GAMMA FUNCTION FOR REAL ARGUMENTS + + ----------- + + GAMMA(A) IS ASSIGNED THE VALUE 0 WHEN THE GAMMA FUNCTION CANNOT + BE COMPUTED. + +----------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA +----------------------------------------------------------------------- +*/ +{ +static double d = .41893853320467274178e0; +static double pi = 3.1415926535898e0; +static double r1 = .820756370353826e-03; +static double r2 = -.595156336428591e-03; +static double r3 = .793650663183693e-03; +static double r4 = -.277777777770481e-02; +static double r5 = .833333333333333e-01; +static double p[7] = { + .539637273585445e-03,.261939260042690e-02,.204493667594920e-01, + .730981088720487e-01,.279648642639792e+00,.553413866010467e+00,1.0e0 +}; +static double q[7] = { + -.832979206704073e-03,.470059485860584e-02,.225211131035340e-01, + -.170458969313360e+00,-.567902761974940e-01,.113062953091122e+01,1.0e0 +}; +static int K2 = 3; +static int K3 = 0; +static double Xgamm,bot,g,lnx,s,t,top,w,x,z; +static int i,j,m,n,T1; +/* + .. + .. Executable Statements .. +*/ + Xgamm = 0.0e0; + x = *a; + if(fabs(*a) >= 15.0e0) goto S110; +/* +----------------------------------------------------------------------- + EVALUATION OF GAMMA(A) FOR ABS(A) .LT. 15 +----------------------------------------------------------------------- +*/ + t = 1.0e0; + m = fifidint(*a)-1; +/* + LET T BE THE PRODUCT OF A-J WHEN A .GE. 2 +*/ + T1 = m; + if(T1 < 0) goto S40; + else if(T1 == 0) goto S30; + else goto S10; +S10: + for(j=1; j<=m; j++) { + x -= 1.0e0; + t = x*t; + } +S30: + x -= 1.0e0; + goto S80; +S40: +/* + LET T BE THE PRODUCT OF A+J WHEN A .LT. 1 +*/ + t = *a; + if(*a > 0.0e0) goto S70; + m = -m-1; + if(m == 0) goto S60; + for(j=1; j<=m; j++) { + x += 1.0e0; + t = x*t; + } +S60: + x += (0.5e0+0.5e0); + t = x*t; + if(t == 0.0e0) return Xgamm; +S70: +/* + THE FOLLOWING CODE CHECKS IF 1/T CAN OVERFLOW. THIS + CODE MAY BE OMITTED IF DESIRED. +*/ + if(fabs(t) >= 1.e-30) goto S80; + if(fabs(t)*spmpar(&K2) <= 1.0001e0) return Xgamm; + Xgamm = 1.0e0/t; + return Xgamm; +S80: +/* + COMPUTE GAMMA(1 + X) FOR 0 .LE. X .LT. 1 +*/ + top = p[0]; + bot = q[0]; + for(i=1; i<7; i++) { + top = p[i]+x*top; + bot = q[i]+x*bot; + } + Xgamm = top/bot; +/* + TERMINATION +*/ + if(*a < 1.0e0) goto S100; + Xgamm *= t; + return Xgamm; +S100: + Xgamm /= t; + return Xgamm; +S110: +/* +----------------------------------------------------------------------- + EVALUATION OF GAMMA(A) FOR ABS(A) .GE. 15 +----------------------------------------------------------------------- +*/ + if(fabs(*a) >= 1.e3) return Xgamm; + if(*a > 0.0e0) goto S120; + x = -*a; + n = (long)(x); + t = x-(double)n; + if(t > 0.9e0) t = 1.0e0-t; + s = sin(pi*t)/pi; + if(fifmod(n,2) == 0) s = -s; + if(s == 0.0e0) return Xgamm; +S120: +/* + COMPUTE THE MODIFIED ASYMPTOTIC SUM +*/ + t = 1.0e0/(x*x); + g = ((((r1*t+r2)*t+r3)*t+r4)*t+r5)/x; +/* + ONE MAY REPLACE THE NEXT STATEMENT WITH LNX = ALOG(X) + BUT LESS ACCURACY WILL NORMALLY BE OBTAINED. +*/ + lnx = log(x); +/* + FINAL ASSEMBLY +*/ + z = x; + g = d+g+(z-0.5e0)*(lnx-1.e0); + w = g; + t = g-w; + if(w > 0.99999e0*exparg(&K3)) return Xgamm; + Xgamm = exp(w)*(1.0e0+t); + if(*a < 0.0e0) Xgamm = 1.0e0/(Xgamm*s)/x; + return Xgamm; +} +void grat1(double *a,double *x,double *r,double *p,double *q, + double *eps) +{ +static int K2 = 0; +static double a2n,a2nm1,am0,an,an0,b2n,b2nm1,c,cma,g,h,j,l,sum,t,tol,w,z,T1,T3; +/* + .. + .. Executable Statements .. +*/ +/* +----------------------------------------------------------------------- + EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS + P(A,X) AND Q(A,X) + IT IS ASSUMED THAT A .LE. 1. EPS IS THE TOLERANCE TO BE USED. + THE INPUT ARGUMENT R HAS THE VALUE E**(-X)*X**A/GAMMA(A). +----------------------------------------------------------------------- +*/ + if(*a**x == 0.0e0) goto S120; + if(*a == 0.5e0) goto S100; + if(*x < 1.1e0) goto S10; + goto S60; +S10: +/* + TAYLOR SERIES FOR P(A,X)/X**A +*/ + an = 3.0e0; + c = *x; + sum = *x/(*a+3.0e0); + tol = 0.1e0**eps/(*a+1.0e0); +S20: + an += 1.0e0; + c = -(c*(*x/an)); + t = c/(*a+an); + sum += t; + if(fabs(t) > tol) goto S20; + j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); + z = *a*log(*x); + h = gam1(a); + g = 1.0e0+h; + if(*x < 0.25e0) goto S30; + if(*a < *x/2.59e0) goto S50; + goto S40; +S30: + if(z > -.13394e0) goto S50; +S40: + w = exp(z); + *p = w*g*(0.5e0+(0.5e0-j)); + *q = 0.5e0+(0.5e0-*p); + return; +S50: + l = rexp(&z); + w = 0.5e0+(0.5e0+l); + *q = (w*j-l)*g-h; + if(*q < 0.0e0) goto S90; + *p = 0.5e0+(0.5e0-*q); + return; +S60: +/* + CONTINUED FRACTION EXPANSION +*/ + a2nm1 = a2n = 1.0e0; + b2nm1 = *x; + b2n = *x+(1.0e0-*a); + c = 1.0e0; +S70: + a2nm1 = *x*a2n+c*a2nm1; + b2nm1 = *x*b2n+c*b2nm1; + am0 = a2nm1/b2nm1; + c += 1.0e0; + cma = c-*a; + a2n = a2nm1+cma*a2n; + b2n = b2nm1+cma*b2n; + an0 = a2n/b2n; + if(fabs(an0-am0) >= *eps*an0) goto S70; + *q = *r*an0; + *p = 0.5e0+(0.5e0-*q); + return; +S80: +/* + SPECIAL CASES +*/ + *p = 0.0e0; + *q = 1.0e0; + return; +S90: + *p = 1.0e0; + *q = 0.0e0; + return; +S100: + if(*x >= 0.25e0) goto S110; + T1 = sqrt(*x); + *p = erf1(&T1); + *q = 0.5e0+(0.5e0-*p); + return; +S110: + T3 = sqrt(*x); + *q = erfc1(&K2,&T3); + *p = 0.5e0+(0.5e0-*q); + return; +S120: + if(*x <= *a) goto S80; + goto S90; +} +void gratio(double *a,double *x,double *ans,double *qans,int *ind) +/* + ---------------------------------------------------------------------- + EVALUATION OF THE INCOMPLETE GAMMA RATIO FUNCTIONS + P(A,X) AND Q(A,X) + + ---------- + + IT IS ASSUMED THAT A AND X ARE NONNEGATIVE, WHERE A AND X + ARE NOT BOTH 0. + + ANS AND QANS ARE VARIABLES. GRATIO ASSIGNS ANS THE VALUE + P(A,X) AND QANS THE VALUE Q(A,X). IND MAY BE ANY INTEGER. + IF IND = 0 THEN THE USER IS REQUESTING AS MUCH ACCURACY AS + POSSIBLE (UP TO 14 SIGNIFICANT DIGITS). OTHERWISE, IF + IND = 1 THEN ACCURACY IS REQUESTED TO WITHIN 1 UNIT OF THE + 6-TH SIGNIFICANT DIGIT, AND IF IND .NE. 0,1 THEN ACCURACY + IS REQUESTED TO WITHIN 1 UNIT OF THE 3RD SIGNIFICANT DIGIT. + + ERROR RETURN ... + ANS IS ASSIGNED THE VALUE 2 WHEN A OR X IS NEGATIVE, + WHEN A*X = 0, OR WHEN P(A,X) AND Q(A,X) ARE INDETERMINANT. + P(A,X) AND Q(A,X) ARE COMPUTATIONALLY INDETERMINANT WHEN + X IS EXCEEDINGLY CLOSE TO A AND A IS EXTREMELY LARGE. + ---------------------------------------------------------------------- + WRITTEN BY ALFRED H. MORRIS, JR. + NAVAL SURFACE WEAPONS CENTER + DAHLGREN, VIRGINIA + -------------------- +*/ +{ +static double alog10 = 2.30258509299405e0; +static double d10 = -.185185185185185e-02; +static double d20 = .413359788359788e-02; +static double d30 = .649434156378601e-03; +static double d40 = -.861888290916712e-03; +static double d50 = -.336798553366358e-03; +static double d60 = .531307936463992e-03; +static double d70 = .344367606892378e-03; +static double rt2pin = .398942280401433e0; +static double rtpi = 1.77245385090552e0; +static double third = .333333333333333e0; +static double acc0[3] = { + 5.e-15,5.e-7,5.e-4 +}; +static double big[3] = { + 20.0e0,14.0e0,10.0e0 +}; +static double d0[13] = { + .833333333333333e-01,-.148148148148148e-01,.115740740740741e-02, + .352733686067019e-03,-.178755144032922e-03,.391926317852244e-04, + -.218544851067999e-05,-.185406221071516e-05,.829671134095309e-06, + -.176659527368261e-06,.670785354340150e-08,.102618097842403e-07, + -.438203601845335e-08 +}; +static double d1[12] = { + -.347222222222222e-02,.264550264550265e-02,-.990226337448560e-03, + .205761316872428e-03,-.401877572016461e-06,-.180985503344900e-04, + .764916091608111e-05,-.161209008945634e-05,.464712780280743e-08, + .137863344691572e-06,-.575254560351770e-07,.119516285997781e-07 +}; +static double d2[10] = { + -.268132716049383e-02,.771604938271605e-03,.200938786008230e-05, + -.107366532263652e-03,.529234488291201e-04,-.127606351886187e-04, + .342357873409614e-07,.137219573090629e-05,-.629899213838006e-06, + .142806142060642e-06 +}; +static double d3[8] = { + .229472093621399e-03,-.469189494395256e-03,.267720632062839e-03, + -.756180167188398e-04,-.239650511386730e-06,.110826541153473e-04, + -.567495282699160e-05,.142309007324359e-05 +}; +static double d4[6] = { + .784039221720067e-03,-.299072480303190e-03,-.146384525788434e-05, + .664149821546512e-04,-.396836504717943e-04,.113757269706784e-04 +}; +static double d5[4] = { + -.697281375836586e-04,.277275324495939e-03,-.199325705161888e-03, + .679778047793721e-04 +}; +static double d6[2] = { + -.592166437353694e-03,.270878209671804e-03 +}; +static double e00[3] = { + .25e-3,.25e-1,.14e0 +}; +static double x00[3] = { + 31.0e0,17.0e0,9.7e0 +}; +static int K1 = 1; +static int K2 = 0; +static double a2n,a2nm1,acc,am0,amn,an,an0,apn,b2n,b2nm1,c,c0,c1,c2,c3,c4,c5,c6, + cma,e,e0,g,h,j,l,r,rta,rtx,s,sum,t,t1,tol,twoa,u,w,x0,y,z; +static int i,iop,m,max,n; +static double wk[20],T3; +static int T4,T5; +static double T6,T7; +/* + .. + .. Executable Statements .. +*/ +/* + -------------------- + ****** E IS A MACHINE DEPENDENT CONSTANT. E IS THE SMALLEST + FLOATING POINT NUMBER FOR WHICH 1.0 + E .GT. 1.0 . +*/ + e = spmpar(&K1); + if(*a < 0.0e0 || *x < 0.0e0) goto S430; + if(*a == 0.0e0 && *x == 0.0e0) goto S430; + if(*a**x == 0.0e0) goto S420; + iop = *ind+1; + if(iop != 1 && iop != 2) iop = 3; + acc = fifdmax1(acc0[iop-1],e); + e0 = e00[iop-1]; + x0 = x00[iop-1]; +/* + SELECT THE APPROPRIATE ALGORITHM +*/ + if(*a >= 1.0e0) goto S10; + if(*a == 0.5e0) goto S390; + if(*x < 1.1e0) goto S160; + t1 = *a*log(*x)-*x; + u = *a*exp(t1); + if(u == 0.0e0) goto S380; + r = u*(1.0e0+gam1(a)); + goto S250; +S10: + if(*a >= big[iop-1]) goto S30; + if(*a > *x || *x >= x0) goto S20; + twoa = *a+*a; + m = fifidint(twoa); + if(twoa != (double)m) goto S20; + i = m/2; + if(*a == (double)i) goto S210; + goto S220; +S20: + t1 = *a*log(*x)-*x; + r = exp(t1)/Xgamm(a); + goto S40; +S30: + l = *x/ *a; + if(l == 0.0e0) goto S370; + s = 0.5e0+(0.5e0-l); + z = rlog(&l); + if(z >= 700.0e0/ *a) goto S410; + y = *a*z; + rta = sqrt(*a); + if(fabs(s) <= e0/rta) goto S330; + if(fabs(s) <= 0.4e0) goto S270; + t = pow(1.0e0/ *a,2.0); + t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); + t1 -= y; + r = rt2pin*rta*exp(t1); +S40: + if(r == 0.0e0) goto S420; + if(*x <= fifdmax1(*a,alog10)) goto S50; + if(*x < x0) goto S250; + goto S100; +S50: +/* + TAYLOR SERIES FOR P/R +*/ + apn = *a+1.0e0; + t = *x/apn; + wk[0] = t; + for(n=2; n<=20; n++) { + apn += 1.0e0; + t *= (*x/apn); + if(t <= 1.e-3) goto S70; + wk[n-1] = t; + } + n = 20; +S70: + sum = t; + tol = 0.5e0*acc; +S80: + apn += 1.0e0; + t *= (*x/apn); + sum += t; + if(t > tol) goto S80; + max = n-1; + for(m=1; m<=max; m++) { + n -= 1; + sum += wk[n-1]; + } + *ans = r/ *a*(1.0e0+sum); + *qans = 0.5e0+(0.5e0-*ans); + return; +S100: +/* + ASYMPTOTIC EXPANSION +*/ + amn = *a-1.0e0; + t = amn/ *x; + wk[0] = t; + for(n=2; n<=20; n++) { + amn -= 1.0e0; + t *= (amn/ *x); + if(fabs(t) <= 1.e-3) goto S120; + wk[n-1] = t; + } + n = 20; +S120: + sum = t; +S130: + if(fabs(t) <= acc) goto S140; + amn -= 1.0e0; + t *= (amn/ *x); + sum += t; + goto S130; +S140: + max = n-1; + for(m=1; m<=max; m++) { + n -= 1; + sum += wk[n-1]; + } + *qans = r/ *x*(1.0e0+sum); + *ans = 0.5e0+(0.5e0-*qans); + return; +S160: +/* + TAYLOR SERIES FOR P(A,X)/X**A +*/ + an = 3.0e0; + c = *x; + sum = *x/(*a+3.0e0); + tol = 3.0e0*acc/(*a+1.0e0); +S170: + an += 1.0e0; + c = -(c*(*x/an)); + t = c/(*a+an); + sum += t; + if(fabs(t) > tol) goto S170; + j = *a**x*((sum/6.0e0-0.5e0/(*a+2.0e0))**x+1.0e0/(*a+1.0e0)); + z = *a*log(*x); + h = gam1(a); + g = 1.0e0+h; + if(*x < 0.25e0) goto S180; + if(*a < *x/2.59e0) goto S200; + goto S190; +S180: + if(z > -.13394e0) goto S200; +S190: + w = exp(z); + *ans = w*g*(0.5e0+(0.5e0-j)); + *qans = 0.5e0+(0.5e0-*ans); + return; +S200: + l = rexp(&z); + w = 0.5e0+(0.5e0+l); + *qans = (w*j-l)*g-h; + if(*qans < 0.0e0) goto S380; + *ans = 0.5e0+(0.5e0-*qans); + return; +S210: +/* + FINITE SUMS FOR Q WHEN A .GE. 1 + AND 2*A IS AN INTEGER +*/ + sum = exp(-*x); + t = sum; + n = 1; + c = 0.0e0; + goto S230; +S220: + rtx = sqrt(*x); + sum = erfc1(&K2,&rtx); + t = exp(-*x)/(rtpi*rtx); + n = 0; + c = -0.5e0; +S230: + if(n == i) goto S240; + n += 1; + c += 1.0e0; + t = *x*t/c; + sum += t; + goto S230; +S240: + *qans = sum; + *ans = 0.5e0+(0.5e0-*qans); + return; +S250: +/* + CONTINUED FRACTION EXPANSION +*/ + tol = fifdmax1(5.0e0*e,acc); + a2nm1 = a2n = 1.0e0; + b2nm1 = *x; + b2n = *x+(1.0e0-*a); + c = 1.0e0; +S260: + a2nm1 = *x*a2n+c*a2nm1; + b2nm1 = *x*b2n+c*b2nm1; + am0 = a2nm1/b2nm1; + c += 1.0e0; + cma = c-*a; + a2n = a2nm1+cma*a2n; + b2n = b2nm1+cma*b2n; + an0 = a2n/b2n; + if(fabs(an0-am0) >= tol*an0) goto S260; + *qans = r*an0; + *ans = 0.5e0+(0.5e0-*qans); + return; +S270: +/* + GENERAL TEMME EXPANSION +*/ + if(fabs(s) <= 2.0e0*e && *a*e*e > 3.28e-3) goto S430; + c = exp(-y); + T3 = sqrt(y); + w = 0.5e0*erfc1(&K1,&T3); + u = 1.0e0/ *a; + z = sqrt(z+z); + if(l < 1.0e0) z = -z; + T4 = iop-2; + if(T4 < 0) goto S280; + else if(T4 == 0) goto S290; + else goto S300; +S280: + if(fabs(s) <= 1.e-3) goto S340; + c0 = ((((((((((((d0[12]*z+d0[11])*z+d0[10])*z+d0[9])*z+d0[8])*z+d0[7])*z+d0[ + 6])*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; + c1 = (((((((((((d1[11]*z+d1[10])*z+d1[9])*z+d1[8])*z+d1[7])*z+d1[6])*z+d1[5] + )*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = (((((((((d2[9]*z+d2[8])*z+d2[7])*z+d2[6])*z+d2[5])*z+d2[4])*z+d2[3])*z+ + d2[2])*z+d2[1])*z+d2[0])*z+d20; + c3 = (((((((d3[7]*z+d3[6])*z+d3[5])*z+d3[4])*z+d3[3])*z+d3[2])*z+d3[1])*z+ + d3[0])*z+d30; + c4 = (((((d4[5]*z+d4[4])*z+d4[3])*z+d4[2])*z+d4[1])*z+d4[0])*z+d40; + c5 = (((d5[3]*z+d5[2])*z+d5[1])*z+d5[0])*z+d50; + c6 = (d6[1]*z+d6[0])*z+d60; + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; + goto S310; +S290: + c0 = (((((d0[5]*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z-third; + c1 = (((d1[3]*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = d2[0]*z+d20; + t = (c2*u+c1)*u+c0; + goto S310; +S300: + t = ((d0[2]*z+d0[1])*z+d0[0])*z-third; +S310: + if(l < 1.0e0) goto S320; + *qans = c*(w+rt2pin*t/rta); + *ans = 0.5e0+(0.5e0-*qans); + return; +S320: + *ans = c*(w-rt2pin*t/rta); + *qans = 0.5e0+(0.5e0-*ans); + return; +S330: +/* + TEMME EXPANSION FOR L = 1 +*/ + if(*a*e*e > 3.28e-3) goto S430; + c = 0.5e0+(0.5e0-y); + w = (0.5e0-sqrt(y)*(0.5e0+(0.5e0-y/3.0e0))/rtpi)/c; + u = 1.0e0/ *a; + z = sqrt(z+z); + if(l < 1.0e0) z = -z; + T5 = iop-2; + if(T5 < 0) goto S340; + else if(T5 == 0) goto S350; + else goto S360; +S340: + c0 = ((((((d0[6]*z+d0[5])*z+d0[4])*z+d0[3])*z+d0[2])*z+d0[1])*z+d0[0])*z- + third; + c1 = (((((d1[5]*z+d1[4])*z+d1[3])*z+d1[2])*z+d1[1])*z+d1[0])*z+d10; + c2 = ((((d2[4]*z+d2[3])*z+d2[2])*z+d2[1])*z+d2[0])*z+d20; + c3 = (((d3[3]*z+d3[2])*z+d3[1])*z+d3[0])*z+d30; + c4 = (d4[1]*z+d4[0])*z+d40; + c5 = (d5[1]*z+d5[0])*z+d50; + c6 = d6[0]*z+d60; + t = ((((((d70*u+c6)*u+c5)*u+c4)*u+c3)*u+c2)*u+c1)*u+c0; + goto S310; +S350: + c0 = (d0[1]*z+d0[0])*z-third; + c1 = d1[0]*z+d10; + t = (d20*u+c1)*u+c0; + goto S310; +S360: + t = d0[0]*z-third; + goto S310; +S370: +/* + SPECIAL CASES +*/ + *ans = 0.0e0; + *qans = 1.0e0; + return; +S380: + *ans = 1.0e0; + *qans = 0.0e0; + return; +S390: + if(*x >= 0.25e0) goto S400; + T6 = sqrt(*x); + *ans = erf1(&T6); + *qans = 0.5e0+(0.5e0-*ans); + return; +S400: + T7 = sqrt(*x); + *qans = erfc1(&K2,&T7); + *ans = 0.5e0+(0.5e0-*qans); + return; +S410: + if(fabs(s) <= 2.0e0*e) goto S430; +S420: + if(*x <= *a) goto S370; + goto S380; +S430: +/* + ERROR RETURN +*/ + *ans = 2.0e0; + return; +} +double gsumln(double *a,double *b) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION LN(GAMMA(A + B)) + FOR 1 .LE. A .LE. 2 AND 1 .LE. B .LE. 2 +----------------------------------------------------------------------- +*/ +{ +static double gsumln,x,T1,T2; +/* + .. + .. Executable Statements .. +*/ + x = *a+*b-2.e0; + if(x > 0.25e0) goto S10; + T1 = 1.0e0+x; + gsumln = gamln1(&T1); + return gsumln; +S10: + if(x > 1.25e0) goto S20; + gsumln = gamln1(&x)+alnrel(&x); + return gsumln; +S20: + T2 = x-1.0e0; + gsumln = gamln1(&T2)+log(x*(1.0e0+x)); + return gsumln; +} +double psi(double *xx) +/* +--------------------------------------------------------------------- + + EVALUATION OF THE DIGAMMA FUNCTION + + ----------- + + PSI(XX) IS ASSIGNED THE VALUE 0 WHEN THE DIGAMMA FUNCTION CANNOT + BE COMPUTED. + + THE MAIN COMPUTATION INVOLVES EVALUATION OF RATIONAL CHEBYSHEV + APPROXIMATIONS PUBLISHED IN MATH. COMP. 27, 123-127(1973) BY + CODY, STRECOK AND THACHER. + +--------------------------------------------------------------------- + PSI WAS WRITTEN AT ARGONNE NATIONAL LABORATORY FOR THE FUNPACK + PACKAGE OF SPECIAL FUNCTION SUBROUTINES. PSI WAS MODIFIED BY + A.H. MORRIS (NSWC). +--------------------------------------------------------------------- +*/ +{ +static double dx0 = 1.461632144968362341262659542325721325e0; +static double piov4 = .785398163397448e0; +static double p1[7] = { + .895385022981970e-02,.477762828042627e+01,.142441585084029e+03, + .118645200713425e+04,.363351846806499e+04,.413810161269013e+04, + .130560269827897e+04 +}; +static double p2[4] = { + -.212940445131011e+01,-.701677227766759e+01,-.448616543918019e+01, + -.648157123766197e+00 +}; +static double q1[6] = { + .448452573429826e+02,.520752771467162e+03,.221000799247830e+04, + .364127349079381e+04,.190831076596300e+04,.691091682714533e-05 +}; +static double q2[4] = { + .322703493791143e+02,.892920700481861e+02,.546117738103215e+02, + .777788548522962e+01 +}; +static int K1 = 3; +static int K2 = 1; +static double psi,aug,den,sgn,upper,w,x,xmax1,xmx0,xsmall,z; +static int i,m,n,nq; +/* + .. + .. Executable Statements .. +*/ +/* +--------------------------------------------------------------------- + MACHINE DEPENDENT CONSTANTS ... + XMAX1 = THE SMALLEST POSITIVE FLOATING POINT CONSTANT + WITH ENTIRELY INTEGER REPRESENTATION. ALSO USED + AS NEGATIVE OF LOWER BOUND ON ACCEPTABLE NEGATIVE + ARGUMENTS AND AS THE POSITIVE ARGUMENT BEYOND WHICH + PSI MAY BE REPRESENTED AS ALOG(X). + XSMALL = ABSOLUTE ARGUMENT BELOW WHICH PI*COTAN(PI*X) + MAY BE REPRESENTED BY 1/X. +--------------------------------------------------------------------- +*/ + xmax1 = ipmpar(&K1); + xmax1 = fifdmin1(xmax1,1.0e0/spmpar(&K2)); + xsmall = 1.e-9; + x = *xx; + aug = 0.0e0; + if(x >= 0.5e0) goto S50; +/* +--------------------------------------------------------------------- + X .LT. 0.5, USE REFLECTION FORMULA + PSI(1-X) = PSI(X) + PI * COTAN(PI*X) +--------------------------------------------------------------------- +*/ + if(fabs(x) > xsmall) goto S10; + if(x == 0.0e0) goto S100; +/* +--------------------------------------------------------------------- + 0 .LT. ABS(X) .LE. XSMALL. USE 1/X AS A SUBSTITUTE + FOR PI*COTAN(PI*X) +--------------------------------------------------------------------- +*/ + aug = -(1.0e0/x); + goto S40; +S10: +/* +--------------------------------------------------------------------- + REDUCTION OF ARGUMENT FOR COTAN +--------------------------------------------------------------------- +*/ + w = -x; + sgn = piov4; + if(w > 0.0e0) goto S20; + w = -w; + sgn = -sgn; +S20: +/* +--------------------------------------------------------------------- + MAKE AN ERROR EXIT IF X .LE. -XMAX1 +--------------------------------------------------------------------- +*/ + if(w >= xmax1) goto S100; + nq = fifidint(w); + w -= (double)nq; + nq = fifidint(w*4.0e0); + w = 4.0e0*(w-(double)nq*.25e0); +/* +--------------------------------------------------------------------- + W IS NOW RELATED TO THE FRACTIONAL PART OF 4.0 * X. + ADJUST ARGUMENT TO CORRESPOND TO VALUES IN FIRST + QUADRANT AND DETERMINE SIGN +--------------------------------------------------------------------- +*/ + n = nq/2; + if(n+n != nq) w = 1.0e0-w; + z = piov4*w; + m = n/2; + if(m+m != n) sgn = -sgn; +/* +--------------------------------------------------------------------- + DETERMINE FINAL VALUE FOR -PI*COTAN(PI*X) +--------------------------------------------------------------------- +*/ + n = (nq+1)/2; + m = n/2; + m += m; + if(m != n) goto S30; +/* +--------------------------------------------------------------------- + CHECK FOR SINGULARITY +--------------------------------------------------------------------- +*/ + if(z == 0.0e0) goto S100; +/* +--------------------------------------------------------------------- + USE COS/SIN AS A SUBSTITUTE FOR COTAN, AND + SIN/COS AS A SUBSTITUTE FOR TAN +--------------------------------------------------------------------- +*/ + aug = sgn*(cos(z)/sin(z)*4.0e0); + goto S40; +S30: + aug = sgn*(sin(z)/cos(z)*4.0e0); +S40: + x = 1.0e0-x; +S50: + if(x > 3.0e0) goto S70; +/* +--------------------------------------------------------------------- + 0.5 .LE. X .LE. 3.0 +--------------------------------------------------------------------- +*/ + den = x; + upper = p1[0]*x; + for(i=1; i<=5; i++) { + den = (den+q1[i-1])*x; + upper = (upper+p1[i+1-1])*x; + } + den = (upper+p1[6])/(den+q1[5]); + xmx0 = x-dx0; + psi = den*xmx0+aug; + return psi; +S70: +/* +--------------------------------------------------------------------- + IF X .GE. XMAX1, PSI = LN(X) +--------------------------------------------------------------------- +*/ + if(x >= xmax1) goto S90; +/* +--------------------------------------------------------------------- + 3.0 .LT. X .LT. XMAX1 +--------------------------------------------------------------------- +*/ + w = 1.0e0/(x*x); + den = w; + upper = p2[0]*w; + for(i=1; i<=3; i++) { + den = (den+q2[i-1])*w; + upper = (upper+p2[i+1-1])*w; + } + aug = upper/(den+q2[3])-0.5e0/x+aug; +S90: + psi = aug+log(x); + return psi; +S100: +/* +--------------------------------------------------------------------- + ERROR RETURN +--------------------------------------------------------------------- +*/ + psi = 0.0e0; + return psi; +} +double rcomp(double *a,double *x) +/* + ------------------- + EVALUATION OF EXP(-X)*X**A/GAMMA(A) + ------------------- + RT2PIN = 1/SQRT(2*PI) + ------------------- +*/ +{ +static double rt2pin = .398942280401433e0; +static double rcomp,t,t1,u; +/* + .. + .. Executable Statements .. +*/ + rcomp = 0.0e0; + if(*a >= 20.0e0) goto S20; + t = *a*log(*x)-*x; + if(*a >= 1.0e0) goto S10; + rcomp = *a*exp(t)*(1.0e0+gam1(a)); + return rcomp; +S10: + rcomp = exp(t)/Xgamm(a); + return rcomp; +S20: + u = *x/ *a; + if(u == 0.0e0) return rcomp; + t = pow(1.0e0/ *a,2.0); + t1 = (((0.75e0*t-1.0e0)*t+3.5e0)*t-105.0e0)/(*a*1260.0e0); + t1 -= (*a*rlog(&u)); + rcomp = rt2pin*sqrt(*a)*exp(t1); + return rcomp; +} +double rexp(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION EXP(X) - 1 +----------------------------------------------------------------------- +*/ +{ +static double p1 = .914041914819518e-09; +static double p2 = .238082361044469e-01; +static double q1 = -.499999999085958e+00; +static double q2 = .107141568980644e+00; +static double q3 = -.119041179760821e-01; +static double q4 = .595130811860248e-03; +static double rexp,w; +/* + .. + .. Executable Statements .. +*/ + if(fabs(*x) > 0.15e0) goto S10; + rexp = *x*(((p2**x+p1)**x+1.0e0)/((((q4**x+q3)**x+q2)**x+q1)**x+1.0e0)); + return rexp; +S10: + w = exp(*x); + if(*x > 0.0e0) goto S20; + rexp = w-0.5e0-0.5e0; + return rexp; +S20: + rexp = w*(0.5e0+(0.5e0-1.0e0/w)); + return rexp; +} +double rlog(double *x) +/* + ------------------- + COMPUTATION OF X - 1 - LN(X) + ------------------- +*/ +{ +static double a = .566749439387324e-01; +static double b = .456512608815524e-01; +static double p0 = .333333333333333e+00; +static double p1 = -.224696413112536e+00; +static double p2 = .620886815375787e-02; +static double q1 = -.127408923933623e+01; +static double q2 = .354508718369557e+00; +static double rlog,r,t,u,w,w1; +/* + .. + .. Executable Statements .. +*/ + if(*x < 0.61e0 || *x > 1.57e0) goto S40; + if(*x < 0.82e0) goto S10; + if(*x > 1.18e0) goto S20; +/* + ARGUMENT REDUCTION +*/ + u = *x-0.5e0-0.5e0; + w1 = 0.0e0; + goto S30; +S10: + u = *x-0.7e0; + u /= 0.7e0; + w1 = a-u*0.3e0; + goto S30; +S20: + u = 0.75e0**x-1.e0; + w1 = b+u/3.0e0; +S30: +/* + SERIES EXPANSION +*/ + r = u/(u+2.0e0); + t = r*r; + w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); + rlog = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; + return rlog; +S40: + r = *x-0.5e0-0.5e0; + rlog = r-log(*x); + return rlog; +} +double rlog1(double *x) +/* +----------------------------------------------------------------------- + EVALUATION OF THE FUNCTION X - LN(1 + X) +----------------------------------------------------------------------- +*/ +{ +static double a = .566749439387324e-01; +static double b = .456512608815524e-01; +static double p0 = .333333333333333e+00; +static double p1 = -.224696413112536e+00; +static double p2 = .620886815375787e-02; +static double q1 = -.127408923933623e+01; +static double q2 = .354508718369557e+00; +static double rlog1,h,r,t,w,w1; +/* + .. + .. Executable Statements .. +*/ + if(*x < -0.39e0 || *x > 0.57e0) goto S40; + if(*x < -0.18e0) goto S10; + if(*x > 0.18e0) goto S20; +/* + ARGUMENT REDUCTION +*/ + h = *x; + w1 = 0.0e0; + goto S30; +S10: + h = *x+0.3e0; + h /= 0.7e0; + w1 = a-h*0.3e0; + goto S30; +S20: + h = 0.75e0**x-0.25e0; + w1 = b+h/3.0e0; +S30: +/* + SERIES EXPANSION +*/ + r = h/(h+2.0e0); + t = r*r; + w = ((p2*t+p1)*t+p0)/((q2*t+q1)*t+1.0e0); + rlog1 = 2.0e0*t*(1.0e0/(1.0e0-r)-r*w)+w1; + return rlog1; +S40: + w = *x+0.5e0+0.5e0; + rlog1 = *x-log(w); + return rlog1; +} +double spmpar(int *i) +/* +----------------------------------------------------------------------- + + SPMPAR PROVIDES THE SINGLE PRECISION MACHINE CONSTANTS FOR + THE COMPUTER BEING USED. IT IS ASSUMED THAT THE ARGUMENT + I IS AN INTEGER HAVING ONE OF THE VALUES 1, 2, OR 3. IF THE + SINGLE PRECISION ARITHMETIC BEING USED HAS M BASE B DIGITS AND + ITS SMALLEST AND LARGEST EXPONENTS ARE EMIN AND EMAX, THEN + + SPMPAR(1) = B**(1 - M), THE MACHINE PRECISION, + + SPMPAR(2) = B**(EMIN - 1), THE SMALLEST MAGNITUDE, + + SPMPAR(3) = B**EMAX*(1 - B**(-M)), THE LARGEST MAGNITUDE. + +----------------------------------------------------------------------- + WRITTEN BY + ALFRED H. MORRIS, JR. + NAVAL SURFACE WARFARE CENTER + DAHLGREN VIRGINIA +----------------------------------------------------------------------- +----------------------------------------------------------------------- + MODIFIED BY BARRY W. BROWN TO RETURN DOUBLE PRECISION MACHINE + CONSTANTS FOR THE COMPUTER BEING USED. THIS MODIFICATION WAS + MADE AS PART OF CONVERTING BRATIO TO DOUBLE PRECISION +----------------------------------------------------------------------- +*/ +{ +static int K1 = 4; +static int K2 = 8; +static int K3 = 9; +static int K4 = 10; +static double spmpar,b,binv,bm1,one,w,z; +static int emax,emin,ibeta,m; +/* + .. + .. Executable Statements .. +*/ + if(*i > 1) goto S10; + b = ipmpar(&K1); + m = ipmpar(&K2); + spmpar = pow(b,(double)(1-m)); + return spmpar; +S10: + if(*i > 2) goto S20; + b = ipmpar(&K1); + emin = ipmpar(&K3); + one = 1.0; + binv = one/b; + w = pow(b,(double)(emin+2)); + spmpar = w*binv*binv*binv; + return spmpar; +S20: + ibeta = ipmpar(&K1); + m = ipmpar(&K2); + emax = ipmpar(&K4); + b = ibeta; + bm1 = ibeta-1; + one = 1.0; + z = pow(b,(double)(m-1)); + w = ((z-one)*b+bm1)/(b*z); + z = pow(b,(double)(emax-2)); + spmpar = w*z*b*b; + return spmpar; +} +double stvaln(double *p) +/* +********************************************************************** + + double stvaln(double *p) + STarting VALue for Neton-Raphon + calculation of Normal distribution Inverse + + + Function + + + Returns X such that CUMNOR(X) = P, i.e., the integral from - + infinity to X of (1/SQRT(2*PI)) EXP(-U*U/2) dU is P + + + Arguments + + + P --> The probability whose normal deviate is sought. + P is DOUBLE PRECISION + + + Method + + + The rational function on page 95 of Kennedy and Gentle, + Statistical Computing, Marcel Dekker, NY , 1980. + +********************************************************************** +*/ +{ +static double xden[5] = { + 0.993484626060e-1,0.588581570495e0,0.531103462366e0,0.103537752850e0, + 0.38560700634e-2 +}; +static double xnum[5] = { + -0.322232431088e0,-1.000000000000e0,-0.342242088547e0,-0.204231210245e-1, + -0.453642210148e-4 +}; +static int K1 = 5; +static double stvaln,sign,y,z; +/* + .. + .. Executable Statements .. +*/ + if(!(*p <= 0.5e0)) goto S10; + sign = -1.0e0; + z = *p; + goto S20; +S10: + sign = 1.0e0; + z = 1.0e0-*p; +S20: + y = sqrt(-(2.0e0*log(z))); + stvaln = y+devlpl(xnum,&K1,&y)/devlpl(xden,&K1,&y); + stvaln = sign*stvaln; + return stvaln; +} +/************************************************************************ +FIFDINT: +Truncates a double precision number to an integer and returns the +value in a double. +************************************************************************/ +double fifdint(double a) +/* a - number to be truncated */ +{ + long temp; + temp = (long)(a); + return (double)(temp); +} +/************************************************************************ +FIFDMAX1: +returns the maximum of two numbers a and b +************************************************************************/ +double fifdmax1(double a,double b) +/* a - first number */ +/* b - second number */ +{ + if (a < b) return b; + else return a; +} +/************************************************************************ +FIFDMIN1: +returns the minimum of two numbers a and b +************************************************************************/ +double fifdmin1(double a,double b) +/* a - first number */ +/* b - second number */ +{ + if (a < b) return a; + else return b; +} +/************************************************************************ +FIFDSIGN: +transfers the sign of the variable "sign" to the variable "mag" +************************************************************************/ +double fifdsign(double mag,double sign) +/* mag - magnitude */ +/* sign - sign to be transfered */ +{ + if (mag < 0) mag = -mag; + if (sign < 0) mag = -mag; + return mag; + +} +/************************************************************************ +FIFIDINT: +Truncates a double precision number to a long integer +************************************************************************/ +long fifidint(double a) +/* a - number to be truncated */ +{ + return (long)(a); +} +/************************************************************************ +FIFMOD: +returns the modulo of a and b +************************************************************************/ +long fifmod(long a,long b) +/* a - numerator */ +/* b - denominator */ +{ + return a % b; +} +/************************************************************************ +FTNSTOP: +Prints msg to standard error and then exits +************************************************************************/ +void ftnstop(char* msg) +/* msg - error message */ +{ + if (msg != NULL) fprintf(stderr,"%s\n",msg); + exit(EXIT_FAILURE); /* EXIT_FAILURE from stdlib.h, or use an int */ +} diff --git a/lib/dcdflib/ipmpar.c b/lib/dcdflib/ipmpar.c new file mode 100644 index 00000000..bdf42d92 --- /dev/null +++ b/lib/dcdflib/ipmpar.c @@ -0,0 +1,97 @@ +#include + +#include "limits.h" + +/* Edited 12/22/97 by Ben Pfaff for PSPP. */ + +int ipmpar(int*); +/* +----------------------------------------------------------------------- + + IPMPAR PROVIDES THE INTEGER MACHINE CONSTANTS FOR THE COMPUTER + THAT IS USED. IT IS ASSUMED THAT THE ARGUMENT I IS AN INTEGER + HAVING ONE OF THE VALUES 1-10. IPMPAR(I) HAS THE VALUE ... + + INTEGERS. + + ASSUME INTEGERS ARE REPRESENTED IN THE N-DIGIT, BASE-A FORM + + SIGN ( X(N-1)*A**(N-1) + ... + X(1)*A + X(0) ) + + WHERE 0 .LE. X(I) .LT. A FOR I=0,...,N-1. + + IPMPAR(1) = A, THE BASE. + + IPMPAR(2) = N, THE NUMBER OF BASE-A DIGITS. + + IPMPAR(3) = A**N - 1, THE LARGEST MAGNITUDE. + + FLOATING-POINT NUMBERS. + + IT IS ASSUMED THAT THE SINGLE AND DOUBLE PRECISION FLOATING + POINT ARITHMETICS HAVE THE SAME BASE, SAY B, AND THAT THE + NONZERO NUMBERS ARE REPRESENTED IN THE FORM + + SIGN (B**E) * (X(1)/B + ... + X(M)/B**M) + + WHERE X(I) = 0,1,...,B-1 FOR I=1,...,M, + X(1) .GE. 1, AND EMIN .LE. E .LE. EMAX. + + IPMPAR(4) = B, THE BASE. + + SINGLE-PRECISION + + IPMPAR(5) = M, THE NUMBER OF BASE-B DIGITS. + + IPMPAR(6) = EMIN, THE SMALLEST EXPONENT E. + + IPMPAR(7) = EMAX, THE LARGEST EXPONENT E. + + DOUBLE-PRECISION + + IPMPAR(8) = M, THE NUMBER OF BASE-B DIGITS. + + IPMPAR(9) = EMIN, THE SMALLEST EXPONENT E. + + IPMPAR(10) = EMAX, THE LARGEST EXPONENT E. + +----------------------------------------------------------------------- + + TO DEFINE THIS FUNCTION FOR THE COMPUTER BEING USED REMOVE + THE COMMENT DELIMITORS FROM THE DEFINITIONS DIRECTLY BELOW THE NAME + OF THE MACHINE + +----------------------------------------------------------------------- + + IPMPAR IS AN ADAPTATION OF THE FUNCTION I1MACH, WRITTEN BY + P.A. FOX, A.D. HALL, AND N.L. SCHRYER (BELL LABORATORIES). + IPMPAR WAS FORMED BY A.H. MORRIS (NSWC). THE CONSTANTS ARE + FROM BELL LABORATORIES, NSWC, AND OTHER SOURCES. + +----------------------------------------------------------------------- + .. Scalar Arguments .. +*/ +int ipmpar(int *i) +{ + static int imach[11]; + static int ipmpar; + + imach[1] = 2; + imach[2] = sizeof (long) * 8 - 1; + imach[3] = INT_MAX; + +#if FPREP==FPREP_IEEE754 + imach[4] = 2; + imach[5] = 24; + imach[6] = -125; + imach[7] = 128; + imach[8] = 53; + imach[9] = -1021; + imach[10] = 1024; +#else +#error Please define machine-specific constants for your machine. +#endif + + ipmpar = imach[*i]; + return ipmpar; +} diff --git a/lib/gmp/COPYING.LIB b/lib/gmp/COPYING.LIB new file mode 100644 index 00000000..92b8903f --- /dev/null +++ b/lib/gmp/COPYING.LIB @@ -0,0 +1,481 @@ + GNU LIBRARY GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + +[This is the first released version of the library GPL. It is + numbered 2 because it goes with version 2 of the ordinary GPL.] + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +Licenses are intended to guarantee your freedom to share and change +free software--to make sure the software is free for all its users. + + This license, the Library General Public License, applies to some +specially designated Free Software Foundation software, and to any +other libraries whose authors decide to use it. You can use it for +your libraries, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if +you distribute copies of the library, or if you modify it. + + For example, if you distribute copies of the library, whether gratis +or for a fee, you must give the recipients all the rights that we gave +you. You must make sure that they, too, receive or can get the source +code. If you link a program with the library, you must provide +complete object files to the recipients so that they can relink them +with the library, after making changes to the library and recompiling +it. And you must show them these terms so they know their rights. + + Our method of protecting your rights has two steps: (1) copyright +the library, and (2) offer you this license which gives you legal +permission to copy, distribute and/or modify the library. + + Also, for each distributor's protection, we want to make certain +that everyone understands that there is no warranty for this free +library. If the library is modified by someone else and passed on, we +want its recipients to know that what they have is not the original +version, so that any problems introduced by others will not reflect on +the original authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that companies distributing free +software will individually obtain patent licenses, thus in effect +transforming the program into proprietary software. To prevent this, +we have made it clear that any patent must be licensed for everyone's +free use or not licensed at all. + + Most GNU software, including some libraries, is covered by the ordinary +GNU General Public License, which was designed for utility programs. This +license, the GNU Library General Public License, applies to certain +designated libraries. This license is quite different from the ordinary +one; be sure to read it in full, and don't assume that anything in it is +the same as in the ordinary license. + + The reason we have a separate public license for some libraries is that +they blur the distinction we usually make between modifying or adding to a +program and simply using it. Linking a program with a library, without +changing the library, is in some sense simply using the library, and is +analogous to running a utility program or application program. However, in +a textual and legal sense, the linked executable is a combined work, a +derivative of the original library, and the ordinary General Public License +treats it as such. + + Because of this blurred distinction, using the ordinary General +Public License for libraries did not effectively promote software +sharing, because most developers did not use the libraries. We +concluded that weaker conditions might promote sharing better. + + However, unrestricted linking of non-free programs would deprive the +users of those programs of all benefit from the free status of the +libraries themselves. This Library General Public License is intended to +permit developers of non-free programs to use free libraries, while +preserving your freedom as a user of such programs to change the free +libraries that are incorporated in them. (We have not seen how to achieve +this as regards changes in header files, but we have achieved it as regards +changes in the actual functions of the Library.) The hope is that this +will lead to faster development of free libraries. + + The precise terms and conditions for copying, distribution and +modification follow. Pay close attention to the difference between a +"work based on the library" and a "work that uses the library". The +former contains code derived from the library, while the latter only +works together with the library. + + Note that it is possible for a library to be covered by the ordinary +General Public License rather than by this special one. + + GNU LIBRARY GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any software library which +contains a notice placed by the copyright holder or other authorized +party saying it may be distributed under the terms of this Library +General Public License (also called "this License"). Each licensee is +addressed as "you". + + A "library" means a collection of software functions and/or data +prepared so as to be conveniently linked with application programs +(which use some of those functions and data) to form executables. + + The "Library", below, refers to any such software library or work +which has been distributed under these terms. A "work based on the +Library" means either the Library or any derivative work under +copyright law: that is to say, a work containing the Library or a +portion of it, either verbatim or with modifications and/or translated +straightforwardly into another language. (Hereinafter, translation is +included without limitation in the term "modification".) + + "Source code" for a work means the preferred form of the work for +making modifications to it. For a library, complete source code means +all the source code for all modules it contains, plus any associated +interface definition files, plus the scripts used to control compilation +and installation of the library. + + Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running a program using the Library is not restricted, and output from +such a program is covered only if its contents constitute a work based +on the Library (independent of the use of the Library in a tool for +writing it). Whether that is true depends on what the Library does +and what the program that uses the Library does. + + 1. You may copy and distribute verbatim copies of the Library's +complete source code as you receive it, in any medium, provided that +you conspicuously and appropriately publish on each copy an +appropriate copyright notice and disclaimer of warranty; keep intact +all the notices that refer to this License and to the absence of any +warranty; and distribute a copy of this License along with the +Library. + + You may charge a fee for the physical act of transferring a copy, +and you may at your option offer warranty protection in exchange for a +fee. + + 2. You may modify your copy or copies of the Library or any portion +of it, thus forming a work based on the Library, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) The modified work must itself be a software library. + + b) You must cause the files modified to carry prominent notices + stating that you changed the files and the date of any change. + + c) You must cause the whole of the work to be licensed at no + charge to all third parties under the terms of this License. + + d) If a facility in the modified Library refers to a function or a + table of data to be supplied by an application program that uses + the facility, other than as an argument passed when the facility + is invoked, then you must make a good faith effort to ensure that, + in the event an application does not supply such function or + table, the facility still operates, and performs whatever part of + its purpose remains meaningful. + + (For example, a function in a library to compute square roots has + a purpose that is entirely well-defined independent of the + application. Therefore, Subsection 2d requires that any + application-supplied function or table used by this function must + be optional: if the application does not supply it, the square + root function must still compute square roots.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Library, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Library, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote +it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Library. + +In addition, mere aggregation of another work not based on the Library +with the Library (or with a work based on the Library) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may opt to apply the terms of the ordinary GNU General Public +License instead of this License to a given copy of the Library. To do +this, you must alter all the notices that refer to this License, so +that they refer to the ordinary GNU General Public License, version 2, +instead of to this License. (If a newer version than version 2 of the +ordinary GNU General Public License has appeared, then you can specify +that version instead if you wish.) Do not make any other change in +these notices. + + Once this change is made in a given copy, it is irreversible for +that copy, so the ordinary GNU General Public License applies to all +subsequent copies and derivative works made from that copy. + + This option is useful when you wish to copy part of the code of +the Library into a program that is not a library. + + 4. You may copy and distribute the Library (or a portion or +derivative of it, under Section 2) in object code or executable form +under the terms of Sections 1 and 2 above provided that you accompany +it with the complete corresponding machine-readable source code, which +must be distributed under the terms of Sections 1 and 2 above on a +medium customarily used for software interchange. + + If distribution of object code is made by offering access to copy +from a designated place, then offering equivalent access to copy the +source code from the same place satisfies the requirement to +distribute the source code, even though third parties are not +compelled to copy the source along with the object code. + + 5. A program that contains no derivative of any portion of the +Library, but is designed to work with the Library by being compiled or +linked with it, is called a "work that uses the Library". Such a +work, in isolation, is not a derivative work of the Library, and +therefore falls outside the scope of this License. + + However, linking a "work that uses the Library" with the Library +creates an executable that is a derivative of the Library (because it +contains portions of the Library), rather than a "work that uses the +library". The executable is therefore covered by this License. +Section 6 states terms for distribution of such executables. + + When a "work that uses the Library" uses material from a header file +that is part of the Library, the object code for the work may be a +derivative work of the Library even though the source code is not. +Whether this is true is especially significant if the work can be +linked without the Library, or if the work is itself a library. The +threshold for this to be true is not precisely defined by law. + + If such an object file uses only numerical parameters, data +structure layouts and accessors, and small macros and small inline +functions (ten lines or less in length), then the use of the object +file is unrestricted, regardless of whether it is legally a derivative +work. (Executables containing this object code plus portions of the +Library will still fall under Section 6.) + + Otherwise, if the work is a derivative of the Library, you may +distribute the object code for the work under the terms of Section 6. +Any executables containing that work also fall under Section 6, +whether or not they are linked directly with the Library itself. + + 6. As an exception to the Sections above, you may also compile or +link a "work that uses the Library" with the Library to produce a +work containing portions of the Library, and distribute that work +under terms of your choice, provided that the terms permit +modification of the work for the customer's own use and reverse +engineering for debugging such modifications. + + You must give prominent notice with each copy of the work that the +Library is used in it and that the Library and its use are covered by +this License. You must supply a copy of this License. If the work +during execution displays copyright notices, you must include the +copyright notice for the Library among them, as well as a reference +directing the user to the copy of this License. Also, you must do one +of these things: + + a) Accompany the work with the complete corresponding + machine-readable source code for the Library including whatever + changes were used in the work (which must be distributed under + Sections 1 and 2 above); and, if the work is an executable linked + with the Library, with the complete machine-readable "work that + uses the Library", as object code and/or source code, so that the + user can modify the Library and then relink to produce a modified + executable containing the modified Library. (It is understood + that the user who changes the contents of definitions files in the + Library will not necessarily be able to recompile the application + to use the modified definitions.) + + b) Accompany the work with a written offer, valid for at + least three years, to give the same user the materials + specified in Subsection 6a, above, for a charge no more + than the cost of performing this distribution. + + c) If distribution of the work is made by offering access to copy + from a designated place, offer equivalent access to copy the above + specified materials from the same place. + + d) Verify that the user has already received a copy of these + materials or that you have already sent this user a copy. + + For an executable, the required form of the "work that uses the +Library" must include any data and utility programs needed for +reproducing the executable from it. However, as a special exception, +the source code distributed need not include anything that is normally +distributed (in either source or binary form) with the major +components (compiler, kernel, and so on) of the operating system on +which the executable runs, unless that component itself accompanies +the executable. + + It may happen that this requirement contradicts the license +restrictions of other proprietary libraries that do not normally +accompany the operating system. Such a contradiction means you cannot +use both them and the Library together in an executable that you +distribute. + + 7. You may place library facilities that are a work based on the +Library side-by-side in a single library together with other library +facilities not covered by this License, and distribute such a combined +library, provided that the separate distribution of the work based on +the Library and of the other library facilities is otherwise +permitted, and provided that you do these two things: + + a) Accompany the combined library with a copy of the same work + based on the Library, uncombined with any other library + facilities. This must be distributed under the terms of the + Sections above. + + b) Give prominent notice with the combined library of the fact + that part of it is a work based on the Library, and explaining + where to find the accompanying uncombined form of the same work. + + 8. You may not copy, modify, sublicense, link with, or distribute +the Library except as expressly provided under this License. Any +attempt otherwise to copy, modify, sublicense, link with, or +distribute the Library is void, and will automatically terminate your +rights under this License. However, parties who have received copies, +or rights, from you under this License will not have their licenses +terminated so long as such parties remain in full compliance. + + 9. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Library or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Library (or any work based on the +Library), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Library or works based on it. + + 10. Each time you redistribute the Library (or any work based on the +Library), the recipient automatically receives a license from the +original licensor to copy, distribute, link with or modify the Library +subject to these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 11. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Library at all. For example, if a patent +license would not permit royalty-free redistribution of the Library by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Library. + +If any portion of this section is held invalid or unenforceable under any +particular circumstance, the balance of the section is intended to apply, +and the section as a whole is intended to apply in other circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 12. If the distribution and/or use of the Library is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Library under this License may add +an explicit geographical distribution limitation excluding those countries, +so that distribution is permitted only in or among countries not thus +excluded. In such case, this License incorporates the limitation as if +written in the body of this License. + + 13. The Free Software Foundation may publish revised and/or new +versions of the Library General Public License from time to time. +Such new versions will be similar in spirit to the present version, +but may differ in detail to address new problems or concerns. + +Each version is given a distinguishing version number. If the Library +specifies a version number of this License which applies to it and +"any later version", you have the option of following the terms and +conditions either of that version or of any later version published by +the Free Software Foundation. If the Library does not specify a +license version number, you may choose any version ever published by +the Free Software Foundation. + + 14. If you wish to incorporate parts of the Library into other free +programs whose distribution conditions are incompatible with these, +write to the author to ask for permission. For software which is +copyrighted by the Free Software Foundation, write to the Free +Software Foundation; we sometimes make exceptions for this. Our +decision will be guided by the two goals of preserving the free status +of all derivatives of our free software and of promoting the sharing +and reuse of software generally. + + NO WARRANTY + + 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO +WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. +EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR +OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY +KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE +LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME +THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN +WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY +AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU +FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR +CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE +LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING +RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A +FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF +SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH +DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Libraries + + If you develop a new library, and you want it to be of the greatest +possible use to the public, we recommend making it free software that +everyone can redistribute and change. You can do so by permitting +redistribution under these terms (or, alternatively, under the terms of the +ordinary General Public License). + + To apply these terms, attach the following notices to the library. It is +safest to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + 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! diff --git a/lib/gmp/ChangeLog b/lib/gmp/ChangeLog new file mode 100644 index 00000000..e398ea69 --- /dev/null +++ b/lib/gmp/ChangeLog @@ -0,0 +1,29 @@ +Mon Dec 14 11:52:05 1998 Ben Pfaff + + * Makefile.am, mpn/Makefile.am, mpf/Makefile.am: (INCLUDES) Add + -I$(top_srcdir)/intl. Thanks to OKUJI Yoshinori + . + +Thu Nov 19 12:35:13 1998 Ben Pfaff + + * Thanks to Hans Olav Eggestad and others + for reporting bug fixed below. + + * Makefile.am: (libgmp_a_SOURCES) Add mp_clz_tab.c. + + * longlong.h: Define LONGLONG_STANDALONE unconditionally since we + don't include architecture-specific directories. + + * mp_clz_tab.c: New file. + +Sun Aug 9 11:17:02 1998 Ben Pfaff + + * Makefile.am: Fixed for renamed file. + + * extract-double.c: Renamed extract-dbl.c. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/lib/gmp/INSTALL b/lib/gmp/INSTALL new file mode 100644 index 00000000..7e4ae38d --- /dev/null +++ b/lib/gmp/INSTALL @@ -0,0 +1,43 @@ +(Other sections omitted because they're not useful in use along with +PSPP. -blp) + +Known Build Problems +-------------------- + +Note that GCC 2.7.2 (as well as 2.6.3) for the RS/6000 and PowerPC can not +be used to compile GMP, due to a bug in GCC. If you want to use GCC, you +need to apply the patch at the end of this file, or use a later version of +the compiler. + +If you are on a Sequent Symmetry, use GAS instead of the system's assembler +due to the latter's serious bugs. + +The system compiler on NeXT is a massacred and old gcc, even if the +compiler calls itself cc. This compiler cannot be used to build GMP. You +need to get a real gcc, and install that before you compile GMP. (NeXT +might have fixed this in newer releases of their system.) + +Please report other problems to bug-gmp@prep.ai.mit.edu. + + +Patch to apply to GCC 2.6.3 and 2.7.2: + +*** config/rs6000/rs6000.md Sun Feb 11 08:22:11 1996 +--- config/rs6000/rs6000.md.new Sun Feb 18 03:33:37 1996 +*************** +*** 920,926 **** + (set (match_operand:SI 0 "gpc_reg_operand" "=r") + (not:SI (match_dup 1)))] + "" +! "nor. %0,%2,%1" + [(set_attr "type" "compare")]) + + (define_insn "" +--- 920,926 ---- + (set (match_operand:SI 0 "gpc_reg_operand" "=r") + (not:SI (match_dup 1)))] + "" +! "nor. %0,%1,%1" + [(set_attr "type" "compare")]) + + (define_insn "" diff --git a/lib/gmp/Makefile.am b/lib/gmp/Makefile.am new file mode 100644 index 00000000..b563f67b --- /dev/null +++ b/lib/gmp/Makefile.am @@ -0,0 +1,11 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +INCLUDES = -I$(srcdir) -I$(top_srcdir) -I$(top_srcdir)/src -I$(top_srcdir)/intl + +SUBDIRS = mpn mpf + +noinst_LIBRARIES = libgmp.a +libgmp_a_SOURCES = extract-dbl.c gmp-mparam.h longlong.h gmp-impl.h \ +gmp.h memory.c mp_clz_tab.c + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/gmp/extract-dbl.c b/lib/gmp/extract-dbl.c new file mode 100644 index 00000000..84bd661a --- /dev/null +++ b/lib/gmp/extract-dbl.c @@ -0,0 +1,161 @@ +/* __gmp_extract_double -- convert from double to array of mp_limb_t. + +Copyright (C) 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +#ifdef XDEBUG +#undef _GMP_IEEE_FLOATS +#endif + +#ifndef _GMP_IEEE_FLOATS +#define _GMP_IEEE_FLOATS 0 +#endif + +#define MP_BASE_AS_DOUBLE (2.0 * ((mp_limb_t) 1 << (BITS_PER_MP_LIMB - 1))) + +/* Extract a non-negative double in d. */ + +int +#if __STDC__ +__gmp_extract_double (mp_ptr rp, double d) +#else +__gmp_extract_double (rp, d) + mp_ptr rp; + double d; +#endif +{ + long exp; + unsigned sc; + mp_limb_t manh, manl; + + /* BUGS + + 1. Should handle Inf and NaN in IEEE specific code. + 2. Handle Inf and NaN also in default code, to avoid hangs. + 3. Generalize to handle all BITS_PER_MP_LIMB >= 32. + 4. This lits is incomplete and misspelled. + */ + + if (d == 0.0) + { + rp[0] = 0; + rp[1] = 0; +#if BITS_PER_MP_LIMB == 32 + rp[2] = 0; +#endif + return 0; + } + +#if _GMP_IEEE_FLOATS + { + union ieee_double_extract x; + x.d = d; + + exp = x.s.exp; + sc = (unsigned) (exp + 2) % BITS_PER_MP_LIMB; +#if BITS_PER_MP_LIMB == 64 + manl = (((mp_limb_t) 1 << 63) + | ((mp_limb_t) x.s.manh << 43) | ((mp_limb_t) x.s.manl << 11)); +#else + manh = ((mp_limb_t) 1 << 31) | (x.s.manh << 11) | (x.s.manl >> 21); + manl = x.s.manl << 11; +#endif + } +#else + { + /* Unknown (or known to be non-IEEE) double format. */ + exp = 0; + if (d >= 1.0) + { + if (d * 0.5 == d) + abort (); + + while (d >= 32768.0) + { + d *= (1.0 / 65536.0); + exp += 16; + } + while (d >= 1.0) + { + d *= 0.5; + exp += 1; + } + } + else if (d < 0.5) + { + while (d < (1.0 / 65536.0)) + { + d *= 65536.0; + exp -= 16; + } + while (d < 0.5) + { + d *= 2.0; + exp -= 1; + } + } + + sc = (unsigned) exp % BITS_PER_MP_LIMB; + + d *= MP_BASE_AS_DOUBLE; +#if BITS_PER_MP_LIMB == 64 + manl = d; +#else + manh = d; + manl = (d - manh) * MP_BASE_AS_DOUBLE; +#endif + + exp += 1022; + } +#endif + + exp = (unsigned) (exp + 1) / BITS_PER_MP_LIMB - 1024 / BITS_PER_MP_LIMB + 1; + +#if BITS_PER_MP_LIMB == 64 + if (sc != 0) + { + rp[1] = manl >> (BITS_PER_MP_LIMB - sc); + rp[0] = manl << sc; + } + else + { + rp[1] = manl; + rp[0] = 0; + } +#else + if (sc != 0) + { + rp[2] = manh >> (BITS_PER_MP_LIMB - sc); + rp[1] = (manl >> (BITS_PER_MP_LIMB - sc)) | (manh << sc); + rp[0] = manl << sc; + } + else + { + rp[2] = manh; + rp[1] = manl; + rp[0] = 0; + } +#endif + + return exp; +} diff --git a/lib/gmp/gmp-impl.h b/lib/gmp/gmp-impl.h new file mode 100644 index 00000000..a838ba65 --- /dev/null +++ b/lib/gmp/gmp-impl.h @@ -0,0 +1,374 @@ +/* Include file for internal GNU MP types and definitions. + +Copyright (C) 1991, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#if 0 /* PSPP has its own alloca */ +/* When using gcc, make sure to use its builtin alloca. */ +#if ! defined (alloca) && defined (__GNUC__) +#define alloca __builtin_alloca +#define HAVE_ALLOCA +#endif + +/* When using cc, do whatever necessary to allow use of alloca. For many + machines, this means including alloca.h. IBM's compilers need a #pragma + in "each module that needs to use alloca". */ +#if ! defined (alloca) +/* We need lots of variants for MIPS, to cover all versions and perversions + of OSes for MIPS. */ +#if defined (__mips) || defined (MIPSEL) || defined (MIPSEB) \ + || defined (_MIPSEL) || defined (_MIPSEB) || defined (__sgi) \ + || defined (__alpha) || defined (__sparc) || defined (sparc) \ + || defined (__ksr__) +#include +#define HAVE_ALLOCA +#endif +#if defined (_IBMR2) +#pragma alloca +#define HAVE_ALLOCA +#endif +#if defined (__DECC) +#define alloca(x) __ALLOCA(x) +#define HAVE_ALLOCA +#endif +#endif +#endif /* 0 */ + +#if ! defined (HAVE_ALLOCA) || USE_STACK_ALLOC +#include "stack-alloc.h" +#else +#define TMP_DECL(m) +#define TMP_ALLOC(x) alloca(x) +#define TMP_MARK(m) +#define TMP_FREE(m) +#endif + +#ifndef NULL +#define NULL ((void *) 0) +#endif + +#if ! defined (__GNUC__) +#define inline /* Empty */ +#endif + +#define ABS(x) (x >= 0 ? x : -x) +#define MIN(l,o) ((l) < (o) ? (l) : (o)) +#define MAX(h,i) ((h) > (i) ? (h) : (i)) + +/* Field access macros. */ +#define SIZ(x) ((x)->_mp_size) +#define ABSIZ(x) ABS (SIZ (x)) +#define PTR(x) ((x)->_mp_d) +#define EXP(x) ((x)->_mp_exp) +#define PREC(x) ((x)->_mp_prec) +#define ALLOC(x) ((x)->_mp_alloc) + +#include "gmp-mparam.h" +/* #include "longlong.h" */ + +#if defined (__STDC__) || defined (__cplusplus) +void *malloc (size_t); +void *realloc (void *, size_t); +void free (void *); + +extern void * (*_mp_allocate_func) (size_t); +extern void * (*_mp_reallocate_func) (void *, size_t, size_t); +extern void (*_mp_free_func) (void *, size_t); + +void *_mp_default_allocate (size_t); +void *_mp_default_reallocate (void *, size_t, size_t); +void _mp_default_free (void *, size_t); + +#else + +#define const /* Empty */ +#define signed /* Empty */ + +void *malloc (); +void *realloc (); +void free (); + +extern void * (*_mp_allocate_func) (); +extern void * (*_mp_reallocate_func) (); +extern void (*_mp_free_func) (); + +void *_mp_default_allocate (); +void *_mp_default_reallocate (); +void _mp_default_free (); +#endif + +/* Copy NLIMBS *limbs* from SRC to DST. */ +#define MPN_COPY_INCR(DST, SRC, NLIMBS) \ + do { \ + mp_size_t __i; \ + for (__i = 0; __i < (NLIMBS); __i++) \ + (DST)[__i] = (SRC)[__i]; \ + } while (0) +#define MPN_COPY_DECR(DST, SRC, NLIMBS) \ + do { \ + mp_size_t __i; \ + for (__i = (NLIMBS) - 1; __i >= 0; __i--) \ + (DST)[__i] = (SRC)[__i]; \ + } while (0) +#define MPN_COPY MPN_COPY_INCR + +/* Zero NLIMBS *limbs* AT DST. */ +#define MPN_ZERO(DST, NLIMBS) \ + do { \ + mp_size_t __i; \ + for (__i = 0; __i < (NLIMBS); __i++) \ + (DST)[__i] = 0; \ + } while (0) + +#define MPN_NORMALIZE(DST, NLIMBS) \ + do { \ + while (NLIMBS > 0) \ + { \ + if ((DST)[(NLIMBS) - 1] != 0) \ + break; \ + NLIMBS--; \ + } \ + } while (0) +#define MPN_NORMALIZE_NOT_ZERO(DST, NLIMBS) \ + do { \ + while (1) \ + { \ + if ((DST)[(NLIMBS) - 1] != 0) \ + break; \ + NLIMBS--; \ + } \ + } while (0) + +/* Initialize the MP_INT X with space for NLIMBS limbs. + X should be a temporary variable, and it will be automatically + cleared out when the running function returns. + We use __x here to make it possible to accept both mpz_ptr and mpz_t + arguments. */ +#define MPZ_TMP_INIT(X, NLIMBS) \ + do { \ + mpz_ptr __x = (X); \ + __x->_mp_alloc = (NLIMBS); \ + __x->_mp_d = (mp_ptr) TMP_ALLOC ((NLIMBS) * BYTES_PER_MP_LIMB); \ + } while (0) + +#define MPN_MUL_N_RECURSE(prodp, up, vp, size, tspace) \ + do { \ + if ((size) < KARATSUBA_THRESHOLD) \ + impn_mul_n_basecase (prodp, up, vp, size); \ + else \ + impn_mul_n (prodp, up, vp, size, tspace); \ + } while (0); +#define MPN_SQR_N_RECURSE(prodp, up, size, tspace) \ + do { \ + if ((size) < KARATSUBA_THRESHOLD) \ + impn_sqr_n_basecase (prodp, up, size); \ + else \ + impn_sqr_n (prodp, up, size, tspace); \ + } while (0); + +/* Structure for conversion between internal binary format and + strings in base 2..36. */ +struct bases +{ + /* Number of digits in the conversion base that always fits in an mp_limb_t. + For example, for base 10 on a machine where a mp_limb_t has 32 bits this + is 9, since 10**9 is the largest number that fits into a mp_limb_t. */ + int chars_per_limb; + + /* log(2)/log(conversion_base) */ + float chars_per_bit_exactly; + + /* base**chars_per_limb, i.e. the biggest number that fits a word, built by + factors of base. Exception: For 2, 4, 8, etc, big_base is log2(base), + i.e. the number of bits used to represent each digit in the base. */ + mp_limb_t big_base; + + /* A BITS_PER_MP_LIMB bit approximation to 1/big_base, represented as a + fixed-point number. Instead of dividing by big_base an application can + choose to multiply by big_base_inverted. */ + mp_limb_t big_base_inverted; +}; + +extern const struct bases __mp_bases[]; +extern mp_size_t __gmp_default_fp_limb_precision; + +/* Divide the two-limb number in (NH,,NL) by D, with DI being the largest + limb not larger than (2**(2*BITS_PER_MP_LIMB))/D - (2**BITS_PER_MP_LIMB). + If this would yield overflow, DI should be the largest possible number + (i.e., only ones). For correct operation, the most significant bit of D + has to be set. Put the quotient in Q and the remainder in R. */ +#define udiv_qrnnd_preinv(q, r, nh, nl, d, di) \ + do { \ + mp_limb_t _q, _ql, _r; \ + mp_limb_t _xh, _xl; \ + umul_ppmm (_q, _ql, (nh), (di)); \ + _q += (nh); /* DI is 2**BITS_PER_MP_LIMB too small */\ + umul_ppmm (_xh, _xl, _q, (d)); \ + sub_ddmmss (_xh, _r, (nh), (nl), _xh, _xl); \ + if (_xh != 0) \ + { \ + sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \ + _q += 1; \ + if (_xh != 0) \ + { \ + sub_ddmmss (_xh, _r, _xh, _r, 0, (d)); \ + _q += 1; \ + } \ + } \ + if (_r >= (d)) \ + { \ + _r -= (d); \ + _q += 1; \ + } \ + (r) = _r; \ + (q) = _q; \ + } while (0) +/* Like udiv_qrnnd_preinv, but for for any value D. DNORM is D shifted left + so that its most significant bit is set. LGUP is ceil(log2(D)). */ +#define udiv_qrnnd_preinv2gen(q, r, nh, nl, d, di, dnorm, lgup) \ + do { \ + mp_limb_t n2, n10, n1, nadj, q1; \ + mp_limb_t _xh, _xl; \ + n2 = ((nh) << (BITS_PER_MP_LIMB - (lgup))) + ((nl) >> 1 >> (l - 1));\ + n10 = (nl) << (BITS_PER_MP_LIMB - (lgup)); \ + n1 = ((mp_limb_signed_t) n10 >> (BITS_PER_MP_LIMB - 1)); \ + nadj = n10 + (n1 & (dnorm)); \ + umul_ppmm (_xh, _xl, di, n2 - n1); \ + add_ssaaaa (_xh, _xl, _xh, _xl, 0, nadj); \ + q1 = ~(n2 + _xh); \ + umul_ppmm (_xh, _xl, q1, d); \ + add_ssaaaa (_xh, _xl, _xh, _xl, nh, nl); \ + _xh -= (d); \ + (r) = _xl + ((d) & _xh); \ + (q) = _xh - q1; \ + } while (0) +/* Exactly like udiv_qrnnd_preinv, but branch-free. It is not clear which + version to use. */ +#define udiv_qrnnd_preinv2norm(q, r, nh, nl, d, di) \ + do { \ + mp_limb_t n2, n10, n1, nadj, q1; \ + mp_limb_t _xh, _xl; \ + n2 = (nh); \ + n10 = (nl); \ + n1 = ((mp_limb_signed_t) n10 >> (BITS_PER_MP_LIMB - 1)); \ + nadj = n10 + (n1 & (d)); \ + umul_ppmm (_xh, _xl, di, n2 - n1); \ + add_ssaaaa (_xh, _xl, _xh, _xl, 0, nadj); \ + q1 = ~(n2 + _xh); \ + umul_ppmm (_xh, _xl, q1, d); \ + add_ssaaaa (_xh, _xl, _xh, _xl, nh, nl); \ + _xh -= (d); \ + (r) = _xl + ((d) & _xh); \ + (q) = _xh - q1; \ + } while (0) + +#if defined (__GNUC__) +/* Define stuff for longlong.h. */ +typedef unsigned int UQItype __attribute__ ((mode (QI))); +typedef int SItype __attribute__ ((mode (SI))); +typedef unsigned int USItype __attribute__ ((mode (SI))); +typedef int DItype __attribute__ ((mode (DI))); +typedef unsigned int UDItype __attribute__ ((mode (DI))); +#else +typedef unsigned char UQItype; +typedef long SItype; +typedef unsigned long USItype; +#endif + +typedef mp_limb_t UWtype; +typedef unsigned int UHWtype; +#define W_TYPE_SIZE BITS_PER_MP_LIMB + +/* Internal mpn calls */ +#define impn_mul_n_basecase __MPN(impn_mul_n_basecase) +#define impn_mul_n __MPN(impn_mul_n) +#define impn_sqr_n_basecase __MPN(impn_sqr_n_basecase) +#define impn_sqr_n __MPN(impn_sqr_n) + +void impn_mul_n_basecase (mp_ptr prodp, mp_srcptr up, mp_srcptr vp, + mp_size_t size); +void impn_mul_n (mp_ptr prodp, mp_srcptr up, mp_srcptr vp, mp_size_t size, + mp_ptr tspace); + +/* Define ieee_double_extract and _GMP_IEEE_FLOATS. */ + +#if defined (_LITTLE_ENDIAN) || defined (__LITTLE_ENDIAN__) \ + || defined (__alpha) \ + || (defined (__arm__) && defined (__ARMWEL__)) \ + || defined (__clipper__) \ + || defined (__cris) \ + || defined (__i386__) \ + || defined (__i860__) \ + || defined (__i960__) \ + || defined (MIPSEL) || defined (_MIPSEL) \ + || defined (__ns32000__) \ + || defined (__WINNT) || defined (_WIN32) +#define _GMP_IEEE_FLOATS 1 +union ieee_double_extract +{ + struct + { + unsigned int manl:32; + unsigned int manh:20; + unsigned int exp:11; + unsigned int sig:1; + } s; + double d; +}; +#else /* Need this as an #else since the tests aren't made exclusive. */ +#if defined (_BIG_ENDIAN) \ + || defined (__a29k__) || defined (_AM29K) \ + || defined (__arm__) \ + || (defined (__convex__) && defined (_IEEE_FLOAT_)) \ + || defined (__i370__) || defined (__mvs__) \ + || defined (__mc68000__) || defined (__mc68020__) || defined (__NeXT__)\ + || defined(mc68020) \ + || defined (__m88000__) \ + || defined (MIPSEB) || defined (_MIPSEB) \ + || defined (__hppa) \ + || defined (__pyr__) \ + || defined (__ibm032__) \ + || defined (_IBMR2) || defined (_ARCH_PPC) \ + || defined (__sh__) \ + || defined (__sparc) || defined (sparc) \ + || defined (__we32k__) +#define _GMP_IEEE_FLOATS 1 +union ieee_double_extract +{ + struct + { + unsigned int sig:1; + unsigned int exp:11; + unsigned int manh:20; + unsigned int manl:32; + } s; + double d; +}; +#endif +#endif + +#define MP_BASE_AS_DOUBLE (2.0 * ((mp_limb_t) 1 << (BITS_PER_MP_LIMB - 1))) +#if BITS_PER_MP_LIMB == 64 +#define LIMBS_PER_DOUBLE 2 +#else +#define LIMBS_PER_DOUBLE 3 +#endif + +double __gmp_scale2 _PROTO ((double, int)); +int __gmp_extract_double _PROTO((mp_ptr, double)); diff --git a/lib/gmp/gmp-mparam.h b/lib/gmp/gmp-mparam.h new file mode 100644 index 00000000..f3cbe781 --- /dev/null +++ b/lib/gmp/gmp-mparam.h @@ -0,0 +1,27 @@ +/* gmp-mparam.h -- Compiler/machine parameter header file. + +Copyright (C) 1991, 1993, 1994 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#define BITS_PER_MP_LIMB (8 * SIZEOF_LONG) +#define BYTES_PER_MP_LIMB SIZEOF_LONG +#define BITS_PER_LONGINT (8 * SIZEOF_LONG) +#define BITS_PER_INT (8 * SIZEOF_INT) +#define BITS_PER_SHORTINT (8 * SIZEOF_SHORT) +#define BITS_PER_CHAR 8 diff --git a/lib/gmp/gmp.h b/lib/gmp/gmp.h new file mode 100644 index 00000000..a1cc1ac7 --- /dev/null +++ b/lib/gmp/gmp.h @@ -0,0 +1,632 @@ +/* gmp.h -- Definitions for GNU multiple precision functions. + +Copyright (C) 1991, 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#ifndef __GMP_H__ + +#ifndef __GNU_MP__ +#define __GNU_MP__ 2 +#define __need_size_t +#include +#undef __need_size_t + +#if defined (__STDC__) || defined (__cplusplus) +#define __gmp_const const +#else +#define __gmp_const +#endif + +#if defined (__GNUC__) +#define __gmp_inline __inline__ +#else +#define __gmp_inline +#endif + +#ifndef _EXTERN_INLINE +#ifdef __GNUC__ +#define _EXTERN_INLINE extern __inline__ +#else +#define _EXTERN_INLINE static +#endif +#endif + +#ifdef _SHORT_LIMB +typedef unsigned int mp_limb_t; +typedef int mp_limb_signed_t; +#else +#ifdef _LONG_LONG_LIMB +typedef unsigned long long int mp_limb_t; +typedef long long int mp_limb_signed_t; +#else +typedef unsigned long int mp_limb_t; +typedef long int mp_limb_signed_t; +#endif +#endif + +typedef mp_limb_t * mp_ptr; +typedef __gmp_const mp_limb_t * mp_srcptr; +typedef long int mp_size_t; +typedef long int mp_exp_t; + +#ifndef __MP_SMALL__ +typedef struct +{ + int _mp_alloc; /* Number of *limbs* allocated and pointed + to by the D field. */ + int _mp_size; /* abs(SIZE) is the number of limbs + the last field points to. If SIZE + is negative this is a negative + number. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpz_struct; +#else +typedef struct +{ + short int _mp_alloc; /* Number of *limbs* allocated and pointed + to by the D field. */ + short int _mp_size; /* abs(SIZE) is the number of limbs + the last field points to. If SIZE + is negative this is a negative + number. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpz_struct; +#endif +#endif /* __GNU_MP__ */ + +/* User-visible types. */ +typedef __mpz_struct MP_INT; +typedef __mpz_struct mpz_t[1]; + +/* Structure for rational numbers. Zero is represented as 0/any, i.e. + the denominator is ignored. Negative numbers have the sign in + the numerator. */ +typedef struct +{ + __mpz_struct _mp_num; + __mpz_struct _mp_den; +#if 0 + int _mp_num_alloc; /* Number of limbs allocated + for the numerator. */ + int _mp_num_size; /* The absolute value of this field is the + length of the numerator; the sign is the + sign of the entire rational number. */ + mp_ptr _mp_num; /* Pointer to the numerator limbs. */ + int _mp_den_alloc; /* Number of limbs allocated + for the denominator. */ + int _mp_den_size; /* Length of the denominator. (This field + should always be positive.) */ + mp_ptr _mp_den; /* Pointer to the denominator limbs. */ +#endif +} __mpq_struct; + +typedef __mpq_struct MP_RAT; +typedef __mpq_struct mpq_t[1]; + +typedef struct +{ + int _mp_prec; /* Max precision, in number of `mp_limb_t's. + Set by mpf_init and modified by + mpf_set_prec. The area pointed to + by the `d' field contains `prec' + 1 + limbs. */ + int _mp_size; /* abs(SIZE) is the number of limbs + the last field points to. If SIZE + is negative this is a negative + number. */ + mp_exp_t _mp_exp; /* Exponent, in the base of `mp_limb_t'. */ + mp_limb_t *_mp_d; /* Pointer to the limbs. */ +} __mpf_struct; + +/* typedef __mpf_struct MP_FLOAT; */ +typedef __mpf_struct mpf_t[1]; + +/* Types for function declarations in gmp files. */ +/* ??? Should not pollute user name space with these ??? */ +typedef __gmp_const __mpz_struct *mpz_srcptr; +typedef __mpz_struct *mpz_ptr; +typedef __gmp_const __mpf_struct *mpf_srcptr; +typedef __mpf_struct *mpf_ptr; +typedef __gmp_const __mpq_struct *mpq_srcptr; +typedef __mpq_struct *mpq_ptr; + +#ifndef _PROTO +#if defined (__STDC__) || defined (__cplusplus) +#define _PROTO(x) x +#else +#define _PROTO(x) () +#endif +#endif + +#ifndef __MPN +#if defined (__STDC__) || defined (__cplusplus) +#define __MPN(x) __mpn_##x +#else +#define __MPN(x) __mpn_/**/x +#endif +#endif + +#if defined (FILE) || defined (H_STDIO) || defined (_H_STDIO) \ + || defined (_STDIO_H) || defined (_STDIO_H_) || defined (__STDIO_H__) \ + || defined (_STDIO_INCLUDED) +#define _GMP_H_HAVE_FILE 1 +#endif + +void mp_set_memory_functions _PROTO ((void *(*) (size_t), + void *(*) (void *, size_t, size_t), + void (*) (void *, size_t))); +extern __gmp_const int mp_bits_per_limb; + +/**************** Integer (i.e. Z) routines. ****************/ + +#if defined (__cplusplus) +extern "C" { +#endif +void *_mpz_realloc _PROTO ((mpz_ptr, mp_size_t)); + +void mpz_abs _PROTO ((mpz_ptr, mpz_srcptr)); +void mpz_add _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_add_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_and _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_array_init _PROTO ((mpz_ptr, mp_size_t, mp_size_t)); +void mpz_cdiv_q _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +unsigned long int mpz_cdiv_q_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_cdiv_qr _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr)); +unsigned long int mpz_cdiv_qr_ui _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_cdiv_r _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +unsigned long int mpz_cdiv_r_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +unsigned long int mpz_cdiv_ui _PROTO ((mpz_srcptr, unsigned long int)); +void mpz_clear _PROTO ((mpz_ptr)); +void mpz_clrbit _PROTO ((mpz_ptr, unsigned long int)); +int mpz_cmp _PROTO ((mpz_srcptr, mpz_srcptr)); +int mpz_cmp_si _PROTO ((mpz_srcptr, signed long int)); +int mpz_cmp_ui _PROTO ((mpz_srcptr, unsigned long int)); +void mpz_com _PROTO ((mpz_ptr, mpz_srcptr)); +void mpz_divexact _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_fac_ui _PROTO ((mpz_ptr, unsigned long int)); +void mpz_fdiv_q _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_fdiv_q_2exp _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +unsigned long int mpz_fdiv_q_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_fdiv_qr _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr)); +unsigned long int mpz_fdiv_qr_ui _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_fdiv_r _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_fdiv_r_2exp _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +unsigned long int mpz_fdiv_r_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +unsigned long int mpz_fdiv_ui _PROTO ((mpz_srcptr, unsigned long int)); +void mpz_gcd _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +unsigned long int mpz_gcd_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_gcdext _PROTO ((mpz_ptr, mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr)); +double mpz_get_d _PROTO ((mpz_srcptr)); +/* signed */ long int mpz_get_si _PROTO ((mpz_srcptr)); +char *mpz_get_str _PROTO ((char *, int, mpz_srcptr)); +unsigned long int mpz_get_ui _PROTO ((mpz_srcptr)); +mp_limb_t mpz_getlimbn _PROTO ((mpz_srcptr, mp_size_t)); +unsigned long int mpz_hamdist _PROTO ((mpz_srcptr, mpz_srcptr)); +void mpz_init _PROTO ((mpz_ptr)); +#ifdef _GMP_H_HAVE_FILE +size_t mpz_inp_binary _PROTO ((mpz_ptr, FILE *)); +size_t mpz_inp_raw _PROTO ((mpz_ptr, FILE *)); +size_t mpz_inp_str _PROTO ((mpz_ptr, FILE *, int)); +#endif +void mpz_init_set _PROTO ((mpz_ptr, mpz_srcptr)); +void mpz_init_set_d _PROTO ((mpz_ptr, double)); +void mpz_init_set_si _PROTO ((mpz_ptr, signed long int)); +int mpz_init_set_str _PROTO ((mpz_ptr, const char *, int)); +void mpz_init_set_ui _PROTO ((mpz_ptr, unsigned long int)); +int mpz_invert _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_ior _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +int mpz_jacobi _PROTO ((mpz_srcptr, mpz_srcptr)); +int mpz_legendre _PROTO ((mpz_srcptr, mpz_srcptr)); +void mpz_mod _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_mul _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_mul_2exp _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_mul_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_neg _PROTO ((mpz_ptr, mpz_srcptr)); +#ifdef _GMP_H_HAVE_FILE +size_t mpz_out_binary _PROTO ((FILE *, mpz_srcptr)); +size_t mpz_out_raw _PROTO ((FILE *, mpz_srcptr)); +size_t mpz_out_str _PROTO ((FILE *, int, mpz_srcptr)); +#endif +int mpz_perfect_square_p _PROTO ((mpz_srcptr)); +unsigned long int mpz_popcount _PROTO ((mpz_srcptr)); +void mpz_pow_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_powm _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr, mpz_srcptr)); +void mpz_powm_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int, mpz_srcptr)); +int mpz_probab_prime_p _PROTO ((mpz_srcptr, int)); +void mpz_random _PROTO ((mpz_ptr, mp_size_t)); +void mpz_random2 _PROTO ((mpz_ptr, mp_size_t)); +unsigned long int mpz_scan0 _PROTO ((mpz_srcptr, unsigned long int)); +unsigned long int mpz_scan1 _PROTO ((mpz_srcptr, unsigned long int)); +void mpz_set _PROTO ((mpz_ptr, mpz_srcptr)); +void mpz_set_d _PROTO ((mpz_ptr, double)); +void mpz_set_f _PROTO ((mpz_ptr, mpf_srcptr)); +void mpz_set_q _PROTO ((mpz_ptr, mpq_srcptr)); +void mpz_set_si _PROTO ((mpz_ptr, signed long int)); +int mpz_set_str _PROTO ((mpz_ptr, const char *, int)); +void mpz_set_ui _PROTO ((mpz_ptr, unsigned long int)); +void mpz_setbit _PROTO ((mpz_ptr, unsigned long int)); +size_t mpz_size _PROTO ((mpz_srcptr)); +size_t mpz_sizeinbase _PROTO ((mpz_srcptr, int)); +void mpz_sqrt _PROTO ((mpz_ptr, mpz_srcptr)); +void mpz_sqrtrem _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr)); +void mpz_sub _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_sub_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_tdiv_q _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_tdiv_q_2exp _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_tdiv_q_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_tdiv_qr _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_tdiv_qr_ui _PROTO ((mpz_ptr, mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_tdiv_r _PROTO ((mpz_ptr, mpz_srcptr, mpz_srcptr)); +void mpz_tdiv_r_2exp _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_tdiv_r_ui _PROTO ((mpz_ptr, mpz_srcptr, unsigned long int)); +void mpz_ui_pow_ui _PROTO ((mpz_ptr, unsigned long int, unsigned long int)); + +/**************** Rational (i.e. Q) routines. ****************/ + +void mpq_init _PROTO ((mpq_ptr)); +void mpq_clear _PROTO ((mpq_ptr)); +void mpq_set _PROTO ((mpq_ptr, mpq_srcptr)); +void mpq_set_ui _PROTO ((mpq_ptr, unsigned long int, unsigned long int)); +void mpq_set_si _PROTO ((mpq_ptr, signed long int, unsigned long int)); +void mpq_set_z _PROTO ((mpq_ptr, mpz_srcptr)); +void mpq_add _PROTO ((mpq_ptr, mpq_srcptr, mpq_srcptr)); +void mpq_sub _PROTO ((mpq_ptr, mpq_srcptr, mpq_srcptr)); +void mpq_mul _PROTO ((mpq_ptr, mpq_srcptr, mpq_srcptr)); +void mpq_div _PROTO ((mpq_ptr, mpq_srcptr, mpq_srcptr)); +void mpq_neg _PROTO ((mpq_ptr, mpq_srcptr)); +int mpq_cmp _PROTO ((mpq_srcptr, mpq_srcptr)); +int mpq_cmp_ui _PROTO ((mpq_srcptr, unsigned long int, unsigned long int)); +int mpq_equal _PROTO ((mpq_srcptr, mpq_srcptr)); +void mpq_inv _PROTO ((mpq_ptr, mpq_srcptr)); +void mpq_set_num _PROTO ((mpq_ptr, mpz_srcptr)); +void mpq_set_den _PROTO ((mpq_ptr, mpz_srcptr)); +void mpq_get_num _PROTO ((mpz_ptr, mpq_srcptr)); +void mpq_get_den _PROTO ((mpz_ptr, mpq_srcptr)); +double mpq_get_d _PROTO ((mpq_srcptr)); +void mpq_canonicalize _PROTO ((mpq_ptr)); + +/**************** Float (i.e. F) routines. ****************/ + +void mpf_abs _PROTO ((mpf_ptr, mpf_srcptr)); +void mpf_add _PROTO ((mpf_ptr, mpf_srcptr, mpf_srcptr)); +void mpf_add_ui _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_clear _PROTO ((mpf_ptr)); +int mpf_cmp _PROTO ((mpf_srcptr, mpf_srcptr)); +int mpf_cmp_si _PROTO ((mpf_srcptr, signed long int)); +int mpf_cmp_ui _PROTO ((mpf_srcptr, unsigned long int)); +void mpf_div _PROTO ((mpf_ptr, mpf_srcptr, mpf_srcptr)); +void mpf_div_2exp _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_div_ui _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_dump _PROTO ((mpf_srcptr)); +int mpf_eq _PROTO ((mpf_srcptr, mpf_srcptr, unsigned long int)); +double mpf_get_d _PROTO ((mpf_srcptr)); +unsigned long int mpf_get_prec _PROTO ((mpf_srcptr)); +char *mpf_get_str _PROTO ((char *, mp_exp_t *, int, size_t, mpf_srcptr)); +void mpf_init _PROTO ((mpf_ptr)); +void mpf_init2 _PROTO ((mpf_ptr, unsigned long int)); +#ifdef _GMP_H_HAVE_FILE +size_t mpf_inp_str _PROTO ((mpf_ptr, FILE *, int)); +#endif +void mpf_init_set _PROTO ((mpf_ptr, mpf_srcptr)); +void mpf_init_set_d _PROTO ((mpf_ptr, double)); +void mpf_init_set_si _PROTO ((mpf_ptr, signed long int)); +int mpf_init_set_str _PROTO ((mpf_ptr, const char *, int)); +void mpf_init_set_ui _PROTO ((mpf_ptr, unsigned long int)); +void mpf_mul _PROTO ((mpf_ptr, mpf_srcptr, mpf_srcptr)); +void mpf_mul_2exp _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_mul_ui _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_neg _PROTO ((mpf_ptr, mpf_srcptr)); +#ifdef _GMP_H_HAVE_FILE +size_t mpf_out_str _PROTO ((FILE *, int, size_t, mpf_srcptr)); +#endif +void mpf_random2 _PROTO ((mpf_ptr, mp_size_t, mp_exp_t)); +void mpf_reldiff _PROTO ((mpf_ptr, mpf_srcptr, mpf_srcptr)); +void mpf_set _PROTO ((mpf_ptr, mpf_srcptr)); +void mpf_set_d _PROTO ((mpf_ptr, double)); +void mpf_set_default_prec _PROTO ((unsigned long int)); +void mpf_set_prec _PROTO ((mpf_ptr, unsigned long int)); +void mpf_set_prec_raw _PROTO ((mpf_ptr, unsigned long int)); +void mpf_set_q _PROTO ((mpf_ptr, mpq_srcptr)); +void mpf_set_si _PROTO ((mpf_ptr, signed long int)); +int mpf_set_str _PROTO ((mpf_ptr, const char *, int)); +void mpf_set_ui _PROTO ((mpf_ptr, unsigned long int)); +void mpf_set_z _PROTO ((mpf_ptr, mpz_srcptr)); +size_t mpf_size _PROTO ((mpf_srcptr)); +void mpf_sqrt _PROTO ((mpf_ptr, mpf_srcptr)); +void mpf_sqrt_ui _PROTO ((mpf_ptr, unsigned long int)); +void mpf_sub _PROTO ((mpf_ptr, mpf_srcptr, mpf_srcptr)); +void mpf_sub_ui _PROTO ((mpf_ptr, mpf_srcptr, unsigned long int)); +void mpf_ui_div _PROTO ((mpf_ptr, unsigned long int, mpf_srcptr)); +void mpf_ui_sub _PROTO ((mpf_ptr, unsigned long int, mpf_srcptr)); +#if defined (__cplusplus) +} +#endif +/************ Low level positive-integer (i.e. N) routines. ************/ + +/* This is ugly, but we need to make usr calls reach the prefixed function. */ +#define mpn_add __MPN(add) +#define mpn_add_1 __MPN(add_1) +#define mpn_add_n __MPN(add_n) +#define mpn_addmul_1 __MPN(addmul_1) +#define mpn_bdivmod __MPN(bdivmod) +#define mpn_cmp __MPN(cmp) +#define mpn_divmod_1 __MPN(divmod_1) +#define mpn_divrem __MPN(divrem) +#define mpn_divrem_1 __MPN(divrem_1) +#define mpn_dump __MPN(dump) +#define mpn_gcd __MPN(gcd) +#define mpn_gcd_1 __MPN(gcd_1) +#define mpn_gcdext __MPN(gcdext) +#define mpn_get_str __MPN(get_str) +#define mpn_hamdist __MPN(hamdist) +#define mpn_lshift __MPN(lshift) +#define mpn_mod_1 __MPN(mod_1) +#define mpn_mul __MPN(mul) +#define mpn_mul_1 __MPN(mul_1) +#define mpn_mul_n __MPN(mul_n) +#define mpn_perfect_square_p __MPN(perfect_square_p) +#define mpn_popcount __MPN(popcount) +#define mpn_preinv_mod_1 __MPN(preinv_mod_1) +#define mpn_random2 __MPN(random2) +#define mpn_rshift __MPN(rshift) +#define mpn_scan0 __MPN(scan0) +#define mpn_scan1 __MPN(scan1) +#define mpn_set_str __MPN(set_str) +#define mpn_sqrtrem __MPN(sqrtrem) +#define mpn_sub __MPN(sub) +#define mpn_sub_1 __MPN(sub_1) +#define mpn_sub_n __MPN(sub_n) +#define mpn_submul_1 __MPN(submul_1) +#define mpn_udiv_w_sdiv __MPN(udiv_w_sdiv) + +#if defined (__cplusplus) +extern "C" { +#endif +mp_limb_t mpn_add _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_srcptr,mp_size_t)); +mp_limb_t mpn_add_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +mp_limb_t mpn_add_n _PROTO ((mp_ptr, mp_srcptr, mp_srcptr, mp_size_t)); +mp_limb_t mpn_addmul_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +mp_limb_t mpn_bdivmod _PROTO ((mp_ptr, mp_ptr, mp_size_t, mp_srcptr, mp_size_t, unsigned long int)); +int mpn_cmp _PROTO ((mp_srcptr, mp_srcptr, mp_size_t)); +mp_limb_t mpn_divmod_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +mp_limb_t mpn_divrem _PROTO ((mp_ptr, mp_size_t, mp_ptr, mp_size_t, mp_srcptr, mp_size_t)); +mp_limb_t mpn_divrem_1 _PROTO ((mp_ptr, mp_size_t, mp_srcptr, mp_size_t, mp_limb_t)); +void mpn_dump _PROTO ((mp_srcptr, mp_size_t)); +mp_size_t mpn_gcd _PROTO ((mp_ptr, mp_ptr, mp_size_t, mp_ptr, mp_size_t)); +mp_limb_t mpn_gcd_1 _PROTO ((mp_srcptr, mp_size_t, mp_limb_t)); +mp_size_t mpn_gcdext _PROTO ((mp_ptr, mp_ptr, mp_ptr, mp_size_t, mp_ptr, mp_size_t)); +size_t mpn_get_str _PROTO ((unsigned char *, int, mp_ptr, mp_size_t)); +unsigned long int mpn_hamdist _PROTO ((mp_srcptr, mp_srcptr, mp_size_t)); +mp_limb_t mpn_lshift _PROTO ((mp_ptr, mp_srcptr, mp_size_t, unsigned int)); +mp_limb_t mpn_mod_1 _PROTO ((mp_srcptr, mp_size_t, mp_limb_t)); +mp_limb_t mpn_mul _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_srcptr, mp_size_t)); +mp_limb_t mpn_mul_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +void mpn_mul_n _PROTO ((mp_ptr, mp_srcptr, mp_srcptr, mp_size_t)); +int mpn_perfect_square_p _PROTO ((mp_srcptr, mp_size_t)); +unsigned long int mpn_popcount _PROTO ((mp_srcptr, mp_size_t)); +mp_limb_t mpn_preinv_mod_1 _PROTO ((mp_srcptr, mp_size_t, mp_limb_t, mp_limb_t)); +void mpn_random2 _PROTO ((mp_ptr, mp_size_t)); +mp_limb_t mpn_rshift _PROTO ((mp_ptr, mp_srcptr, mp_size_t, unsigned int)); +unsigned long int mpn_scan0 _PROTO ((mp_srcptr, unsigned long int)); +unsigned long int mpn_scan1 _PROTO ((mp_srcptr, unsigned long int)); +mp_size_t mpn_set_str _PROTO ((mp_ptr, const unsigned char *, size_t, int)); +mp_size_t mpn_sqrtrem _PROTO ((mp_ptr, mp_ptr, mp_srcptr, mp_size_t)); +mp_limb_t mpn_sub _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_srcptr,mp_size_t)); +mp_limb_t mpn_sub_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +mp_limb_t mpn_sub_n _PROTO ((mp_ptr, mp_srcptr, mp_srcptr, mp_size_t)); +mp_limb_t mpn_submul_1 _PROTO ((mp_ptr, mp_srcptr, mp_size_t, mp_limb_t)); +#if defined (__cplusplus) +} +#endif + +#if defined (__GNUC__) || defined (_FORCE_INLINES) +_EXTERN_INLINE mp_limb_t +#if defined (__STDC__) || defined (__cplusplus) +mpn_add_1 (register mp_ptr res_ptr, + register mp_srcptr s1_ptr, + register mp_size_t s1_size, + register mp_limb_t s2_limb) +#else +mpn_add_1 (res_ptr, s1_ptr, s1_size, s2_limb) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_size_t s1_size; + register mp_limb_t s2_limb; +#endif +{ + register mp_limb_t x; + + x = *s1_ptr++; + s2_limb = x + s2_limb; + *res_ptr++ = s2_limb; + if (s2_limb < x) + { + while (--s1_size != 0) + { + x = *s1_ptr++ + 1; + *res_ptr++ = x; + if (x != 0) + goto fin; + } + + return 1; + } + + fin: + if (res_ptr != s1_ptr) + { + mp_size_t i; + for (i = 0; i < s1_size - 1; i++) + res_ptr[i] = s1_ptr[i]; + } + return 0; +} + +_EXTERN_INLINE mp_limb_t +#if defined (__STDC__) || defined (__cplusplus) +mpn_add (register mp_ptr res_ptr, + register mp_srcptr s1_ptr, + register mp_size_t s1_size, + register mp_srcptr s2_ptr, + register mp_size_t s2_size) +#else +mpn_add (res_ptr, s1_ptr, s1_size, s2_ptr, s2_size) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_size_t s1_size; + register mp_srcptr s2_ptr; + register mp_size_t s2_size; +#endif +{ + mp_limb_t cy_limb = 0; + + if (s2_size != 0) + cy_limb = mpn_add_n (res_ptr, s1_ptr, s2_ptr, s2_size); + + if (s1_size - s2_size != 0) + cy_limb = mpn_add_1 (res_ptr + s2_size, + s1_ptr + s2_size, + s1_size - s2_size, + cy_limb); + return cy_limb; +} + +_EXTERN_INLINE mp_limb_t +#if defined (__STDC__) || defined (__cplusplus) +mpn_sub_1 (register mp_ptr res_ptr, + register mp_srcptr s1_ptr, + register mp_size_t s1_size, + register mp_limb_t s2_limb) +#else +mpn_sub_1 (res_ptr, s1_ptr, s1_size, s2_limb) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_size_t s1_size; + register mp_limb_t s2_limb; +#endif +{ + register mp_limb_t x; + + x = *s1_ptr++; + s2_limb = x - s2_limb; + *res_ptr++ = s2_limb; + if (s2_limb > x) + { + while (--s1_size != 0) + { + x = *s1_ptr++; + *res_ptr++ = x - 1; + if (x != 0) + goto fin; + } + + return 1; + } + + fin: + if (res_ptr != s1_ptr) + { + mp_size_t i; + for (i = 0; i < s1_size - 1; i++) + res_ptr[i] = s1_ptr[i]; + } + return 0; +} + +_EXTERN_INLINE mp_limb_t +#if defined (__STDC__) || defined (__cplusplus) +mpn_sub (register mp_ptr res_ptr, + register mp_srcptr s1_ptr, + register mp_size_t s1_size, + register mp_srcptr s2_ptr, + register mp_size_t s2_size) +#else +mpn_sub (res_ptr, s1_ptr, s1_size, s2_ptr, s2_size) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_size_t s1_size; + register mp_srcptr s2_ptr; + register mp_size_t s2_size; +#endif +{ + mp_limb_t cy_limb = 0; + + if (s2_size != 0) + cy_limb = mpn_sub_n (res_ptr, s1_ptr, s2_ptr, s2_size); + + if (s1_size - s2_size != 0) + cy_limb = mpn_sub_1 (res_ptr + s2_size, + s1_ptr + s2_size, + s1_size - s2_size, + cy_limb); + return cy_limb; +} +#endif /* __GNUC__ */ + +/* Allow faster testing for negative, zero, and positive. */ +#define mpz_sgn(Z) ((Z)->_mp_size < 0 ? -1 : (Z)->_mp_size > 0) +#define mpf_sgn(F) ((F)->_mp_size < 0 ? -1 : (F)->_mp_size > 0) +#define mpq_sgn(Q) ((Q)->_mp_num._mp_size < 0 ? -1 : (Q)->_mp_num._mp_size > 0) + +/* Allow direct user access to numerator and denominator of a mpq_t object. */ +#define mpq_numref(Q) (&((Q)->_mp_num)) +#define mpq_denref(Q) (&((Q)->_mp_den)) + +/* When using GCC, optimize certain common comparisons. */ +#if defined (__GNUC__) +#define mpz_cmp_ui(Z,UI) \ + (__builtin_constant_p (UI) && (UI) == 0 \ + ? mpz_sgn (Z) : mpz_cmp_ui (Z,UI)) +#define mpz_cmp_si(Z,UI) \ + (__builtin_constant_p (UI) && (UI) == 0 ? mpz_sgn (Z) \ + : __builtin_constant_p (UI) && (UI) > 0 ? mpz_cmp_ui (Z,UI) \ + : mpz_cmp_si (Z,UI)) +#define mpq_cmp_ui(Q,NUI,DUI) \ + (__builtin_constant_p (NUI) && (NUI) == 0 \ + ? mpq_sgn (Q) : mpq_cmp_ui (Q,NUI,DUI)) +#endif + +#define mpn_divmod(qp,np,nsize,dp,dsize) mpn_divrem (qp,0,np,nsize,dp,dsize) +#if 0 +#define mpn_divmod_1(qp,np,nsize,dlimb) mpn_divrem_1 (qp,0,np,nsize,dlimb) +#endif + +/* Compatibility with GMP 1. */ +#define mpz_mdiv mpz_fdiv_q +#define mpz_mdivmod mpz_fdiv_qr +#define mpz_mmod mpz_fdiv_r +#define mpz_mdiv_ui mpz_fdiv_q_ui +#define mpz_mdivmod_ui(q,r,n,d) \ + ((r == 0) ? mpz_fdiv_q_ui (q,n,d) : mpz_fdiv_qr_ui (q,r,n,d)) +#define mpz_mmod_ui(r,n,d) \ + ((r == 0) ? mpz_fdiv_ui (n,d) : mpz_fdiv_r_ui (r,n,d)) + +/* Useful synonyms, but not quite compatible with GMP 1. */ +#define mpz_div mpz_fdiv_q +#define mpz_divmod mpz_fdiv_qr +#define mpz_div_ui mpz_fdiv_q_ui +#define mpz_divmod_ui mpz_fdiv_qr_ui +#define mpz_mod_ui mpz_fdiv_r_ui +#define mpz_div_2exp mpz_fdiv_q_2exp +#define mpz_mod_2exp mpz_fdiv_r_2exp + +#define __GNU_MP_VERSION 2 +#define __GNU_MP_VERSION_MINOR 0 +#define __GMP_H__ +#endif /* __GMP_H__ */ diff --git a/lib/gmp/longlong.h b/lib/gmp/longlong.h new file mode 100644 index 00000000..e9c25212 --- /dev/null +++ b/lib/gmp/longlong.h @@ -0,0 +1,1410 @@ +/* longlong.h -- definitions for mixed size 32/64 bit arithmetic. + +Copyright (C) 1991, 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This file is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with this file; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#define LONGLONG_STANDALONE 1 /* blp 1998/10/29 */ + +/* You have to define the following before including this file: + + UWtype -- An unsigned type, default type for operations (typically a "word") + UHWtype -- An unsigned type, at least half the size of UWtype. + UDWtype -- An unsigned type, at least twice as large a UWtype + W_TYPE_SIZE -- size in bits of UWtype + + SItype, USItype -- Signed and unsigned 32 bit types. + DItype, UDItype -- Signed and unsigned 64 bit types. + + On a 32 bit machine UWtype should typically be USItype; + on a 64 bit machine, UWtype should typically be UDItype. +*/ + +#define __BITS4 (W_TYPE_SIZE / 4) +#define __ll_B ((UWtype) 1 << (W_TYPE_SIZE / 2)) +#define __ll_lowpart(t) ((UWtype) (t) & (__ll_B - 1)) +#define __ll_highpart(t) ((UWtype) (t) >> (W_TYPE_SIZE / 2)) + +/* This is used to make sure no undesirable sharing between different libraries + that use this file takes place. */ +#ifndef __MPN +#define __MPN(x) __##x +#endif + +/* Define auxiliary asm macros. + + 1) umul_ppmm(high_prod, low_prod, multipler, multiplicand) multiplies two + UWtype integers MULTIPLER and MULTIPLICAND, and generates a two UWtype + word product in HIGH_PROD and LOW_PROD. + + 2) __umulsidi3(a,b) multiplies two UWtype integers A and B, and returns a + UDWtype product. This is just a variant of umul_ppmm. + + 3) udiv_qrnnd(quotient, remainder, high_numerator, low_numerator, + denominator) divides a UDWtype, composed by the UWtype integers + HIGH_NUMERATOR and LOW_NUMERATOR, by DENOMINATOR and places the quotient + in QUOTIENT and the remainder in REMAINDER. HIGH_NUMERATOR must be less + than DENOMINATOR for correct operation. If, in addition, the most + significant bit of DENOMINATOR must be 1, then the pre-processor symbol + UDIV_NEEDS_NORMALIZATION is defined to 1. + + 4) sdiv_qrnnd(quotient, remainder, high_numerator, low_numerator, + denominator). Like udiv_qrnnd but the numbers are signed. The quotient + is rounded towards 0. + + 5) count_leading_zeros(count, x) counts the number of zero-bits from the + msb to the first non-zero bit in the UWtype X. This is the number of + steps X needs to be shifted left to set the msb. Undefined for X == 0, + unless the symbol COUNT_LEADING_ZEROS_0 is defined to some value. + + 6) count_trailing_zeros(count, x) like count_leading_zeros, but counts + from the least significant end. + + 7) add_ssaaaa(high_sum, low_sum, high_addend_1, low_addend_1, + high_addend_2, low_addend_2) adds two UWtype integers, composed by + HIGH_ADDEND_1 and LOW_ADDEND_1, and HIGH_ADDEND_2 and LOW_ADDEND_2 + respectively. The result is placed in HIGH_SUM and LOW_SUM. Overflow + (i.e. carry out) is not stored anywhere, and is lost. + + 8) sub_ddmmss(high_difference, low_difference, high_minuend, low_minuend, + high_subtrahend, low_subtrahend) subtracts two two-word UWtype integers, + composed by HIGH_MINUEND_1 and LOW_MINUEND_1, and HIGH_SUBTRAHEND_2 and + LOW_SUBTRAHEND_2 respectively. The result is placed in HIGH_DIFFERENCE + and LOW_DIFFERENCE. Overflow (i.e. carry out) is not stored anywhere, + and is lost. + + If any of these macros are left undefined for a particular CPU, + C macros are used. */ + +/* The CPUs come in alphabetical order below. + + Please add support for more CPUs here, or improve the current support + for the CPUs below! */ + +#if defined (__CHECKER__) +#define NO_ASM +#endif + +#if defined (__GNUC__) && !defined (NO_ASM) + +/* We sometimes need to clobber "cc" with gcc2, but that would not be + understood by gcc1. Use cpp to avoid major code duplication. */ +#if __GNUC__ < 2 +#define __CLOBBER_CC +#define __AND_CLOBBER_CC +#else /* __GNUC__ >= 2 */ +#define __CLOBBER_CC : "cc" +#define __AND_CLOBBER_CC , "cc" +#endif /* __GNUC__ < 2 */ + +#if (defined (__a29k__) || defined (_AM29K)) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("add %1,%4,%5 + addc %0,%2,%3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%r" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "%r" ((USItype)(al)), \ + "rI" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("sub %1,%4,%5 + subc %0,%2,%3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "r" ((USItype)(al)), \ + "rI" ((USItype)(bl))) +#define umul_ppmm(xh, xl, m0, m1) \ + do { \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("multiplu %0,%1,%2" \ + : "=r" ((USItype)(xl)) \ + : "r" (__m0), \ + "r" (__m1)); \ + __asm__ ("multmu %0,%1,%2" \ + : "=r" ((USItype)(xh)) \ + : "r" (__m0), \ + "r" (__m1)); \ + } while (0) +#define udiv_qrnnd(q, r, n1, n0, d) \ + __asm__ ("dividu %0,%3,%4" \ + : "=r" ((USItype)(q)), \ + "=q" ((USItype)(r)) \ + : "1" ((USItype)(n1)), \ + "r" ((USItype)(n0)), \ + "r" ((USItype)(d))) +#define count_leading_zeros(count, x) \ + __asm__ ("clz %0,%1" \ + : "=r" ((USItype)(count)) \ + : "r" ((USItype)(x))) +#define COUNT_LEADING_ZEROS_0 32 +#endif /* __a29k__ */ + +#if defined (__alpha) && W_TYPE_SIZE == 64 +#define umul_ppmm(ph, pl, m0, m1) \ + do { \ + UDItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("umulh %r1,%2,%0" \ + : "=r" ((UDItype) ph) \ + : "%rJ" (__m0), \ + "rI" (__m1)); \ + (pl) = __m0 * __m1; \ + } while (0) +#define UMUL_TIME 46 +#ifndef LONGLONG_STANDALONE +#define udiv_qrnnd(q, r, n1, n0, d) \ + do { UDItype __r; \ + (q) = __udiv_qrnnd (&__r, (n1), (n0), (d)); \ + (r) = __r; \ + } while (0) +extern UDItype __udiv_qrnnd (); +#define UDIV_TIME 220 +#endif /* LONGLONG_STANDALONE */ +#endif /* __alpha */ + +#if defined (__arm__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("adds %1, %4, %5 + adc %0, %2, %3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%r" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "%r" ((USItype)(al)), \ + "rI" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subs %1, %4, %5 + sbc %0, %2, %3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "r" ((USItype)(al)), \ + "rI" ((USItype)(bl))) +#define umul_ppmm(xh, xl, a, b) \ + __asm__ ("%@ Inlined umul_ppmm + mov %|r0, %2, lsr #16 + mov %|r2, %3, lsr #16 + bic %|r1, %2, %|r0, lsl #16 + bic %|r2, %3, %|r2, lsl #16 + mul %1, %|r1, %|r2 + mul %|r2, %|r0, %|r2 + mul %|r1, %0, %|r1 + mul %0, %|r0, %0 + adds %|r1, %|r2, %|r1 + addcs %0, %0, #65536 + adds %1, %1, %|r1, lsl #16 + adc %0, %0, %|r1, lsr #16" \ + : "=&r" ((USItype)(xh)), \ + "=r" ((USItype)(xl)) \ + : "r" ((USItype)(a)), \ + "r" ((USItype)(b)) \ + : "r0", "r1", "r2") +#define UMUL_TIME 20 +#define UDIV_TIME 100 +#endif /* __arm__ */ + +#if defined (__clipper__) && W_TYPE_SIZE == 32 +#define umul_ppmm(w1, w0, u, v) \ + ({union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __xx; \ + __asm__ ("mulwux %2,%0" \ + : "=r" (__xx.__ll) \ + : "%0" ((USItype)(u)), \ + "r" ((USItype)(v))); \ + (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;}) +#define smul_ppmm(w1, w0, u, v) \ + ({union {DItype __ll; \ + struct {SItype __l, __h;} __i; \ + } __xx; \ + __asm__ ("mulwx %2,%0" \ + : "=r" (__xx.__ll) \ + : "%0" ((SItype)(u)), \ + "r" ((SItype)(v))); \ + (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;}) +#define __umulsidi3(u, v) \ + ({UDItype __w; \ + __asm__ ("mulwux %2,%0" \ + : "=r" (__w) \ + : "%0" ((USItype)(u)), \ + "r" ((USItype)(v))); \ + __w; }) +#endif /* __clipper__ */ + +#if defined (__gmicro__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("add.w %5,%1 + addx %3,%0" \ + : "=g" ((USItype)(sh)), \ + "=&g" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("sub.w %5,%1 + subx %3,%0" \ + : "=g" ((USItype)(sh)), \ + "=&g" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define umul_ppmm(ph, pl, m0, m1) \ + __asm__ ("mulx %3,%0,%1" \ + : "=g" ((USItype)(ph)), \ + "=r" ((USItype)(pl)) \ + : "%0" ((USItype)(m0)), \ + "g" ((USItype)(m1))) +#define udiv_qrnnd(q, r, nh, nl, d) \ + __asm__ ("divx %4,%0,%1" \ + : "=g" ((USItype)(q)), \ + "=r" ((USItype)(r)) \ + : "1" ((USItype)(nh)), \ + "0" ((USItype)(nl)), \ + "g" ((USItype)(d))) +#define count_leading_zeros(count, x) \ + __asm__ ("bsch/1 %1,%0" \ + : "=g" (count) \ + : "g" ((USItype)(x)), \ + "0" ((USItype)0)) +#endif + +#if defined (__hppa) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("add %4,%5,%1 + addc %2,%3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%rM" ((USItype)(ah)), \ + "rM" ((USItype)(bh)), \ + "%rM" ((USItype)(al)), \ + "rM" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("sub %4,%5,%1 + subb %2,%3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "rM" ((USItype)(ah)), \ + "rM" ((USItype)(bh)), \ + "rM" ((USItype)(al)), \ + "rM" ((USItype)(bl))) +#if defined (_PA_RISC1_1) +#define umul_ppmm(wh, wl, u, v) \ + do { \ + union {UDItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + __asm__ ("xmpyu %1,%2,%0" \ + : "=*f" (__xx.__ll) \ + : "*f" ((USItype)(u)), \ + "*f" ((USItype)(v))); \ + (wh) = __xx.__i.__h; \ + (wl) = __xx.__i.__l; \ + } while (0) +#define UMUL_TIME 8 +#define UDIV_TIME 60 +#else +#define UMUL_TIME 40 +#define UDIV_TIME 80 +#endif +#ifndef LONGLONG_STANDALONE +#define udiv_qrnnd(q, r, n1, n0, d) \ + do { USItype __r; \ + (q) = __udiv_qrnnd (&__r, (n1), (n0), (d)); \ + (r) = __r; \ + } while (0) +extern USItype __udiv_qrnnd (); +#endif /* LONGLONG_STANDALONE */ +#define count_leading_zeros(count, x) \ + do { \ + USItype __tmp; \ + __asm__ ( \ + "ldi 1,%0 + extru,= %1,15,16,%%r0 ; Bits 31..16 zero? + extru,tr %1,15,16,%1 ; No. Shift down, skip add. + ldo 16(%0),%0 ; Yes. Perform add. + extru,= %1,23,8,%%r0 ; Bits 15..8 zero? + extru,tr %1,23,8,%1 ; No. Shift down, skip add. + ldo 8(%0),%0 ; Yes. Perform add. + extru,= %1,27,4,%%r0 ; Bits 7..4 zero? + extru,tr %1,27,4,%1 ; No. Shift down, skip add. + ldo 4(%0),%0 ; Yes. Perform add. + extru,= %1,29,2,%%r0 ; Bits 3..2 zero? + extru,tr %1,29,2,%1 ; No. Shift down, skip add. + ldo 2(%0),%0 ; Yes. Perform add. + extru %1,30,1,%1 ; Extract bit 1. + sub %0,%1,%0 ; Subtract it. + " : "=r" (count), "=r" (__tmp) : "1" (x)); \ + } while (0) +#endif /* hppa */ + +#if (defined (__i370__) || defined (__mvs__)) && W_TYPE_SIZE == 32 +#define umul_ppmm(xh, xl, m0, m1) \ + do { \ + union {UDItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("mr %0,%3" \ + : "=r" (__xx.__i.__h), \ + "=r" (__xx.__i.__l) \ + : "%1" (__m0), \ + "r" (__m1)); \ + (xh) = __xx.__i.__h; (xl) = __xx.__i.__l; \ + (xh) += ((((SItype) __m0 >> 31) & __m1) \ + + (((SItype) __m1 >> 31) & __m0)); \ + } while (0) +#define smul_ppmm(xh, xl, m0, m1) \ + do { \ + union {DItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + __asm__ ("mr %0,%3" \ + : "=r" (__xx.__i.__h), \ + "=r" (__xx.__i.__l) \ + : "%1" (m0), \ + "r" (m1)); \ + (xh) = __xx.__i.__h; (xl) = __xx.__i.__l; \ + } while (0) +#define sdiv_qrnnd(q, r, n1, n0, d) \ + do { \ + union {DItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + __xx.__i.__h = n1; __xx.__i.__l = n0; \ + __asm__ ("dr %0,%2" \ + : "=r" (__xx.__ll) \ + : "0" (__xx.__ll), "r" (d)); \ + (q) = __xx.__i.__l; (r) = __xx.__i.__h; \ + } while (0) +#endif + +#if (defined (__i386__) || defined (__i486__)) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("addl %5,%1 + adcl %3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subl %5,%1 + sbbl %3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("mull %3" \ + : "=a" ((USItype)(w0)), \ + "=d" ((USItype)(w1)) \ + : "%0" ((USItype)(u)), \ + "rm" ((USItype)(v))) +#define udiv_qrnnd(q, r, n1, n0, d) \ + __asm__ ("divl %4" \ + : "=a" ((USItype)(q)), \ + "=d" ((USItype)(r)) \ + : "0" ((USItype)(n0)), \ + "1" ((USItype)(n1)), \ + "rm" ((USItype)(d))) +#define count_leading_zeros(count, x) \ + do { \ + USItype __cbtmp; \ + __asm__ ("bsrl %1,%0" \ + : "=r" (__cbtmp) : "rm" ((USItype)(x))); \ + (count) = __cbtmp ^ 31; \ + } while (0) +#define count_trailing_zeros(count, x) \ + __asm__ ("bsfl %1,%0" : "=r" (count) : "rm" ((USItype)(x))) +#ifndef UMUL_TIME +#define UMUL_TIME 40 +#endif +#ifndef UDIV_TIME +#define UDIV_TIME 40 +#endif +#endif /* 80x86 */ + +#if defined (__i860__) && W_TYPE_SIZE == 32 +#define rshift_rhlc(r,h,l,c) \ + __asm__ ("shr %3,r0,r0\;shrd %1,%2,%0" \ + "=r" (r) : "r" (h), "r" (l), "rn" (c)) +#endif /* i860 */ + +#if defined (__i960__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("cmpo 1,0\;addc %5,%4,%1\;addc %3,%2,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%dI" ((USItype)(ah)), \ + "dI" ((USItype)(bh)), \ + "%dI" ((USItype)(al)), \ + "dI" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("cmpo 0,0\;subc %5,%4,%1\;subc %3,%2,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "dI" ((USItype)(ah)), \ + "dI" ((USItype)(bh)), \ + "dI" ((USItype)(al)), \ + "dI" ((USItype)(bl))) +#define umul_ppmm(w1, w0, u, v) \ + ({union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __xx; \ + __asm__ ("emul %2,%1,%0" \ + : "=d" (__xx.__ll) \ + : "%dI" ((USItype)(u)), \ + "dI" ((USItype)(v))); \ + (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;}) +#define __umulsidi3(u, v) \ + ({UDItype __w; \ + __asm__ ("emul %2,%1,%0" \ + : "=d" (__w) \ + : "%dI" ((USItype)(u)), \ + "dI" ((USItype)(v))); \ + __w; }) +#define udiv_qrnnd(q, r, nh, nl, d) \ + do { \ + union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __nn; \ + __nn.__i.__h = (nh); __nn.__i.__l = (nl); \ + __asm__ ("ediv %d,%n,%0" \ + : "=d" (__rq.__ll) \ + : "dI" (__nn.__ll), \ + "dI" ((USItype)(d))); \ + (r) = __rq.__i.__l; (q) = __rq.__i.__h; \ + } while (0) +#define count_leading_zeros(count, x) \ + do { \ + USItype __cbtmp; \ + __asm__ ("scanbit %1,%0" \ + : "=r" (__cbtmp) \ + : "r" ((USItype)(x))); \ + (count) = __cbtmp ^ 31; \ + } while (0) +#define COUNT_LEADING_ZEROS_0 (-32) /* sic */ +#if defined (__i960mx) /* what is the proper symbol to test??? */ +#define rshift_rhlc(r,h,l,c) \ + do { \ + union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __nn; \ + __nn.__i.__h = (h); __nn.__i.__l = (l); \ + __asm__ ("shre %2,%1,%0" \ + : "=d" (r) : "dI" (__nn.__ll), "dI" (c)); \ + } +#endif /* i960mx */ +#endif /* i960 */ + +#if (defined (__mc68000__) || defined (__mc68020__) || defined (__NeXT__) || defined(mc68020)) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("add%.l %5,%1 + addx%.l %3,%0" \ + : "=d" ((USItype)(sh)), \ + "=&d" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "d" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("sub%.l %5,%1 + subx%.l %3,%0" \ + : "=d" ((USItype)(sh)), \ + "=&d" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "d" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#if (defined (__mc68020__) || defined (__NeXT__) || defined(mc68020)) +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("mulu%.l %3,%1:%0" \ + : "=d" ((USItype)(w0)), \ + "=d" ((USItype)(w1)) \ + : "%0" ((USItype)(u)), \ + "dmi" ((USItype)(v))) +#define UMUL_TIME 45 +#define udiv_qrnnd(q, r, n1, n0, d) \ + __asm__ ("divu%.l %4,%1:%0" \ + : "=d" ((USItype)(q)), \ + "=d" ((USItype)(r)) \ + : "0" ((USItype)(n0)), \ + "1" ((USItype)(n1)), \ + "dmi" ((USItype)(d))) +#define UDIV_TIME 90 +#define sdiv_qrnnd(q, r, n1, n0, d) \ + __asm__ ("divs%.l %4,%1:%0" \ + : "=d" ((USItype)(q)), \ + "=d" ((USItype)(r)) \ + : "0" ((USItype)(n0)), \ + "1" ((USItype)(n1)), \ + "dmi" ((USItype)(d))) +#define count_leading_zeros(count, x) \ + __asm__ ("bfffo %1{%b2:%b2},%0" \ + : "=d" ((USItype)(count)) \ + : "od" ((USItype)(x)), "n" (0)) +#define COUNT_LEADING_ZEROS_0 32 +#else /* not mc68020 */ +#define umul_ppmm(xh, xl, a, b) \ + do { USItype __umul_tmp1, __umul_tmp2; \ + __asm__ ("| Inlined umul_ppmm + move%.l %5,%3 + move%.l %2,%0 + move%.w %3,%1 + swap %3 + swap %0 + mulu %2,%1 + mulu %3,%0 + mulu %2,%3 + swap %2 + mulu %5,%2 + add%.l %3,%2 + jcc 1f + add%.l %#0x10000,%0 +1: move%.l %2,%3 + clr%.w %2 + swap %2 + swap %3 + clr%.w %3 + add%.l %3,%1 + addx%.l %2,%0 + | End inlined umul_ppmm" \ + : "=&d" ((USItype)(xh)), "=&d" ((USItype)(xl)), \ + "=d" (__umul_tmp1), "=&d" (__umul_tmp2) \ + : "%2" ((USItype)(a)), "d" ((USItype)(b))); \ + } while (0) +#define UMUL_TIME 100 +#define UDIV_TIME 400 +#endif /* not mc68020 */ +#endif /* mc68000 */ + +#if defined (__m88000__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("addu.co %1,%r4,%r5 + addu.ci %0,%r2,%r3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%rJ" ((USItype)(ah)), \ + "rJ" ((USItype)(bh)), \ + "%rJ" ((USItype)(al)), \ + "rJ" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subu.co %1,%r4,%r5 + subu.ci %0,%r2,%r3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "rJ" ((USItype)(ah)), \ + "rJ" ((USItype)(bh)), \ + "rJ" ((USItype)(al)), \ + "rJ" ((USItype)(bl))) +#define count_leading_zeros(count, x) \ + do { \ + USItype __cbtmp; \ + __asm__ ("ff1 %0,%1" \ + : "=r" (__cbtmp) \ + : "r" ((USItype)(x))); \ + (count) = __cbtmp ^ 31; \ + } while (0) +#define COUNT_LEADING_ZEROS_0 63 /* sic */ +#if defined (__m88110__) +#define umul_ppmm(wh, wl, u, v) \ + do { \ + union {UDItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + __asm__ ("mulu.d %0,%1,%2" \ + : "=r" (__xx.__ll) \ + : "r" ((USItype)(u)), \ + "r" ((USItype)(v))); \ + (wh) = __xx.__i.__h; \ + (wl) = __xx.__i.__l; \ + } while (0) +#define udiv_qrnnd(q, r, n1, n0, d) \ + ({union {UDItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + USItype __q; \ + __xx.__i.__h = (n1); __xx.__i.__l = (n0); \ + __asm__ ("divu.d %0,%1,%2" \ + : "=r" (__q) \ + : "r" (__xx.__ll), \ + "r" ((USItype)(d))); \ + (r) = (n0) - __q * (d); (q) = __q; }) +#define UMUL_TIME 5 +#define UDIV_TIME 25 +#else +#define UMUL_TIME 17 +#define UDIV_TIME 150 +#endif /* __m88110__ */ +#endif /* __m88000__ */ + +#if defined (__mips__) && W_TYPE_SIZE == 32 +#if __GNUC__ > 2 || __GNUC_MINOR__ >= 7 +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("multu %2,%3" \ + : "=l" ((USItype)(w0)), \ + "=h" ((USItype)(w1)) \ + : "d" ((USItype)(u)), \ + "d" ((USItype)(v))) +#else +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("multu %2,%3 + mflo %0 + mfhi %1" \ + : "=d" ((USItype)(w0)), \ + "=d" ((USItype)(w1)) \ + : "d" ((USItype)(u)), \ + "d" ((USItype)(v))) +#endif +#define UMUL_TIME 10 +#define UDIV_TIME 100 +#endif /* __mips__ */ + +#if (defined (__mips) && __mips >= 3) && W_TYPE_SIZE == 64 +#if __GNUC__ > 2 || __GNUC_MINOR__ >= 7 +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("dmultu %2,%3" \ + : "=l" ((UDItype)(w0)), \ + "=h" ((UDItype)(w1)) \ + : "d" ((UDItype)(u)), \ + "d" ((UDItype)(v))) +#else +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("dmultu %2,%3 + mflo %0 + mfhi %1" \ + : "=d" ((UDItype)(w0)), \ + "=d" ((UDItype)(w1)) \ + : "d" ((UDItype)(u)), \ + "d" ((UDItype)(v))) +#endif +#define UMUL_TIME 20 +#define UDIV_TIME 140 +#endif /* __mips__ */ + +#if defined (__ns32000__) && W_TYPE_SIZE == 32 +#define umul_ppmm(w1, w0, u, v) \ + ({union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __xx; \ + __asm__ ("meid %2,%0" \ + : "=g" (__xx.__ll) \ + : "%0" ((USItype)(u)), \ + "g" ((USItype)(v))); \ + (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;}) +#define __umulsidi3(u, v) \ + ({UDItype __w; \ + __asm__ ("meid %2,%0" \ + : "=g" (__w) \ + : "%0" ((USItype)(u)), \ + "g" ((USItype)(v))); \ + __w; }) +#define udiv_qrnnd(q, r, n1, n0, d) \ + ({union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __xx; \ + __xx.__i.__h = (n1); __xx.__i.__l = (n0); \ + __asm__ ("deid %2,%0" \ + : "=g" (__xx.__ll) \ + : "0" (__xx.__ll), \ + "g" ((USItype)(d))); \ + (r) = __xx.__i.__l; (q) = __xx.__i.__h; }) +#define count_trailing_zeros(count,x) \ + do { + __asm__ ("ffsd %2,%0" \ + : "=r" ((USItype) (count)) \ + : "0" ((USItype) 0), \ + "r" ((USItype) (x))); \ + } while (0) +#endif /* __ns32000__ */ + +#if (defined (_ARCH_PPC) || defined (_IBMR2)) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + do { \ + if (__builtin_constant_p (bh) && (bh) == 0) \ + __asm__ ("{a%I4|add%I4c} %1,%3,%4\n\t{aze|addze} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%r" ((USItype)(ah)), \ + "%r" ((USItype)(al)), \ + "rI" ((USItype)(bl))); \ + else if (__builtin_constant_p (bh) && (bh) ==~(USItype) 0) \ + __asm__ ("{a%I4|add%I4c} %1,%3,%4\n\t{ame|addme} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%r" ((USItype)(ah)), \ + "%r" ((USItype)(al)), \ + "rI" ((USItype)(bl))); \ + else \ + __asm__ ("{a%I5|add%I5c} %1,%4,%5\n\t{ae|adde} %0,%2,%3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%r" ((USItype)(ah)), \ + "r" ((USItype)(bh)), \ + "%r" ((USItype)(al)), \ + "rI" ((USItype)(bl))); \ + } while (0) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + do { \ + if (__builtin_constant_p (ah) && (ah) == 0) \ + __asm__ ("{sf%I3|subf%I3c} %1,%4,%3\n\t{sfze|subfze} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(bh)), \ + "rI" ((USItype)(al)), \ + "r" ((USItype)(bl))); \ + else if (__builtin_constant_p (ah) && (ah) ==~(USItype) 0) \ + __asm__ ("{sf%I3|subf%I3c} %1,%4,%3\n\t{sfme|subfme} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(bh)), \ + "rI" ((USItype)(al)), \ + "r" ((USItype)(bl))); \ + else if (__builtin_constant_p (bh) && (bh) == 0) \ + __asm__ ("{sf%I3|subf%I3c} %1,%4,%3\n\t{ame|addme} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(ah)), \ + "rI" ((USItype)(al)), \ + "r" ((USItype)(bl))); \ + else if (__builtin_constant_p (bh) && (bh) ==~(USItype) 0) \ + __asm__ ("{sf%I3|subf%I3c} %1,%4,%3\n\t{aze|addze} %0,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(ah)), \ + "rI" ((USItype)(al)), \ + "r" ((USItype)(bl))); \ + else \ + __asm__ ("{sf%I4|subf%I4c} %1,%5,%4\n\t{sfe|subfe} %0,%3,%2" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "r" ((USItype)(ah)), \ + "r" ((USItype)(bh)), \ + "rI" ((USItype)(al)), \ + "r" ((USItype)(bl))); \ + } while (0) +#define count_leading_zeros(count, x) \ + __asm__ ("{cntlz|cntlzw} %0,%1" \ + : "=r" ((USItype)(count)) \ + : "r" ((USItype)(x))) +#define COUNT_LEADING_ZEROS_0 32 +#if defined (_ARCH_PPC) +#define umul_ppmm(ph, pl, m0, m1) \ + do { \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("mulhwu %0,%1,%2" \ + : "=r" ((USItype) ph) \ + : "%r" (__m0), \ + "r" (__m1)); \ + (pl) = __m0 * __m1; \ + } while (0) +#define UMUL_TIME 15 +#define smul_ppmm(ph, pl, m0, m1) \ + do { \ + SItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("mulhw %0,%1,%2" \ + : "=r" ((SItype) ph) \ + : "%r" (__m0), \ + "r" (__m1)); \ + (pl) = __m0 * __m1; \ + } while (0) +#define SMUL_TIME 14 +#define UDIV_TIME 120 +#else +#define umul_ppmm(xh, xl, m0, m1) \ + do { \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("mul %0,%2,%3" \ + : "=r" ((USItype)(xh)), \ + "=q" ((USItype)(xl)) \ + : "r" (__m0), \ + "r" (__m1)); \ + (xh) += ((((SItype) __m0 >> 31) & __m1) \ + + (((SItype) __m1 >> 31) & __m0)); \ + } while (0) +#define UMUL_TIME 8 +#define smul_ppmm(xh, xl, m0, m1) \ + __asm__ ("mul %0,%2,%3" \ + : "=r" ((SItype)(xh)), \ + "=q" ((SItype)(xl)) \ + : "r" (m0), \ + "r" (m1)) +#define SMUL_TIME 4 +#define sdiv_qrnnd(q, r, nh, nl, d) \ + __asm__ ("div %0,%2,%4" \ + : "=r" ((SItype)(q)), "=q" ((SItype)(r)) \ + : "r" ((SItype)(nh)), "1" ((SItype)(nl)), "r" ((SItype)(d))) +#define UDIV_TIME 100 +#endif +#endif /* Power architecture variants. */ + +#if defined (__pyr__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("addw %5,%1 + addwc %3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subw %5,%1 + subwb %3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +/* This insn works on Pyramids with AP, XP, or MI CPUs, but not with SP. */ +#define umul_ppmm(w1, w0, u, v) \ + ({union {UDItype __ll; \ + struct {USItype __h, __l;} __i; \ + } __xx; \ + __asm__ ("movw %1,%R0 + uemul %2,%0" \ + : "=&r" (__xx.__ll) \ + : "g" ((USItype) (u)), \ + "g" ((USItype)(v))); \ + (w1) = __xx.__i.__h; (w0) = __xx.__i.__l;}) +#endif /* __pyr__ */ + +#if defined (__ibm032__) /* RT/ROMP */ && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("a %1,%5 + ae %0,%3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "r" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "r" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("s %1,%5 + se %0,%3" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "r" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "r" ((USItype)(bl))) +#define umul_ppmm(ph, pl, m0, m1) \ + do { \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ( \ + "s r2,r2 + mts r10,%2 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + m r2,%3 + cas %0,r2,r0 + mfs r10,%1" \ + : "=r" ((USItype)(ph)), \ + "=r" ((USItype)(pl)) \ + : "%r" (__m0), \ + "r" (__m1) \ + : "r2"); \ + (ph) += ((((SItype) __m0 >> 31) & __m1) \ + + (((SItype) __m1 >> 31) & __m0)); \ + } while (0) +#define UMUL_TIME 20 +#define UDIV_TIME 200 +#define count_leading_zeros(count, x) \ + do { \ + if ((x) >= 0x10000) \ + __asm__ ("clz %0,%1" \ + : "=r" ((USItype)(count)) \ + : "r" ((USItype)(x) >> 16)); \ + else \ + { \ + __asm__ ("clz %0,%1" \ + : "=r" ((USItype)(count)) \ + : "r" ((USItype)(x))); \ + (count) += 16; \ + } \ + } while (0) +#endif /* RT/ROMP */ + +#if defined (__sh2__) && W_TYPE_SIZE == 32 +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ( \ + "dmulu.l %2,%3 + sts macl,%1 + sts mach,%0" \ + : "=r" ((USItype)(w1)), \ + "=r" ((USItype)(w0)) \ + : "r" ((USItype)(u)), \ + "r" ((USItype)(v)) \ + : "macl", "mach") +#define UMUL_TIME 5 +#endif + +#if defined (__sparc__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("addcc %r4,%5,%1 + addx %r2,%3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "%rJ" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "%rJ" ((USItype)(al)), \ + "rI" ((USItype)(bl)) \ + __CLOBBER_CC) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subcc %r4,%5,%1 + subx %r2,%3,%0" \ + : "=r" ((USItype)(sh)), \ + "=&r" ((USItype)(sl)) \ + : "rJ" ((USItype)(ah)), \ + "rI" ((USItype)(bh)), \ + "rJ" ((USItype)(al)), \ + "rI" ((USItype)(bl)) \ + __CLOBBER_CC) +#if defined (__sparc_v8__) +/* Don't match immediate range because, 1) it is not often useful, + 2) the 'I' flag thinks of the range as a 13 bit signed interval, + while we want to match a 13 bit interval, sign extended to 32 bits, + but INTERPRETED AS UNSIGNED. */ +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("umul %2,%3,%1;rd %%y,%0" \ + : "=r" ((USItype)(w1)), \ + "=r" ((USItype)(w0)) \ + : "r" ((USItype)(u)), \ + "r" ((USItype)(v))) +#define UMUL_TIME 5 +#ifndef SUPERSPARC /* SuperSPARC's udiv only handles 53 bit dividends */ +#define udiv_qrnnd(q, r, n1, n0, d) \ + do { \ + USItype __q; \ + __asm__ ("mov %1,%%y;nop;nop;nop;udiv %2,%3,%0" \ + : "=r" ((USItype)(__q)) \ + : "r" ((USItype)(n1)), \ + "r" ((USItype)(n0)), \ + "r" ((USItype)(d))); \ + (r) = (n0) - __q * (d); \ + (q) = __q; \ + } while (0) +#define UDIV_TIME 25 +#endif /* SUPERSPARC */ +#else /* ! __sparc_v8__ */ +#if defined (__sparclite__) +/* This has hardware multiply but not divide. It also has two additional + instructions scan (ffs from high bit) and divscc. */ +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("umul %2,%3,%1;rd %%y,%0" \ + : "=r" ((USItype)(w1)), \ + "=r" ((USItype)(w0)) \ + : "r" ((USItype)(u)), \ + "r" ((USItype)(v))) +#define UMUL_TIME 5 +#define udiv_qrnnd(q, r, n1, n0, d) \ + __asm__ ("! Inlined udiv_qrnnd + wr %%g0,%2,%%y ! Not a delayed write for sparclite + tst %%g0 + divscc %3,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%%g1 + divscc %%g1,%4,%0 + rd %%y,%1 + bl,a 1f + add %1,%4,%1 +1: ! End of inline udiv_qrnnd" \ + : "=r" ((USItype)(q)), \ + "=r" ((USItype)(r)) \ + : "r" ((USItype)(n1)), \ + "r" ((USItype)(n0)), \ + "rI" ((USItype)(d)) \ + : "%g1" __AND_CLOBBER_CC) +#define UDIV_TIME 37 +#define count_leading_zeros(count, x) \ + __asm__ ("scan %1,0,%0" \ + : "=r" ((USItype)(x)) \ + : "r" ((USItype)(count))) +/* Early sparclites return 63 for an argument of 0, but they warn that future + implementations might change this. Therefore, leave COUNT_LEADING_ZEROS_0 + undefined. */ +#endif /* __sparclite__ */ +#endif /* __sparc_v8__ */ +/* Default to sparc v7 versions of umul_ppmm and udiv_qrnnd. */ +#ifndef umul_ppmm +#define umul_ppmm(w1, w0, u, v) \ + __asm__ ("! Inlined umul_ppmm + wr %%g0,%2,%%y ! SPARC has 0-3 delay insn after a wr + sra %3,31,%%g2 ! Don't move this insn + and %2,%%g2,%%g2 ! Don't move this insn + andcc %%g0,0,%%g1 ! Don't move this insn + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,%3,%%g1 + mulscc %%g1,0,%%g1 + add %%g1,%%g2,%0 + rd %%y,%1" \ + : "=r" ((USItype)(w1)), \ + "=r" ((USItype)(w0)) \ + : "%rI" ((USItype)(u)), \ + "r" ((USItype)(v)) \ + : "%g1", "%g2" __AND_CLOBBER_CC) +#define UMUL_TIME 39 /* 39 instructions */ +#endif +#ifndef udiv_qrnnd +#ifndef LONGLONG_STANDALONE +#define udiv_qrnnd(q, r, n1, n0, d) \ + do { USItype __r; \ + (q) = __udiv_qrnnd (&__r, (n1), (n0), (d)); \ + (r) = __r; \ + } while (0) +extern USItype __udiv_qrnnd (); +#define UDIV_TIME 140 +#endif /* LONGLONG_STANDALONE */ +#endif /* udiv_qrnnd */ +#endif /* __sparc__ */ + +#if defined (__vax__) && W_TYPE_SIZE == 32 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("addl2 %5,%1 + adwc %3,%0" \ + : "=g" ((USItype)(sh)), \ + "=&g" ((USItype)(sl)) \ + : "%0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "%1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("subl2 %5,%1 + sbwc %3,%0" \ + : "=g" ((USItype)(sh)), \ + "=&g" ((USItype)(sl)) \ + : "0" ((USItype)(ah)), \ + "g" ((USItype)(bh)), \ + "1" ((USItype)(al)), \ + "g" ((USItype)(bl))) +#define umul_ppmm(xh, xl, m0, m1) \ + do { \ + union {UDItype __ll; \ + struct {USItype __l, __h;} __i; \ + } __xx; \ + USItype __m0 = (m0), __m1 = (m1); \ + __asm__ ("emul %1,%2,$0,%0" \ + : "=g" (__xx.__ll) \ + : "g" (__m0), \ + "g" (__m1)); \ + (xh) = __xx.__i.__h; (xl) = __xx.__i.__l; \ + (xh) += ((((SItype) __m0 >> 31) & __m1) \ + + (((SItype) __m1 >> 31) & __m0)); \ + } while (0) +#define sdiv_qrnnd(q, r, n1, n0, d) \ + do { \ + union {DItype __ll; \ + struct {SItype __l, __h;} __i; \ + } __xx; \ + __xx.__i.__h = n1; __xx.__i.__l = n0; \ + __asm__ ("ediv %3,%2,%0,%1" \ + : "=g" (q), "=g" (r) \ + : "g" (__xx.ll), "g" (d)); \ + } while (0) +#endif /* __vax__ */ + +#if defined (__z8000__) && W_TYPE_SIZE == 16 +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + __asm__ ("add %H1,%H5\n\tadc %H0,%H3" \ + : "=r" ((unsigned int)(sh)), \ + "=&r" ((unsigned int)(sl)) \ + : "%0" ((unsigned int)(ah)), \ + "r" ((unsigned int)(bh)), \ + "%1" ((unsigned int)(al)), \ + "rQR" ((unsigned int)(bl))) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + __asm__ ("sub %H1,%H5\n\tsbc %H0,%H3" \ + : "=r" ((unsigned int)(sh)), \ + "=&r" ((unsigned int)(sl)) \ + : "0" ((unsigned int)(ah)), \ + "r" ((unsigned int)(bh)), \ + "1" ((unsigned int)(al)), \ + "rQR" ((unsigned int)(bl))) +#define umul_ppmm(xh, xl, m0, m1) \ + do { \ + union {long int __ll; \ + struct {unsigned int __h, __l;} __i; \ + } __xx; \ + unsigned int __m0 = (m0), __m1 = (m1); \ + __asm__ ("mult %S0,%H3" \ + : "=r" (__xx.__i.__h), \ + "=r" (__xx.__i.__l) \ + : "%1" (__m0), \ + "rQR" (__m1)); \ + (xh) = __xx.__i.__h; (xl) = __xx.__i.__l; \ + (xh) += ((((signed int) __m0 >> 15) & __m1) \ + + (((signed int) __m1 >> 15) & __m0)); \ + } while (0) +#endif /* __z8000__ */ + +#endif /* __GNUC__ */ + + +#if !defined (umul_ppmm) && defined (__umulsidi3) +#define umul_ppmm(ph, pl, m0, m1) \ + { \ + UDWtype __ll = __umulsidi3 (m0, m1); \ + ph = (UWtype) (__ll >> W_TYPE_SIZE); \ + pl = (UWtype) __ll; \ + } +#endif + +#if !defined (__umulsidi3) +#define __umulsidi3(u, v) \ + ({UWtype __hi, __lo; \ + umul_ppmm (__hi, __lo, u, v); \ + ((UDWtype) __hi << W_TYPE_SIZE) | __lo; }) +#endif + +/* If this machine has no inline assembler, use C macros. */ + +#if !defined (add_ssaaaa) +#define add_ssaaaa(sh, sl, ah, al, bh, bl) \ + do { \ + UWtype __x; \ + __x = (al) + (bl); \ + (sh) = (ah) + (bh) + (__x < (al)); \ + (sl) = __x; \ + } while (0) +#endif + +#if !defined (sub_ddmmss) +#define sub_ddmmss(sh, sl, ah, al, bh, bl) \ + do { \ + UWtype __x; \ + __x = (al) - (bl); \ + (sh) = (ah) - (bh) - (__x > (al)); \ + (sl) = __x; \ + } while (0) +#endif + +#if !defined (umul_ppmm) +#define umul_ppmm(w1, w0, u, v) \ + do { \ + UWtype __x0, __x1, __x2, __x3; \ + UHWtype __ul, __vl, __uh, __vh; \ + UWtype __u = (u), __v = (v); \ + \ + __ul = __ll_lowpart (__u); \ + __uh = __ll_highpart (__u); \ + __vl = __ll_lowpart (__v); \ + __vh = __ll_highpart (__v); \ + \ + __x0 = (UWtype) __ul * __vl; \ + __x1 = (UWtype) __ul * __vh; \ + __x2 = (UWtype) __uh * __vl; \ + __x3 = (UWtype) __uh * __vh; \ + \ + __x1 += __ll_highpart (__x0);/* this can't give carry */ \ + __x1 += __x2; /* but this indeed can */ \ + if (__x1 < __x2) /* did we get it? */ \ + __x3 += __ll_B; /* yes, add it in the proper pos. */ \ + \ + (w1) = __x3 + __ll_highpart (__x1); \ + (w0) = (__ll_lowpart (__x1) << W_TYPE_SIZE/2) + __ll_lowpart (__x0);\ + } while (0) +#endif + +#if !defined (umul_ppmm) +#define smul_ppmm(w1, w0, u, v) \ + do { \ + UWtype __w1; \ + UWtype __m0 = (u), __m1 = (v); \ + umul_ppmm (__w1, w0, __m0, __m1); \ + (w1) = __w1 - (-(__m0 >> (W_TYPE_SIZE - 1)) & __m1) \ + - (-(__m1 >> (W_TYPE_SIZE - 1)) & __m0); \ + } while (0) +#endif + +/* Define this unconditionally, so it can be used for debugging. */ +#define __udiv_qrnnd_c(q, r, n1, n0, d) \ + do { \ + UWtype __d1, __d0, __q1, __q0, __r1, __r0, __m; \ + __d1 = __ll_highpart (d); \ + __d0 = __ll_lowpart (d); \ + \ + __r1 = (n1) % __d1; \ + __q1 = (n1) / __d1; \ + __m = (UWtype) __q1 * __d0; \ + __r1 = __r1 * __ll_B | __ll_highpart (n0); \ + if (__r1 < __m) \ + { \ + __q1--, __r1 += (d); \ + if (__r1 >= (d)) /* i.e. we didn't get carry when adding to __r1 */\ + if (__r1 < __m) \ + __q1--, __r1 += (d); \ + } \ + __r1 -= __m; \ + \ + __r0 = __r1 % __d1; \ + __q0 = __r1 / __d1; \ + __m = (UWtype) __q0 * __d0; \ + __r0 = __r0 * __ll_B | __ll_lowpart (n0); \ + if (__r0 < __m) \ + { \ + __q0--, __r0 += (d); \ + if (__r0 >= (d)) \ + if (__r0 < __m) \ + __q0--, __r0 += (d); \ + } \ + __r0 -= __m; \ + \ + (q) = (UWtype) __q1 * __ll_B | __q0; \ + (r) = __r0; \ + } while (0) + +/* If the processor has no udiv_qrnnd but sdiv_qrnnd, go through + __udiv_w_sdiv (defined in libgcc or elsewhere). */ +#if !defined (udiv_qrnnd) && defined (sdiv_qrnnd) +#define udiv_qrnnd(q, r, nh, nl, d) \ + do { \ + UWtype __r; \ + (q) = __MPN(udiv_w_sdiv) (&__r, nh, nl, d); \ + (r) = __r; \ + } while (0) +#endif + +/* If udiv_qrnnd was not defined for this processor, use __udiv_qrnnd_c. */ +#if !defined (udiv_qrnnd) +#define UDIV_NEEDS_NORMALIZATION 1 +#define udiv_qrnnd __udiv_qrnnd_c +#endif + +#if !defined (count_leading_zeros) +extern +#ifdef __STDC__ +const +#endif +unsigned char __clz_tab[]; +#define count_leading_zeros(count, x) \ + do { \ + UWtype __xr = (x); \ + UWtype __a; \ + \ + if (W_TYPE_SIZE <= 32) \ + { \ + __a = __xr < ((UWtype) 1 << 2*__BITS4) \ + ? (__xr < ((UWtype) 1 << __BITS4) ? 0 : __BITS4) \ + : (__xr < ((UWtype) 1 << 3*__BITS4) ? 2*__BITS4 : 3*__BITS4);\ + } \ + else \ + { \ + for (__a = W_TYPE_SIZE - 8; __a > 0; __a -= 8) \ + if (((__xr >> __a) & 0xff) != 0) \ + break; \ + } \ + \ + (count) = W_TYPE_SIZE - (__clz_tab[__xr >> __a] + __a); \ + } while (0) +/* This version gives a well-defined value for zero. */ +#define COUNT_LEADING_ZEROS_0 W_TYPE_SIZE +#endif + +#if !defined (count_trailing_zeros) +/* Define count_trailing_zeros using count_leading_zeros. The latter might be + defined in asm, but if it is not, the C version above is good enough. */ +#define count_trailing_zeros(count, x) \ + do { \ + UWtype __ctz_x = (x); \ + UWtype __ctz_c; \ + count_leading_zeros (__ctz_c, __ctz_x & -__ctz_x); \ + (count) = W_TYPE_SIZE - 1 - __ctz_c; \ + } while (0) +#endif + +#ifndef UDIV_NEEDS_NORMALIZATION +#define UDIV_NEEDS_NORMALIZATION 0 +#endif diff --git a/lib/gmp/memory.c b/lib/gmp/memory.c new file mode 100644 index 00000000..2cd64a1f --- /dev/null +++ b/lib/gmp/memory.c @@ -0,0 +1,98 @@ +/* Memory allocation routines. + +Copyright (C) 1991, 1993, 1994 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include + +#include "gmp.h" +#include "gmp-impl.h" + +#ifdef __NeXT__ +#define static +#endif + +#if __STDC__ +void * (*_mp_allocate_func) (size_t) = _mp_default_allocate; +void * (*_mp_reallocate_func) (void *, size_t, size_t) + = _mp_default_reallocate; +void (*_mp_free_func) (void *, size_t) = _mp_default_free; +#else +void * (*_mp_allocate_func) () = _mp_default_allocate; +void * (*_mp_reallocate_func) () = _mp_default_reallocate; +void (*_mp_free_func) () = _mp_default_free; +#endif + +/* Default allocation functions. In case of failure to allocate/reallocate + an error message is written to stderr and the program aborts. */ + +void * +#if __STDC__ +_mp_default_allocate (size_t size) +#else +_mp_default_allocate (size) + size_t size; +#endif +{ + void *ret; + + ret = malloc (size); + if (ret == 0) + { + perror ("cannot allocate in gmp"); + abort (); + } + + return ret; +} + +void * +#if __STDC__ +_mp_default_reallocate (void *oldptr, unused size_t old_size, size_t new_size) +#else +_mp_default_reallocate (oldptr, old_size, new_size) + void *oldptr; + size_t old_size; + size_t new_size; +#endif +{ + void *ret; + + ret = realloc (oldptr, new_size); + if (ret == 0) + { + perror ("cannot allocate in gmp"); + abort (); + } + + return ret; +} + +void +#if __STDC__ +_mp_default_free (void *blk_ptr, unused size_t blk_size) +#else +_mp_default_free (blk_ptr, blk_size) + void *blk_ptr; + size_t blk_size; +#endif +{ + free (blk_ptr); +} diff --git a/lib/gmp/mp_clz_tab.c b/lib/gmp/mp_clz_tab.c new file mode 100644 index 00000000..6fd7e908 --- /dev/null +++ b/lib/gmp/mp_clz_tab.c @@ -0,0 +1,40 @@ +/* __clz_tab -- support for longlong.h + +Copyright (C) 1991, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#if 0 +#include "gmp.h" +#include "gmp-impl.h" +#endif + +#if 0 +const +#endif +unsigned char __clz_tab[] = +{ + 0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, + 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7, + 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, + 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, + 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, + 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8, +}; diff --git a/lib/gmp/mpf/Makefile.am b/lib/gmp/mpf/Makefile.am new file mode 100644 index 00000000..c048998c --- /dev/null +++ b/lib/gmp/mpf/Makefile.am @@ -0,0 +1,9 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +INCLUDES = -I$(srcdir) -I$(srcdir)/.. -I$(top_srcdir) -I$(top_srcdir)/src \ + -I$(top_srcdir)/intl + +noinst_LIBRARIES = libmpf.a +libmpf_a_SOURCES = clear.c get_str.c iset_d.c set_d.c set_dfl_prec.c + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/gmp/mpf/clear.c b/lib/gmp/mpf/clear.c new file mode 100644 index 00000000..00284f55 --- /dev/null +++ b/lib/gmp/mpf/clear.c @@ -0,0 +1,36 @@ +/* mpf_clear -- de-allocate the space occupied by the dynamic digit space of + an integer. + +Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +void +#if __STDC__ +mpf_clear (mpf_ptr m) +#else +mpf_clear (m) + mpf_ptr m; +#endif +{ + (*_mp_free_func) (m->_mp_d, (m->_mp_prec + 1) * BYTES_PER_MP_LIMB); +} diff --git a/lib/gmp/mpf/get_str.c b/lib/gmp/mpf/get_str.c new file mode 100644 index 00000000..f6cf10d2 --- /dev/null +++ b/lib/gmp/mpf/get_str.c @@ -0,0 +1,501 @@ +/* mpf_get_str (digit_ptr, exp, base, n_digits, a) -- Convert the floating + point number A to a base BASE number and store N_DIGITS raw digits at + DIGIT_PTR, and the base BASE exponent in the word pointed to by EXP. For + example, the number 3.1416 would be returned as "31416" in DIGIT_PTR and + 1 in EXP. + +Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +/* + New algorithm for converting fractions (951019): + 0. Call the fraction to convert F. + 1. Compute [exp * log(2^BITS_PER_MP_LIMB)/log(B)], i.e., + [exp * BITS_PER_MP_LIMB * __mp_bases[B].chars_per_bit_exactly]. Exp is + the number of limbs between the limb point and the most significant + non-zero limb. Call this result n. + 2. Compute B^n. + 3. F*B^n will now be just below 1, which can be converted easily. (Just + multiply by B repeatedly, and see the digits fall out as integers.) + We should interrupt the conversion process of F*B^n as soon as the number + of digits requested have been generated. + + New algorithm for converting integers (951019): + 0. Call the integer to convert I. + 1. Compute [exp * log(2^BITS_PER_MP_LIMB)/log(B)], i.e., + [exp BITS_PER_MP_LIMB * __mp_bases[B].chars_per_bit_exactly]. Exp is + the number of limbs between the limb point and the least significant + non-zero limb. Call this result n. + 2. Compute B^n. + 3. I/B^n can be converted easily. (Just divide by B repeatedly. In GMP, + this is best done by calling mpn_get_str.) + Note that converting I/B^n could yield more digits than requested. For + efficiency, the variable n above should be set larger in such cases, to + kill all undesired digits in the division in step 3. +*/ + +char * +#if __STDC__ +mpf_get_str (char *digit_ptr, mp_exp_t *exp, int base, size_t n_digits, mpf_srcptr u) +#else +mpf_get_str (digit_ptr, exp, base, n_digits, u) + char *digit_ptr; + mp_exp_t *exp; + int base; + size_t n_digits; + mpf_srcptr u; +#endif +{ + mp_size_t usize; + mp_exp_t uexp; + unsigned char *str; + size_t str_size; + char *num_to_text; + long i; /* should be size_t */ + mp_ptr rp; + mp_limb_t big_base; + size_t digits_computed_so_far; + int dig_per_u; + mp_srcptr up; + unsigned char *tstr; + mp_exp_t exp_in_base; + TMP_DECL (marker); + + TMP_MARK (marker); + usize = u->_mp_size; + uexp = u->_mp_exp; + + if (base >= 0) + { + if (base == 0) + base = 10; + num_to_text = (char *) "0123456789abcdefghijklmnopqrstuvwxyz"; + } + else + { + base = -base; + num_to_text = (char *) "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + } + + /* Don't compute more digits than U can accurately represent. + Also, if 0 digits were requested, give *exactly* as many digits + as can be accurately represented. */ + { + size_t max_digits = (((u->_mp_prec - 1) * BITS_PER_MP_LIMB) + * __mp_bases[base].chars_per_bit_exactly); + if (n_digits == 0 || n_digits > max_digits) + n_digits = max_digits; + } + + if (digit_ptr == 0) + { + /* We didn't get a string from the user. Allocate one (and return + a pointer to it) with space for `-' and terminating null. */ + digit_ptr = (char *) (*_mp_allocate_func) (n_digits + 2); + } + + if (usize == 0) + { + *exp = 0; + *digit_ptr = 0; + return digit_ptr; + } + + str = (unsigned char *) digit_ptr; + + /* Allocate temporary digit space. We can't put digits directly in the user + area, since we almost always generate more digits than requested. */ + tstr = (unsigned char *) TMP_ALLOC (n_digits + 3 * BITS_PER_MP_LIMB); + + if (usize < 0) + { + *digit_ptr = '-'; + str++; + usize = -usize; + } + + digits_computed_so_far = 0; + + if (uexp > usize) + { + /* The number has just an integral part. */ + mp_size_t rsize; + mp_size_t exp_in_limbs; + mp_size_t msize; + mp_ptr tp, xp, mp; + int cnt; + mp_limb_t cy; + mp_size_t start_str; + mp_size_t n_limbs; + + n_limbs = 2 + ((mp_size_t) (n_digits / __mp_bases[base].chars_per_bit_exactly) + / BITS_PER_MP_LIMB); + + /* Compute n such that [u/B^n] contains (somewhat) more than n_digits + digits. (We compute less than that only if that is an exact number, + i.e., exp is small enough.) */ + + exp_in_limbs = uexp; + + if (n_limbs >= exp_in_limbs) + { + /* The number is so small that we convert the entire number. */ + exp_in_base = 0; + rp = (mp_ptr) TMP_ALLOC (exp_in_limbs * BYTES_PER_MP_LIMB); + MPN_ZERO (rp, exp_in_limbs - usize); + MPN_COPY (rp + (exp_in_limbs - usize), u->_mp_d, usize); + rsize = exp_in_limbs; + } + else + { + exp_in_limbs -= n_limbs; + exp_in_base = (((exp_in_limbs * BITS_PER_MP_LIMB - 1)) + * __mp_bases[base].chars_per_bit_exactly); + + rsize = exp_in_limbs + 1; + rp = (mp_ptr) TMP_ALLOC (rsize * BYTES_PER_MP_LIMB); + tp = (mp_ptr) TMP_ALLOC (rsize * BYTES_PER_MP_LIMB); + + rp[0] = base; + rsize = 1; + + count_leading_zeros (cnt, exp_in_base); + for (i = BITS_PER_MP_LIMB - cnt - 2; i >= 0; i--) + { + mpn_mul_n (tp, rp, rp, rsize); + rsize = 2 * rsize; + rsize -= tp[rsize - 1] == 0; + xp = tp; tp = rp; rp = xp; + + if (((exp_in_base >> i) & 1) != 0) + { + cy = mpn_mul_1 (rp, rp, rsize, (mp_limb_t) base); + rp[rsize] = cy; + rsize += cy != 0; + } + } + + mp = u->_mp_d; + msize = usize; + + { + mp_ptr qp; + mp_limb_t qflag; + mp_size_t xtra; + if (msize < rsize) + { + mp_ptr tmp = (mp_ptr) TMP_ALLOC ((rsize+1)* BYTES_PER_MP_LIMB); + MPN_ZERO (tmp, rsize - msize); + MPN_COPY (tmp + rsize - msize, mp, msize); + mp = tmp; + msize = rsize; + } + else + { + mp_ptr tmp = (mp_ptr) TMP_ALLOC ((msize+1)* BYTES_PER_MP_LIMB); + MPN_COPY (tmp, mp, msize); + mp = tmp; + } + count_leading_zeros (cnt, rp[rsize - 1]); + cy = 0; + if (cnt != 0) + { + mpn_lshift (rp, rp, rsize, cnt); + cy = mpn_lshift (mp, mp, msize, cnt); + if (cy) + mp[msize++] = cy; + } + + { + mp_size_t qsize = n_limbs + (cy != 0); + qp = (mp_ptr) TMP_ALLOC ((qsize + 1) * BYTES_PER_MP_LIMB); + xtra = qsize - (msize - rsize); + qflag = mpn_divrem (qp, xtra, mp, msize, rp, rsize); + qp[qsize] = qflag; + rsize = qsize + qflag; + rp = qp; + } + } + } + + str_size = mpn_get_str (tstr, base, rp, rsize); + + if (str_size > n_digits + 3 * BITS_PER_MP_LIMB) + abort (); + + start_str = 0; + while (tstr[start_str] == 0) + start_str++; + + for (i = start_str; i < (int) str_size; i++) + { + tstr[digits_computed_so_far++] = tstr[i]; + if (digits_computed_so_far > n_digits) + break; + } + exp_in_base = exp_in_base + str_size - start_str; + goto finish_up; + } + + exp_in_base = 0; + + if (uexp > 0) + { + /* The number has an integral part, convert that first. + If there is a fractional part too, it will be handled later. */ + mp_size_t start_str; + + rp = (mp_ptr) TMP_ALLOC (uexp * BYTES_PER_MP_LIMB); + up = u->_mp_d + usize - uexp; + MPN_COPY (rp, up, uexp); + + str_size = mpn_get_str (tstr, base, rp, uexp); + + start_str = 0; + while (tstr[start_str] == 0) + start_str++; + + for (i = start_str; i < (int) str_size; i++) + { + tstr[digits_computed_so_far++] = tstr[i]; + if (digits_computed_so_far > n_digits) + { + exp_in_base = str_size - start_str; + goto finish_up; + } + } + + exp_in_base = str_size - start_str; + /* Modify somewhat and fall out to convert fraction... */ + usize -= uexp; + uexp = 0; + } + + if (usize <= 0) + goto finish_up; + + /* Convert the fraction. */ + { + mp_size_t rsize, msize; + mp_ptr rp, tp, xp, mp; + int cnt; + mp_limb_t cy; + mp_exp_t nexp; + + big_base = __mp_bases[base].big_base; + dig_per_u = __mp_bases[base].chars_per_limb; + + /* Hack for correctly (although not efficiently) converting to bases that + are powers of 2. If we deem it important, we could handle powers of 2 + by shifting and masking (just like mpn_get_str). */ + if (big_base < 10) /* logarithm of base when power of two */ + { + int logbase = big_base; + if (dig_per_u * logbase == BITS_PER_MP_LIMB) + dig_per_u--; + big_base = (mp_limb_t) 1 << (dig_per_u * logbase); + /* fall out to general code... */ + } + +#if 0 + if (0 && uexp == 0) + { + rp = (mp_ptr) TMP_ALLOC (usize * BYTES_PER_MP_LIMB); + up = u->_mp_d; + MPN_COPY (rp, up, usize); + rsize = usize; + nexp = 0; + } + else + {} +#endif + uexp = -uexp; + if (u->_mp_d[usize - 1] == 0) + cnt = 0; + else + count_leading_zeros (cnt, u->_mp_d[usize - 1]); + + nexp = ((uexp * BITS_PER_MP_LIMB) + cnt) + * __mp_bases[base].chars_per_bit_exactly; + + if (nexp == 0) + { + rp = (mp_ptr) TMP_ALLOC (usize * BYTES_PER_MP_LIMB); + up = u->_mp_d; + MPN_COPY (rp, up, usize); + rsize = usize; + } + else + { + rsize = uexp + 2; + rp = (mp_ptr) TMP_ALLOC (rsize * BYTES_PER_MP_LIMB); + tp = (mp_ptr) TMP_ALLOC (rsize * BYTES_PER_MP_LIMB); + + rp[0] = base; + rsize = 1; + + count_leading_zeros (cnt, nexp); + for (i = BITS_PER_MP_LIMB - cnt - 2; i >= 0; i--) + { + mpn_mul_n (tp, rp, rp, rsize); + rsize = 2 * rsize; + rsize -= tp[rsize - 1] == 0; + xp = tp; tp = rp; rp = xp; + + if (((nexp >> i) & 1) != 0) + { + cy = mpn_mul_1 (rp, rp, rsize, (mp_limb_t) base); + rp[rsize] = cy; + rsize += cy != 0; + } + } + + /* Did our multiplier (base^nexp) cancel with uexp? */ +#if 0 + if (uexp != rsize) + { + do + { + cy = mpn_mul_1 (rp, rp, rsize, big_base); + nexp += dig_per_u; + } + while (cy == 0); + rp[rsize++] = cy; + } +#endif + mp = u->_mp_d; + msize = usize; + + tp = (mp_ptr) TMP_ALLOC ((rsize + msize) * BYTES_PER_MP_LIMB); + if (rsize > msize) + cy = mpn_mul (tp, rp, rsize, mp, msize); + else + cy = mpn_mul (tp, mp, msize, rp, rsize); + rsize += msize; + rsize -= cy == 0; + rp = tp; + + /* If we already output digits (for an integral part) pad + leading zeros. */ + if (digits_computed_so_far != 0) + for (i = 0; i < nexp; i++) + tstr[digits_computed_so_far++] = 0; + } + + while (digits_computed_so_far <= n_digits) + { + /* For speed: skip trailing zeroes. */ + if (rp[0] == 0) + { + rp++; + rsize--; + if (rsize == 0) + { + n_digits = digits_computed_so_far; + break; + } + } + + cy = mpn_mul_1 (rp, rp, rsize, big_base); + if (digits_computed_so_far == 0 && cy == 0) + { + abort (); + nexp += dig_per_u; + continue; + } + /* Convert N1 from BIG_BASE to a string of digits in BASE + using single precision operations. */ + { + unsigned char *s = tstr + digits_computed_so_far + dig_per_u; + for (i = dig_per_u - 1; i >= 0; i--) + { + *--s = cy % base; + cy /= base; + } + } + digits_computed_so_far += dig_per_u; + } + if (exp_in_base == 0) + exp_in_base = -nexp; + } + + finish_up: + + /* We can have at most one leading 0. Remove it. */ + if (tstr[0] == 0) + { + tstr++; + digits_computed_so_far--; + exp_in_base--; + } + + /* We should normally have computed too many digits. Round the result + at the point indicated by n_digits. */ + if (digits_computed_so_far > n_digits) + { + /* Round the result. */ + if (tstr[n_digits] * 2 >= base) + { + digits_computed_so_far = n_digits; + for (i = n_digits - 1; i >= 0; i--) + { + unsigned int x; + x = ++(tstr[i]); + if ((int) x < base) + goto rounded_ok; + digits_computed_so_far--; + } + tstr[0] = 1; + digits_computed_so_far = 1; + exp_in_base++; + rounded_ok:; + } + } + + /* We might have fewer digits than requested as a result of rounding above, + (i.e. 0.999999 => 1.0) or because we have a number that simply doesn't + need many digits in this base (i.e., 0.125 in base 10). */ + if (n_digits > digits_computed_so_far) + n_digits = digits_computed_so_far; + + /* Remove trailing 0. There can be many zeros. */ + while (n_digits != 0 && tstr[n_digits - 1] == 0) + n_digits--; + + /* Translate to ascii and null-terminate. */ + for (i = 0; i < (int) n_digits; i++) + *str++ = num_to_text[tstr[i]]; + *str = 0; + *exp = exp_in_base; + TMP_FREE (marker); + return digit_ptr; +} + +#if COPY_THIS_TO_OTHER_PLACES + /* Use this expression in lots of places in the library instead of the + count_leading_zeros+expression that is used currently. This expression + is much more accurate and will save odles of memory. */ + rsize = ((mp_size_t) (exp_in_base / __mp_bases[base].chars_per_bit_exactly) + + BITS_PER_MP_LIMB) / BITS_PER_MP_LIMB; +#endif diff --git a/lib/gmp/mpf/iset_d.c b/lib/gmp/mpf/iset_d.c new file mode 100644 index 00000000..3d4427ea --- /dev/null +++ b/lib/gmp/mpf/iset_d.c @@ -0,0 +1,40 @@ +/* mpf_init_set_d -- Initialize a float and assign it from a double. + +Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +void +#if __STDC__ +mpf_init_set_d (mpf_ptr r, double val) +#else +mpf_init_set_d (r, val) + mpf_ptr r; + double val; +#endif +{ + mp_size_t prec = __gmp_default_fp_limb_precision; + r->_mp_d = (mp_ptr) (*_mp_allocate_func) ((prec + 1) * BYTES_PER_MP_LIMB); + r->_mp_prec = prec; + + mpf_set_d (r, val); +} diff --git a/lib/gmp/mpf/set_d.c b/lib/gmp/mpf/set_d.c new file mode 100644 index 00000000..a9fcfed6 --- /dev/null +++ b/lib/gmp/mpf/set_d.c @@ -0,0 +1,48 @@ +/* mpf_set_d -- Assign a float from a IEEE double. + +Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +void +#if __STDC__ +mpf_set_d (mpf_ptr r, double d) +#else +mpf_set_d (r, d) + mpf_ptr r; + double d; +#endif +{ + int negative; + + if (d == 0) + { + SIZ(r) = 0; + EXP(r) = 0; + return; + } + negative = d < 0; + d = ABS (d); + + EXP(r) = __gmp_extract_double (PTR(r), d); + SIZ(r) = negative ? -LIMBS_PER_DOUBLE : LIMBS_PER_DOUBLE; +} diff --git a/lib/gmp/mpf/set_dfl_prec.c b/lib/gmp/mpf/set_dfl_prec.c new file mode 100644 index 00000000..c8db2d6e --- /dev/null +++ b/lib/gmp/mpf/set_dfl_prec.c @@ -0,0 +1,41 @@ +/* mpf_set_default_prec -- + +Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +mp_size_t __gmp_default_fp_limb_precision + = (53 + 2 * BITS_PER_MP_LIMB - 1) / BITS_PER_MP_LIMB; + +void +#if __STDC__ +mpf_set_default_prec (unsigned long int prec_in_bits) +#else +mpf_set_default_prec (prec_in_bits) + unsigned long int prec_in_bits; +#endif +{ + mp_size_t prec; + + prec = (MAX (53, prec_in_bits) + 2 * BITS_PER_MP_LIMB - 1)/BITS_PER_MP_LIMB; + __gmp_default_fp_limb_precision = prec; +} diff --git a/lib/gmp/mpn/Makefile.am b/lib/gmp/mpn/Makefile.am new file mode 100644 index 00000000..80b7c64d --- /dev/null +++ b/lib/gmp/mpn/Makefile.am @@ -0,0 +1,10 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +INCLUDES = -I$(srcdir) -I$(srcdir)/.. -I$(top_srcdir) -I$(top_srcdir)/src \ + -I$(top_srcdir)/intl + +noinst_LIBRARIES = libmpn.a +libmpn_a_SOURCES = add_n.c addmul_1.c cmp.c divrem.c get_str.c \ +inlines.c lshift.c mp_bases.c mul.c mul_1.c mul_n.c sub_n.c submul_1.c + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/gmp/mpn/add_n.c b/lib/gmp/mpn/add_n.c new file mode 100644 index 00000000..ecaec46c --- /dev/null +++ b/lib/gmp/mpn/add_n.c @@ -0,0 +1,63 @@ +/* mpn_add_n -- Add two limb vectors of equal, non-zero length. + +Copyright (C) 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +mp_limb_t +#if __STDC__ +mpn_add_n (mp_ptr res_ptr, mp_srcptr s1_ptr, mp_srcptr s2_ptr, mp_size_t size) +#else +mpn_add_n (res_ptr, s1_ptr, s2_ptr, size) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_srcptr s2_ptr; + mp_size_t size; +#endif +{ + register mp_limb_t x, y, cy; + register mp_size_t j; + + /* The loop counter and index J goes from -SIZE to -1. This way + the loop becomes faster. */ + j = -size; + + /* Offset the base pointers to compensate for the negative indices. */ + s1_ptr -= j; + s2_ptr -= j; + res_ptr -= j; + + cy = 0; + do + { + y = s2_ptr[j]; + x = s1_ptr[j]; + y += cy; /* add previous carry to one addend */ + cy = (y < cy); /* get out carry from that addition */ + y = x + y; /* add other addend */ + cy = (y < x) + cy; /* get out carry from that add, combine */ + res_ptr[j] = y; + } + while (++j != 0); + + return cy; +} diff --git a/lib/gmp/mpn/addmul_1.c b/lib/gmp/mpn/addmul_1.c new file mode 100644 index 00000000..ec580917 --- /dev/null +++ b/lib/gmp/mpn/addmul_1.c @@ -0,0 +1,66 @@ +/* mpn_addmul_1 -- multiply the S1_SIZE long limb vector pointed to by S1_PTR + by S2_LIMB, add the S1_SIZE least significant limbs of the product to the + limb vector pointed to by RES_PTR. Return the most significant limb of + the product, adjusted for carry-out from the addition. + +Copyright (C) 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +mp_limb_t +mpn_addmul_1 (res_ptr, s1_ptr, s1_size, s2_limb) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + mp_size_t s1_size; + register mp_limb_t s2_limb; +{ + register mp_limb_t cy_limb; + register mp_size_t j; + register mp_limb_t prod_high, prod_low; + register mp_limb_t x; + + /* The loop counter and index J goes from -SIZE to -1. This way + the loop becomes faster. */ + j = -s1_size; + + /* Offset the base pointers to compensate for the negative indices. */ + res_ptr -= j; + s1_ptr -= j; + + cy_limb = 0; + do + { + umul_ppmm (prod_high, prod_low, s1_ptr[j], s2_limb); + + prod_low += cy_limb; + cy_limb = (prod_low < cy_limb) + prod_high; + + x = res_ptr[j]; + prod_low = x + prod_low; + cy_limb += (prod_low < x); + res_ptr[j] = prod_low; + } + while (++j != 0); + + return cy_limb; +} diff --git a/lib/gmp/mpn/cmp.c b/lib/gmp/mpn/cmp.c new file mode 100644 index 00000000..95d44f95 --- /dev/null +++ b/lib/gmp/mpn/cmp.c @@ -0,0 +1,57 @@ +/* mpn_cmp -- Compare two low-level natural-number integers. + +Copyright (C) 1991, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +/* Compare OP1_PTR/OP1_SIZE with OP2_PTR/OP2_SIZE. + There are no restrictions on the relative sizes of + the two arguments. + Return 1 if OP1 > OP2, 0 if they are equal, and -1 if OP1 < OP2. */ + +int +#if __STDC__ +mpn_cmp (mp_srcptr op1_ptr, mp_srcptr op2_ptr, mp_size_t size) +#else +mpn_cmp (op1_ptr, op2_ptr, size) + mp_srcptr op1_ptr; + mp_srcptr op2_ptr; + mp_size_t size; +#endif +{ + mp_size_t i; + mp_limb_t op1_word, op2_word; + + for (i = size - 1; i >= 0; i--) + { + op1_word = op1_ptr[i]; + op2_word = op2_ptr[i]; + if (op1_word != op2_word) + goto diff; + } + return 0; + diff: + /* This can *not* be simplified to + op2_word - op2_word + since that expression might give signed overflow. */ + return (op1_word > op2_word) ? 1 : -1; +} diff --git a/lib/gmp/mpn/divrem.c b/lib/gmp/mpn/divrem.c new file mode 100644 index 00000000..1b41f6c9 --- /dev/null +++ b/lib/gmp/mpn/divrem.c @@ -0,0 +1,246 @@ +/* mpn_divrem -- Divide natural numbers, producing both remainder and + quotient. + +Copyright (C) 1993, 1994, 1995, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +/* Divide num (NP/NSIZE) by den (DP/DSIZE) and write + the NSIZE-DSIZE least significant quotient limbs at QP + and the DSIZE long remainder at NP. If QEXTRA_LIMBS is + non-zero, generate that many fraction bits and append them after the + other quotient limbs. + Return the most significant limb of the quotient, this is always 0 or 1. + + Preconditions: + 0. NSIZE >= DSIZE. + 1. The most significant bit of the divisor must be set. + 2. QP must either not overlap with the input operands at all, or + QP + DSIZE >= NP must hold true. (This means that it's + possible to put the quotient in the high part of NUM, right after the + remainder in NUM. + 3. NSIZE >= DSIZE, even if QEXTRA_LIMBS is non-zero. */ + +mp_limb_t +#if __STDC__ +mpn_divrem (mp_ptr qp, mp_size_t qextra_limbs, + mp_ptr np, mp_size_t nsize, + mp_srcptr dp, mp_size_t dsize) +#else +mpn_divrem (qp, qextra_limbs, np, nsize, dp, dsize) + mp_ptr qp; + mp_size_t qextra_limbs; + mp_ptr np; + mp_size_t nsize; + mp_srcptr dp; + mp_size_t dsize; +#endif +{ + mp_limb_t most_significant_q_limb = 0; + + switch (dsize) + { + case 0: + /* We are asked to divide by zero, so go ahead and do it! (To make + the compiler not remove this statement, return the value.) */ + return 1 / dsize; + + case 1: + { + mp_size_t i; + mp_limb_t n1; + mp_limb_t d; + + d = dp[0]; + n1 = np[nsize - 1]; + + if (n1 >= d) + { + n1 -= d; + most_significant_q_limb = 1; + } + + qp += qextra_limbs; + for (i = nsize - 2; i >= 0; i--) + udiv_qrnnd (qp[i], n1, n1, np[i], d); + qp -= qextra_limbs; + + for (i = qextra_limbs - 1; i >= 0; i--) + udiv_qrnnd (qp[i], n1, n1, 0, d); + + np[0] = n1; + } + break; + + case 2: + { + mp_size_t i; + mp_limb_t n1, n0, n2; + mp_limb_t d1, d0; + + np += nsize - 2; + d1 = dp[1]; + d0 = dp[0]; + n1 = np[1]; + n0 = np[0]; + + if (n1 >= d1 && (n1 > d1 || n0 >= d0)) + { + sub_ddmmss (n1, n0, n1, n0, d1, d0); + most_significant_q_limb = 1; + } + + for (i = qextra_limbs + nsize - 2 - 1; i >= 0; i--) + { + mp_limb_t q; + mp_limb_t r; + + if (i >= qextra_limbs) + np--; + else + np[0] = 0; + + if (n1 == d1) + { + /* Q should be either 111..111 or 111..110. Need special + treatment of this rare case as normal division would + give overflow. */ + q = ~(mp_limb_t) 0; + + r = n0 + d1; + if (r < d1) /* Carry in the addition? */ + { + add_ssaaaa (n1, n0, r - d0, np[0], 0, d0); + qp[i] = q; + continue; + } + n1 = d0 - (d0 != 0); + n0 = -d0; + } + else + { + udiv_qrnnd (q, r, n1, n0, d1); + umul_ppmm (n1, n0, d0, q); + } + + n2 = np[0]; + q_test: + if (n1 > r || (n1 == r && n0 > n2)) + { + /* The estimated Q was too large. */ + q--; + + sub_ddmmss (n1, n0, n1, n0, 0, d0); + r += d1; + if (r >= d1) /* If not carry, test Q again. */ + goto q_test; + } + + qp[i] = q; + sub_ddmmss (n1, n0, r, n2, n1, n0); + } + np[1] = n1; + np[0] = n0; + } + break; + + default: + { + mp_size_t i; + mp_limb_t dX, d1, n0; + + np += nsize - dsize; + dX = dp[dsize - 1]; + d1 = dp[dsize - 2]; + n0 = np[dsize - 1]; + + if (n0 >= dX) + { + if (n0 > dX || mpn_cmp (np, dp, dsize - 1) >= 0) + { + mpn_sub_n (np, np, dp, dsize); + n0 = np[dsize - 1]; + most_significant_q_limb = 1; + } + } + + for (i = qextra_limbs + nsize - dsize - 1; i >= 0; i--) + { + mp_limb_t q; + mp_limb_t n1, n2; + mp_limb_t cy_limb; + + if (i >= qextra_limbs) + { + np--; + n2 = np[dsize]; + } + else + { + n2 = np[dsize - 1]; + MPN_COPY_DECR (np + 1, np, dsize); + np[0] = 0; + } + + if (n0 == dX) + /* This might over-estimate q, but it's probably not worth + the extra code here to find out. */ + q = ~(mp_limb_t) 0; + else + { + mp_limb_t r; + + udiv_qrnnd (q, r, n0, np[dsize - 1], dX); + umul_ppmm (n1, n0, d1, q); + + while (n1 > r || (n1 == r && n0 > np[dsize - 2])) + { + q--; + r += dX; + if (r < dX) /* I.e. "carry in previous addition?" */ + break; + n1 -= n0 < d1; + n0 -= d1; + } + } + + /* Possible optimization: We already have (q * n0) and (1 * n1) + after the calculation of q. Taking advantage of that, we + could make this loop make two iterations less. */ + + cy_limb = mpn_submul_1 (np, dp, dsize, q); + + if (n2 != cy_limb) + { + mpn_add_n (np, np, dp, dsize); + q--; + } + + qp[i] = q; + n0 = np[dsize - 1]; + } + } + } + + return most_significant_q_limb; +} diff --git a/lib/gmp/mpn/get_str.c b/lib/gmp/mpn/get_str.c new file mode 100644 index 00000000..77c16436 --- /dev/null +++ b/lib/gmp/mpn/get_str.c @@ -0,0 +1,212 @@ +/* mpn_get_str -- Convert a MSIZE long limb vector pointed to by MPTR + to a printable string in STR in base BASE. + +Copyright (C) 1991, 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +/* Convert the limb vector pointed to by MPTR and MSIZE long to a + char array, using base BASE for the result array. Store the + result in the character array STR. STR must point to an array with + space for the largest possible number represented by a MSIZE long + limb vector + 1 extra character. + + The result is NOT in Ascii, to convert it to printable format, add + '0' or 'A' depending on the base and range. + + Return the number of digits in the result string. + This may include some leading zeros. + + The limb vector pointed to by MPTR is clobbered. */ + +size_t +mpn_get_str (str, base, mptr, msize) + unsigned char *str; + int base; + mp_ptr mptr; + mp_size_t msize; +{ + mp_limb_t big_base; +#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME + int normalization_steps; +#endif +#if UDIV_TIME > 2 * UMUL_TIME + mp_limb_t big_base_inverted; +#endif + unsigned int dig_per_u; + mp_size_t out_len; + register unsigned char *s; + + big_base = __mp_bases[base].big_base; + + s = str; + + /* Special case zero, as the code below doesn't handle it. */ + if (msize == 0) + { + s[0] = 0; + return 1; + } + + if ((base & (base - 1)) == 0) + { + /* The base is a power of 2. Make conversion from most + significant side. */ + mp_limb_t n1, n0; + register int bits_per_digit = big_base; + register int x; + register int bit_pos; + register int i; + + n1 = mptr[msize - 1]; + count_leading_zeros (x, n1); + + /* BIT_POS should be R when input ends in least sign. nibble, + R + bits_per_digit * n when input ends in n:th least significant + nibble. */ + + { + int bits; + + bits = BITS_PER_MP_LIMB * msize - x; + x = bits % bits_per_digit; + if (x != 0) + bits += bits_per_digit - x; + bit_pos = bits - (msize - 1) * BITS_PER_MP_LIMB; + } + + /* Fast loop for bit output. */ + i = msize - 1; + for (;;) + { + bit_pos -= bits_per_digit; + while (bit_pos >= 0) + { + *s++ = (n1 >> bit_pos) & ((1 << bits_per_digit) - 1); + bit_pos -= bits_per_digit; + } + i--; + if (i < 0) + break; + n0 = (n1 << -bit_pos) & ((1 << bits_per_digit) - 1); + n1 = mptr[i]; + bit_pos += BITS_PER_MP_LIMB; + *s++ = n0 | (n1 >> bit_pos); + } + + *s = 0; + + return s - str; + } + else + { + /* General case. The base is not a power of 2. Make conversion + from least significant end. */ + + /* If udiv_qrnnd only handles divisors with the most significant bit + set, prepare BIG_BASE for being a divisor by shifting it to the + left exactly enough to set the most significant bit. */ +#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME + count_leading_zeros (normalization_steps, big_base); + big_base <<= normalization_steps; +#if UDIV_TIME > 2 * UMUL_TIME + /* Get the fixed-point approximation to 1/(BIG_BASE << NORMALIZATION_STEPS). */ + big_base_inverted = __mp_bases[base].big_base_inverted; +#endif +#endif + + dig_per_u = __mp_bases[base].chars_per_limb; + out_len = ((size_t) msize * BITS_PER_MP_LIMB + * __mp_bases[base].chars_per_bit_exactly) + 1; + s += out_len; + + while (msize != 0) + { + int i; + mp_limb_t n0, n1; + +#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME + /* If we shifted BIG_BASE above, shift the dividend too, to get + the right quotient. We need to do this every loop, + since the intermediate quotients are OK, but the quotient from + one turn in the loop is going to be the dividend in the + next turn, and the dividend needs to be up-shifted. */ + if (normalization_steps != 0) + { + n0 = mpn_lshift (mptr, mptr, msize, normalization_steps); + + /* If the shifting gave a carry out limb, store it and + increase the length. */ + if (n0 != 0) + { + mptr[msize] = n0; + msize++; + } + } +#endif + + /* Divide the number at TP with BIG_BASE to get a quotient and a + remainder. The remainder is our new digit in base BIG_BASE. */ + i = msize - 1; + n1 = mptr[i]; + + if (n1 >= big_base) + n1 = 0; + else + { + msize--; + i--; + } + + for (; i >= 0; i--) + { + n0 = mptr[i]; +#if UDIV_TIME > 2 * UMUL_TIME + udiv_qrnnd_preinv (mptr[i], n1, n1, n0, big_base, big_base_inverted); +#else + udiv_qrnnd (mptr[i], n1, n1, n0, big_base); +#endif + } + +#if UDIV_NEEDS_NORMALIZATION || UDIV_TIME > 2 * UMUL_TIME + /* If we shifted above (at previous UDIV_NEEDS_NORMALIZATION tests) + the remainder will be up-shifted here. Compensate. */ + n1 >>= normalization_steps; +#endif + + /* Convert N1 from BIG_BASE to a string of digits in BASE + using single precision operations. */ + for (i = dig_per_u - 1; i >= 0; i--) + { + *--s = n1 % base; + n1 /= base; + if (n1 == 0 && msize == 0) + break; + } + } + + while (s != str) + *--s = 0; + return out_len; + } +} diff --git a/lib/gmp/mpn/inlines.c b/lib/gmp/mpn/inlines.c new file mode 100644 index 00000000..5c137d34 --- /dev/null +++ b/lib/gmp/mpn/inlines.c @@ -0,0 +1,4 @@ +#include +#define _FORCE_INLINES +#define _EXTERN_INLINE /* empty */ +#include "gmp.h" diff --git a/lib/gmp/mpn/lshift.c b/lib/gmp/mpn/lshift.c new file mode 100644 index 00000000..1d73afbc --- /dev/null +++ b/lib/gmp/mpn/lshift.c @@ -0,0 +1,88 @@ +/* mpn_lshift -- Shift left low level. + +Copyright (C) 1991, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +/* Shift U (pointed to by UP and USIZE digits long) CNT bits to the left + and store the USIZE least significant digits of the result at WP. + Return the bits shifted out from the most significant digit. + + Argument constraints: + 1. 0 < CNT < BITS_PER_MP_LIMB + 2. If the result is to be written over the input, WP must be >= UP. +*/ + +mp_limb_t +#if __STDC__ +mpn_lshift (register mp_ptr wp, + register mp_srcptr up, mp_size_t usize, + register unsigned int cnt) +#else +mpn_lshift (wp, up, usize, cnt) + register mp_ptr wp; + register mp_srcptr up; + mp_size_t usize; + register unsigned int cnt; +#endif +{ + register mp_limb_t high_limb, low_limb; + register unsigned sh_1, sh_2; + register mp_size_t i; + mp_limb_t retval; + +#ifdef DEBUG + if (usize == 0 || cnt == 0) + abort (); +#endif + + sh_1 = cnt; +#if 0 + if (sh_1 == 0) + { + if (wp != up) + { + /* Copy from high end to low end, to allow specified input/output + overlapping. */ + for (i = usize - 1; i >= 0; i--) + wp[i] = up[i]; + } + return 0; + } +#endif + + wp += 1; + sh_2 = BITS_PER_MP_LIMB - sh_1; + i = usize - 1; + low_limb = up[i]; + retval = low_limb >> sh_2; + high_limb = low_limb; + while (--i >= 0) + { + low_limb = up[i]; + wp[i] = (high_limb << sh_1) | (low_limb >> sh_2); + high_limb = low_limb; + } + wp[i] = high_limb << sh_1; + + return retval; +} diff --git a/lib/gmp/mpn/mp_bases.c b/lib/gmp/mpn/mp_bases.c new file mode 100644 index 00000000..f2f6daef --- /dev/null +++ b/lib/gmp/mpn/mp_bases.c @@ -0,0 +1,550 @@ +/* __mp_bases -- Structure for conversion between internal binary + format and strings in base 2..255. The fields are explained in + gmp-impl.h. + + +Copyright (C) 1991, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +#if BITS_PER_MP_LIMB == 32 +const struct bases __mp_bases[256] = +{ + /* 0 */ {0, 0.0, 0, 0}, + /* 1 */ {0, 1e38, 0, 0}, + /* 2 */ {32, 1.00000000, 0x1, 0x0}, + /* 3 */ {20, 0.63092975, 0xcfd41b91, 0x3b563c24}, + /* 4 */ {16, 0.50000000, 0x2, 0x0}, + /* 5 */ {13, 0.43067656, 0x48c27395, 0xc25c2684}, + /* 6 */ {12, 0.38685281, 0x81bf1000, 0xf91bd1b6}, + /* 7 */ {11, 0.35620719, 0x75db9c97, 0x1607a2cb}, + /* 8 */ {10, 0.33333333, 0x3, 0x0}, + /* 9 */ {10, 0.31546488, 0xcfd41b91, 0x3b563c24}, + /* 10 */ {9, 0.30103000, 0x3b9aca00, 0x12e0be82}, + /* 11 */ {9, 0.28906483, 0x8c8b6d2b, 0xd24cde04}, + /* 12 */ {8, 0.27894295, 0x19a10000, 0x3fa39ab5}, + /* 13 */ {8, 0.27023815, 0x309f1021, 0x50f8ac5f}, + /* 14 */ {8, 0.26264954, 0x57f6c100, 0x74843b1e}, + /* 15 */ {8, 0.25595802, 0x98c29b81, 0xad0326c2}, + /* 16 */ {8, 0.25000000, 0x4, 0x0}, + /* 17 */ {7, 0.24465054, 0x18754571, 0x4ef0b6bd}, + /* 18 */ {7, 0.23981247, 0x247dbc80, 0xc0fc48a1}, + /* 19 */ {7, 0.23540891, 0x3547667b, 0x33838942}, + /* 20 */ {7, 0.23137821, 0x4c4b4000, 0xad7f29ab}, + /* 21 */ {7, 0.22767025, 0x6b5a6e1d, 0x313c3d15}, + /* 22 */ {7, 0.22424382, 0x94ace180, 0xb8cca9e0}, + /* 23 */ {7, 0.22106473, 0xcaf18367, 0x42ed6de9}, + /* 24 */ {6, 0.21810429, 0xb640000, 0x67980e0b}, + /* 25 */ {6, 0.21533828, 0xe8d4a51, 0x19799812}, + /* 26 */ {6, 0.21274605, 0x1269ae40, 0xbce85396}, + /* 27 */ {6, 0.21030992, 0x17179149, 0x62c103a9}, + /* 28 */ {6, 0.20801460, 0x1cb91000, 0x1d353d43}, + /* 29 */ {6, 0.20584683, 0x23744899, 0xce1decea}, + /* 30 */ {6, 0.20379505, 0x2b73a840, 0x790fc511}, + /* 31 */ {6, 0.20184909, 0x34e63b41, 0x35b865a0}, + /* 32 */ {6, 0.20000000, 0x5, 0x0}, + /* 33 */ {6, 0.19823986, 0x4cfa3cc1, 0xa9aed1b3}, + /* 34 */ {6, 0.19656163, 0x5c13d840, 0x63dfc229}, + /* 35 */ {6, 0.19495902, 0x6d91b519, 0x2b0fee30}, + /* 36 */ {6, 0.19342640, 0x81bf1000, 0xf91bd1b6}, + /* 37 */ {6, 0.19195872, 0x98ede0c9, 0xac89c3a9}, + /* 38 */ {6, 0.19055141, 0xb3773e40, 0x6d2c32fe}, + /* 39 */ {6, 0.18920036, 0xd1bbc4d1, 0x387907c9}, + /* 40 */ {6, 0.18790182, 0xf4240000, 0xc6f7a0b}, + /* 41 */ {5, 0.18665241, 0x6e7d349, 0x28928154}, + /* 42 */ {5, 0.18544902, 0x7ca30a0, 0x6e8629d}, + /* 43 */ {5, 0.18428883, 0x8c32bbb, 0xd373dca0}, + /* 44 */ {5, 0.18316925, 0x9d46c00, 0xa0b17895}, + /* 45 */ {5, 0.18208790, 0xaffacfd, 0x746811a5}, + /* 46 */ {5, 0.18104260, 0xc46bee0, 0x4da6500f}, + /* 47 */ {5, 0.18003133, 0xdab86ef, 0x2ba23582}, + /* 48 */ {5, 0.17905223, 0xf300000, 0xdb20a88}, + /* 49 */ {5, 0.17810359, 0x10d63af1, 0xe68d5ce4}, + /* 50 */ {5, 0.17718382, 0x12a05f20, 0xb7cdfd9d}, + /* 51 */ {5, 0.17629143, 0x1490aae3, 0x8e583933}, + /* 52 */ {5, 0.17542506, 0x16a97400, 0x697cc3ea}, + /* 53 */ {5, 0.17458343, 0x18ed2825, 0x48a5ca6c}, + /* 54 */ {5, 0.17376534, 0x1b5e4d60, 0x2b52db16}, + /* 55 */ {5, 0.17296969, 0x1dff8297, 0x111586a6}, + /* 56 */ {5, 0.17219543, 0x20d38000, 0xf31d2b36}, + /* 57 */ {5, 0.17144160, 0x23dd1799, 0xc8d76d19}, + /* 58 */ {5, 0.17070728, 0x271f35a0, 0xa2cb1eb4}, + /* 59 */ {5, 0.16999162, 0x2a9ce10b, 0x807c3ec3}, + /* 60 */ {5, 0.16929381, 0x2e593c00, 0x617ec8bf}, + /* 61 */ {5, 0.16861310, 0x3257844d, 0x45746cbe}, + /* 62 */ {5, 0.16794878, 0x369b13e0, 0x2c0aa273}, + /* 63 */ {5, 0.16730018, 0x3b27613f, 0x14f90805}, + /* 64 */ {5, 0.16666667, 0x6, 0x0}, + /* 65 */ {5, 0.16604765, 0x4528a141, 0xd9cf0829}, + /* 66 */ {5, 0.16544255, 0x4aa51420, 0xb6fc4841}, + /* 67 */ {5, 0.16485086, 0x50794633, 0x973054cb}, + /* 68 */ {5, 0.16427205, 0x56a94400, 0x7a1dbe4b}, + /* 69 */ {5, 0.16370566, 0x5d393975, 0x5f7fcd7f}, + /* 70 */ {5, 0.16315122, 0x642d7260, 0x47196c84}, + /* 71 */ {5, 0.16260831, 0x6b8a5ae7, 0x30b43635}, + /* 72 */ {5, 0.16207652, 0x73548000, 0x1c1fa5f6}, + /* 73 */ {5, 0.16155547, 0x7b908fe9, 0x930634a}, + /* 74 */ {5, 0.16104477, 0x84435aa0, 0xef7f4a3c}, + /* 75 */ {5, 0.16054409, 0x8d71d25b, 0xcf5552d2}, + /* 76 */ {5, 0.16005307, 0x97210c00, 0xb1a47c8e}, + /* 77 */ {5, 0.15957142, 0xa1563f9d, 0x9634b43e}, + /* 78 */ {5, 0.15909881, 0xac16c8e0, 0x7cd3817d}, + /* 79 */ {5, 0.15863496, 0xb768278f, 0x65536761}, + /* 80 */ {5, 0.15817959, 0xc3500000, 0x4f8b588e}, + /* 81 */ {5, 0.15773244, 0xcfd41b91, 0x3b563c24}, + /* 82 */ {5, 0.15729325, 0xdcfa6920, 0x28928154}, + /* 83 */ {5, 0.15686177, 0xeac8fd83, 0x1721bfb0}, + /* 84 */ {5, 0.15643779, 0xf9461400, 0x6e8629d}, + /* 85 */ {4, 0.15602107, 0x31c84b1, 0x491cc17c}, + /* 86 */ {4, 0.15561139, 0x342ab10, 0x3a11d83b}, + /* 87 */ {4, 0.15520856, 0x36a2c21, 0x2be074cd}, + /* 88 */ {4, 0.15481238, 0x3931000, 0x1e7a02e7}, + /* 89 */ {4, 0.15442266, 0x3bd5ee1, 0x11d10edd}, + /* 90 */ {4, 0.15403922, 0x3e92110, 0x5d92c68}, + /* 91 */ {4, 0.15366189, 0x4165ef1, 0xf50dbfb2}, + /* 92 */ {4, 0.15329049, 0x4452100, 0xdf9f1316}, + /* 93 */ {4, 0.15292487, 0x4756fd1, 0xcb52a684}, + /* 94 */ {4, 0.15256487, 0x4a75410, 0xb8163e97}, + /* 95 */ {4, 0.15221035, 0x4dad681, 0xa5d8f269}, + /* 96 */ {4, 0.15186115, 0x5100000, 0x948b0fcd}, + /* 97 */ {4, 0.15151715, 0x546d981, 0x841e0215}, + /* 98 */ {4, 0.15117821, 0x57f6c10, 0x74843b1e}, + /* 99 */ {4, 0.15084420, 0x5b9c0d1, 0x65b11e6e}, + /* 100 */ {4, 0.15051500, 0x5f5e100, 0x5798ee23}, + /* 101 */ {4, 0.15019048, 0x633d5f1, 0x4a30b99b}, + /* 102 */ {4, 0.14987054, 0x673a910, 0x3d6e4d94}, + /* 103 */ {4, 0.14955506, 0x6b563e1, 0x314825b0}, + /* 104 */ {4, 0.14924394, 0x6f91000, 0x25b55f2e}, + /* 105 */ {4, 0.14893706, 0x73eb721, 0x1aadaccb}, + /* 106 */ {4, 0.14863434, 0x7866310, 0x10294ba2}, + /* 107 */ {4, 0.14833567, 0x7d01db1, 0x620f8f6}, + /* 108 */ {4, 0.14804096, 0x81bf100, 0xf91bd1b6}, + /* 109 */ {4, 0.14775011, 0x869e711, 0xe6d37b2a}, + /* 110 */ {4, 0.14746305, 0x8ba0a10, 0xd55cff6e}, + /* 111 */ {4, 0.14717969, 0x90c6441, 0xc4ad2db2}, + /* 112 */ {4, 0.14689994, 0x9610000, 0xb4b985cf}, + /* 113 */ {4, 0.14662372, 0x9b7e7c1, 0xa5782bef}, + /* 114 */ {4, 0.14635096, 0xa112610, 0x96dfdd2a}, + /* 115 */ {4, 0.14608158, 0xa6cc591, 0x88e7e509}, + /* 116 */ {4, 0.14581551, 0xacad100, 0x7b8813d3}, + /* 117 */ {4, 0.14555268, 0xb2b5331, 0x6eb8b595}, + /* 118 */ {4, 0.14529302, 0xb8e5710, 0x627289db}, + /* 119 */ {4, 0.14503647, 0xbf3e7a1, 0x56aebc07}, + /* 120 */ {4, 0.14478295, 0xc5c1000, 0x4b66dc33}, + /* 121 */ {4, 0.14453241, 0xcc6db61, 0x4094d8a3}, + /* 122 */ {4, 0.14428479, 0xd345510, 0x3632f7a5}, + /* 123 */ {4, 0.14404003, 0xda48871, 0x2c3bd1f0}, + /* 124 */ {4, 0.14379807, 0xe178100, 0x22aa4d5f}, + /* 125 */ {4, 0.14355885, 0xe8d4a51, 0x19799812}, + /* 126 */ {4, 0.14332233, 0xf05f010, 0x10a523e5}, + /* 127 */ {4, 0.14308844, 0xf817e01, 0x828a237}, + /* 128 */ {4, 0.14285714, 0x7, 0x0}, + /* 129 */ {4, 0.14262838, 0x10818201, 0xf04ec452}, + /* 130 */ {4, 0.14240211, 0x11061010, 0xe136444a}, + /* 131 */ {4, 0.14217828, 0x118db651, 0xd2af9589}, + /* 132 */ {4, 0.14195685, 0x12188100, 0xc4b42a83}, + /* 133 */ {4, 0.14173777, 0x12a67c71, 0xb73dccf5}, + /* 134 */ {4, 0.14152100, 0x1337b510, 0xaa4698c5}, + /* 135 */ {4, 0.14130649, 0x13cc3761, 0x9dc8f729}, + /* 136 */ {4, 0.14109421, 0x14641000, 0x91bf9a30}, + /* 137 */ {4, 0.14088412, 0x14ff4ba1, 0x86257887}, + /* 138 */ {4, 0.14067617, 0x159df710, 0x7af5c98c}, + /* 139 */ {4, 0.14047033, 0x16401f31, 0x702c01a0}, + /* 140 */ {4, 0.14026656, 0x16e5d100, 0x65c3ceb1}, + /* 141 */ {4, 0.14006482, 0x178f1991, 0x5bb91502}, + /* 142 */ {4, 0.13986509, 0x183c0610, 0x5207ec23}, + /* 143 */ {4, 0.13966731, 0x18eca3c1, 0x48ac9c19}, + /* 144 */ {4, 0.13947147, 0x19a10000, 0x3fa39ab5}, + /* 145 */ {4, 0.13927753, 0x1a592841, 0x36e98912}, + /* 146 */ {4, 0.13908545, 0x1b152a10, 0x2e7b3140}, + /* 147 */ {4, 0.13889521, 0x1bd51311, 0x2655840b}, + /* 148 */ {4, 0.13870677, 0x1c98f100, 0x1e7596ea}, + /* 149 */ {4, 0.13852011, 0x1d60d1b1, 0x16d8a20d}, + /* 150 */ {4, 0.13833519, 0x1e2cc310, 0xf7bfe87}, + /* 151 */ {4, 0.13815199, 0x1efcd321, 0x85d2492}, + /* 152 */ {4, 0.13797047, 0x1fd11000, 0x179a9f4}, + /* 153 */ {4, 0.13779062, 0x20a987e1, 0xf59e80eb}, + /* 154 */ {4, 0.13761241, 0x21864910, 0xe8b768db}, + /* 155 */ {4, 0.13743580, 0x226761f1, 0xdc39d6d5}, + /* 156 */ {4, 0.13726078, 0x234ce100, 0xd021c5d1}, + /* 157 */ {4, 0.13708732, 0x2436d4d1, 0xc46b5e37}, + /* 158 */ {4, 0.13691539, 0x25254c10, 0xb912f39c}, + /* 159 */ {4, 0.13674498, 0x26185581, 0xae150294}, + /* 160 */ {4, 0.13657605, 0x27100000, 0xa36e2eb1}, + /* 161 */ {4, 0.13640859, 0x280c5a81, 0x991b4094}, + /* 162 */ {4, 0.13624257, 0x290d7410, 0x8f19241e}, + /* 163 */ {4, 0.13607797, 0x2a135bd1, 0x8564e6b7}, + /* 164 */ {4, 0.13591477, 0x2b1e2100, 0x7bfbb5b4}, + /* 165 */ {4, 0.13575295, 0x2c2dd2f1, 0x72dadcc8}, + /* 166 */ {4, 0.13559250, 0x2d428110, 0x69ffc498}, + /* 167 */ {4, 0.13543338, 0x2e5c3ae1, 0x6167f154}, + /* 168 */ {4, 0.13527558, 0x2f7b1000, 0x5911016e}, + /* 169 */ {4, 0.13511908, 0x309f1021, 0x50f8ac5f}, + /* 170 */ {4, 0.13496386, 0x31c84b10, 0x491cc17c}, + /* 171 */ {4, 0.13480991, 0x32f6d0b1, 0x417b26d8}, + /* 172 */ {4, 0.13465720, 0x342ab100, 0x3a11d83b}, + /* 173 */ {4, 0.13450572, 0x3563fc11, 0x32dee622}, + /* 174 */ {4, 0.13435545, 0x36a2c210, 0x2be074cd}, + /* 175 */ {4, 0.13420637, 0x37e71341, 0x2514bb58}, + /* 176 */ {4, 0.13405847, 0x39310000, 0x1e7a02e7}, + /* 177 */ {4, 0.13391173, 0x3a8098c1, 0x180ea5d0}, + /* 178 */ {4, 0.13376614, 0x3bd5ee10, 0x11d10edd}, + /* 179 */ {4, 0.13362168, 0x3d311091, 0xbbfb88e}, + /* 180 */ {4, 0.13347832, 0x3e921100, 0x5d92c68}, + /* 181 */ {4, 0.13333607, 0x3ff90031, 0x1c024c}, + /* 182 */ {4, 0.13319491, 0x4165ef10, 0xf50dbfb2}, + /* 183 */ {4, 0.13305481, 0x42d8eea1, 0xea30efa3}, + /* 184 */ {4, 0.13291577, 0x44521000, 0xdf9f1316}, + /* 185 */ {4, 0.13277777, 0x45d16461, 0xd555c0c9}, + /* 186 */ {4, 0.13264079, 0x4756fd10, 0xcb52a684}, + /* 187 */ {4, 0.13250483, 0x48e2eb71, 0xc193881f}, + /* 188 */ {4, 0.13236988, 0x4a754100, 0xb8163e97}, + /* 189 */ {4, 0.13223591, 0x4c0e0f51, 0xaed8b724}, + /* 190 */ {4, 0.13210292, 0x4dad6810, 0xa5d8f269}, + /* 191 */ {4, 0.13197089, 0x4f535d01, 0x9d15039d}, + /* 192 */ {4, 0.13183981, 0x51000000, 0x948b0fcd}, + /* 193 */ {4, 0.13170967, 0x52b36301, 0x8c394d1d}, + /* 194 */ {4, 0.13158046, 0x546d9810, 0x841e0215}, + /* 195 */ {4, 0.13145216, 0x562eb151, 0x7c3784f8}, + /* 196 */ {4, 0.13132477, 0x57f6c100, 0x74843b1e}, + /* 197 */ {4, 0.13119827, 0x59c5d971, 0x6d02985d}, + /* 198 */ {4, 0.13107265, 0x5b9c0d10, 0x65b11e6e}, + /* 199 */ {4, 0.13094791, 0x5d796e61, 0x5e8e5c64}, + /* 200 */ {4, 0.13082402, 0x5f5e1000, 0x5798ee23}, + /* 201 */ {4, 0.13070099, 0x614a04a1, 0x50cf7bde}, + /* 202 */ {4, 0.13057879, 0x633d5f10, 0x4a30b99b}, + /* 203 */ {4, 0.13045743, 0x65383231, 0x43bb66bd}, + /* 204 */ {4, 0.13033688, 0x673a9100, 0x3d6e4d94}, + /* 205 */ {4, 0.13021715, 0x69448e91, 0x374842ee}, + /* 206 */ {4, 0.13009822, 0x6b563e10, 0x314825b0}, + /* 207 */ {4, 0.12998007, 0x6d6fb2c1, 0x2b6cde75}, + /* 208 */ {4, 0.12986271, 0x6f910000, 0x25b55f2e}, + /* 209 */ {4, 0.12974613, 0x71ba3941, 0x2020a2c5}, + /* 210 */ {4, 0.12963031, 0x73eb7210, 0x1aadaccb}, + /* 211 */ {4, 0.12951524, 0x7624be11, 0x155b891f}, + /* 212 */ {4, 0.12940092, 0x78663100, 0x10294ba2}, + /* 213 */ {4, 0.12928734, 0x7aafdeb1, 0xb160fe9}, + /* 214 */ {4, 0.12917448, 0x7d01db10, 0x620f8f6}, + /* 215 */ {4, 0.12906235, 0x7f5c3a21, 0x14930ef}, + /* 216 */ {4, 0.12895094, 0x81bf1000, 0xf91bd1b6}, + /* 217 */ {4, 0.12884022, 0x842a70e1, 0xefdcb0c7}, + /* 218 */ {4, 0.12873021, 0x869e7110, 0xe6d37b2a}, + /* 219 */ {4, 0.12862089, 0x891b24f1, 0xddfeb94a}, + /* 220 */ {4, 0.12851224, 0x8ba0a100, 0xd55cff6e}, + /* 221 */ {4, 0.12840428, 0x8e2ef9d1, 0xcceced50}, + /* 222 */ {4, 0.12829698, 0x90c64410, 0xc4ad2db2}, + /* 223 */ {4, 0.12819034, 0x93669481, 0xbc9c75f9}, + /* 224 */ {4, 0.12808435, 0x96100000, 0xb4b985cf}, + /* 225 */ {4, 0.12797901, 0x98c29b81, 0xad0326c2}, + /* 226 */ {4, 0.12787431, 0x9b7e7c10, 0xa5782bef}, + /* 227 */ {4, 0.12777024, 0x9e43b6d1, 0x9e1771a9}, + /* 228 */ {4, 0.12766680, 0xa1126100, 0x96dfdd2a}, + /* 229 */ {4, 0.12756398, 0xa3ea8ff1, 0x8fd05c41}, + /* 230 */ {4, 0.12746176, 0xa6cc5910, 0x88e7e509}, + /* 231 */ {4, 0.12736016, 0xa9b7d1e1, 0x8225759d}, + /* 232 */ {4, 0.12725915, 0xacad1000, 0x7b8813d3}, + /* 233 */ {4, 0.12715874, 0xafac2921, 0x750eccf9}, + /* 234 */ {4, 0.12705891, 0xb2b53310, 0x6eb8b595}, + /* 235 */ {4, 0.12695967, 0xb5c843b1, 0x6884e923}, + /* 236 */ {4, 0.12686100, 0xb8e57100, 0x627289db}, + /* 237 */ {4, 0.12676290, 0xbc0cd111, 0x5c80c07b}, + /* 238 */ {4, 0.12666537, 0xbf3e7a10, 0x56aebc07}, + /* 239 */ {4, 0.12656839, 0xc27a8241, 0x50fbb19b}, + /* 240 */ {4, 0.12647197, 0xc5c10000, 0x4b66dc33}, + /* 241 */ {4, 0.12637609, 0xc91209c1, 0x45ef7c7c}, + /* 242 */ {4, 0.12628075, 0xcc6db610, 0x4094d8a3}, + /* 243 */ {4, 0.12618595, 0xcfd41b91, 0x3b563c24}, + /* 244 */ {4, 0.12609168, 0xd3455100, 0x3632f7a5}, + /* 245 */ {4, 0.12599794, 0xd6c16d31, 0x312a60c3}, + /* 246 */ {4, 0.12590471, 0xda488710, 0x2c3bd1f0}, + /* 247 */ {4, 0.12581200, 0xdddab5a1, 0x2766aa45}, + /* 248 */ {4, 0.12571980, 0xe1781000, 0x22aa4d5f}, + /* 249 */ {4, 0.12562811, 0xe520ad61, 0x1e06233c}, + /* 250 */ {4, 0.12553692, 0xe8d4a510, 0x19799812}, + /* 251 */ {4, 0.12544622, 0xec940e71, 0x15041c33}, + /* 252 */ {4, 0.12535601, 0xf05f0100, 0x10a523e5}, + /* 253 */ {4, 0.12526629, 0xf4359451, 0xc5c2749}, + /* 254 */ {4, 0.12517705, 0xf817e010, 0x828a237}, + /* 255 */ {4, 0.12508829, 0xfc05fc01, 0x40a1423}, +}; +#endif +#if BITS_PER_MP_LIMB == 64 +const struct bases __mp_bases[256] = +{ + /* 0 */ {0, 0.0, 0, 0}, + /* 1 */ {0, 1e38, 0, 0}, + /* 2 */ {64, 1.00000000, 0x1, 0x0}, + /* 3 */ {40, 0.63092975, 0xa8b8b452291fe821L, 0x846d550e37b5063dL}, + /* 4 */ {32, 0.50000000, 0x2L, 0x0L}, + /* 5 */ {27, 0.43067656, 0x6765c793fa10079dL, 0x3ce9a36f23c0fc90L}, + /* 6 */ {24, 0.38685281, 0x41c21cb8e1000000L, 0xf24f62335024a295L}, + /* 7 */ {22, 0.35620719, 0x3642798750226111L, 0x2df495ccaa57147bL}, + /* 8 */ {21, 0.33333333, 0x3L, 0x0L}, + /* 9 */ {20, 0.31546488, 0xa8b8b452291fe821L, 0x846d550e37b5063dL}, + /* 10 */ {19, 0.30103000, 0x8ac7230489e80000L, 0xd83c94fb6d2ac34aL}, + /* 11 */ {18, 0.28906483, 0x4d28cb56c33fa539L, 0xa8adf7ae45e7577bL}, + /* 12 */ {17, 0.27894295, 0x1eca170c00000000L, 0xa10c2bec5da8f8fL}, + /* 13 */ {17, 0.27023815, 0x780c7372621bd74dL, 0x10f4becafe412ec3L}, + /* 14 */ {16, 0.26264954, 0x1e39a5057d810000L, 0xf08480f672b4e86L}, + /* 15 */ {16, 0.25595802, 0x5b27ac993df97701L, 0x6779c7f90dc42f48L}, + /* 16 */ {16, 0.25000000, 0x4L, 0x0L}, + /* 17 */ {15, 0.24465054, 0x27b95e997e21d9f1L, 0x9c71e11bab279323L}, + /* 18 */ {15, 0.23981247, 0x5da0e1e53c5c8000L, 0x5dfaa697ec6f6a1cL}, + /* 19 */ {15, 0.23540891, 0xd2ae3299c1c4aedbL, 0x3711783f6be7e9ecL}, + /* 20 */ {14, 0.23137821, 0x16bcc41e90000000L, 0x6849b86a12b9b01eL}, + /* 21 */ {14, 0.22767025, 0x2d04b7fdd9c0ef49L, 0x6bf097ba5ca5e239L}, + /* 22 */ {14, 0.22424382, 0x5658597bcaa24000L, 0x7b8015c8d7af8f08L}, + /* 23 */ {14, 0.22106473, 0xa0e2073737609371L, 0x975a24b3a3151b38L}, + /* 24 */ {13, 0.21810429, 0xc29e98000000000L, 0x50bd367972689db1L}, + /* 25 */ {13, 0.21533828, 0x14adf4b7320334b9L, 0x8c240c4aecb13bb5L}, + /* 26 */ {13, 0.21274605, 0x226ed36478bfa000L, 0xdbd2e56854e118c9L}, + /* 27 */ {13, 0.21030992, 0x383d9170b85ff80bL, 0x2351ffcaa9c7c4aeL}, + /* 28 */ {13, 0.20801460, 0x5a3c23e39c000000L, 0x6b24188ca33b0636L}, + /* 29 */ {13, 0.20584683, 0x8e65137388122bcdL, 0xcc3dceaf2b8ba99dL}, + /* 30 */ {13, 0.20379505, 0xdd41bb36d259e000L, 0x2832e835c6c7d6b6L}, + /* 31 */ {12, 0.20184909, 0xaee5720ee830681L, 0x76b6aa272e1873c5L}, + /* 32 */ {12, 0.20000000, 0x5L, 0x0L}, + /* 33 */ {12, 0.19823986, 0x172588ad4f5f0981L, 0x61eaf5d402c7bf4fL}, + /* 34 */ {12, 0.19656163, 0x211e44f7d02c1000L, 0xeeb658123ffb27ecL}, + /* 35 */ {12, 0.19495902, 0x2ee56725f06e5c71L, 0x5d5e3762e6fdf509L}, + /* 36 */ {12, 0.19342640, 0x41c21cb8e1000000L, 0xf24f62335024a295L}, + /* 37 */ {12, 0.19195872, 0x5b5b57f8a98a5dd1L, 0x66ae7831762efb6fL}, + /* 38 */ {12, 0.19055141, 0x7dcff8986ea31000L, 0x47388865a00f544L}, + /* 39 */ {12, 0.18920036, 0xabd4211662a6b2a1L, 0x7d673c33a123b54cL}, + /* 40 */ {12, 0.18790182, 0xe8d4a51000000000L, 0x19799812dea11197L}, + /* 41 */ {11, 0.18665241, 0x7a32956ad081b79L, 0xc27e62e0686feaeL}, + /* 42 */ {11, 0.18544902, 0x9f49aaff0e86800L, 0x9b6e7507064ce7c7L}, + /* 43 */ {11, 0.18428883, 0xce583bb812d37b3L, 0x3d9ac2bf66cfed94L}, + /* 44 */ {11, 0.18316925, 0x109b79a654c00000L, 0xed46bc50ce59712aL}, + /* 45 */ {11, 0.18208790, 0x1543beff214c8b95L, 0x813d97e2c89b8d46L}, + /* 46 */ {11, 0.18104260, 0x1b149a79459a3800L, 0x2e81751956af8083L}, + /* 47 */ {11, 0.18003133, 0x224edfb5434a830fL, 0xdd8e0a95e30c0988L}, + /* 48 */ {11, 0.17905223, 0x2b3fb00000000000L, 0x7ad4dd48a0b5b167L}, + /* 49 */ {11, 0.17810359, 0x3642798750226111L, 0x2df495ccaa57147bL}, + /* 50 */ {11, 0.17718382, 0x43c33c1937564800L, 0xe392010175ee5962L}, + /* 51 */ {11, 0.17629143, 0x54411b2441c3cd8bL, 0x84eaf11b2fe7738eL}, + /* 52 */ {11, 0.17542506, 0x6851455acd400000L, 0x3a1e3971e008995dL}, + /* 53 */ {11, 0.17458343, 0x80a23b117c8feb6dL, 0xfd7a462344ffce25L}, + /* 54 */ {11, 0.17376534, 0x9dff7d32d5dc1800L, 0x9eca40b40ebcef8aL}, + /* 55 */ {11, 0.17296969, 0xc155af6faeffe6a7L, 0x52fa161a4a48e43dL}, + /* 56 */ {11, 0.17219543, 0xebb7392e00000000L, 0x1607a2cbacf930c1L}, + /* 57 */ {10, 0.17144160, 0x50633659656d971L, 0x97a014f8e3be55f1L}, + /* 58 */ {10, 0.17070728, 0x5fa8624c7fba400L, 0x568df8b76cbf212cL}, + /* 59 */ {10, 0.16999162, 0x717d9faa73c5679L, 0x20ba7c4b4e6ef492L}, + /* 60 */ {10, 0.16929381, 0x86430aac6100000L, 0xe81ee46b9ef492f5L}, + /* 61 */ {10, 0.16861310, 0x9e64d9944b57f29L, 0x9dc0d10d51940416L}, + /* 62 */ {10, 0.16794878, 0xba5ca5392cb0400L, 0x5fa8ed2f450272a5L}, + /* 63 */ {10, 0.16730018, 0xdab2ce1d022cd81L, 0x2ba9eb8c5e04e641L}, + /* 64 */ {10, 0.16666667, 0x6L, 0x0L}, + /* 65 */ {10, 0.16604765, 0x12aeed5fd3e2d281L, 0xb67759cc00287bf1L}, + /* 66 */ {10, 0.16544255, 0x15c3da1572d50400L, 0x78621feeb7f4ed33L}, + /* 67 */ {10, 0.16485086, 0x194c05534f75ee29L, 0x43d55b5f72943bc0L}, + /* 68 */ {10, 0.16427205, 0x1d56299ada100000L, 0x173decb64d1d4409L}, + /* 69 */ {10, 0.16370566, 0x21f2a089a4ff4f79L, 0xe29fb54fd6b6074fL}, + /* 70 */ {10, 0.16315122, 0x2733896c68d9a400L, 0xa1f1f5c210d54e62L}, + /* 71 */ {10, 0.16260831, 0x2d2cf2c33b533c71L, 0x6aac7f9bfafd57b2L}, + /* 72 */ {10, 0.16207652, 0x33f506e440000000L, 0x3b563c2478b72ee2L}, + /* 73 */ {10, 0.16155547, 0x3ba43bec1d062211L, 0x12b536b574e92d1bL}, + /* 74 */ {10, 0.16104477, 0x4455872d8fd4e400L, 0xdf86c03020404fa5L}, + /* 75 */ {10, 0.16054409, 0x4e2694539f2f6c59L, 0xa34adf02234eea8eL}, + /* 76 */ {10, 0.16005307, 0x5938006c18900000L, 0x6f46eb8574eb59ddL}, + /* 77 */ {10, 0.15957142, 0x65ad9912474aa649L, 0x42459b481df47cecL}, + /* 78 */ {10, 0.15909881, 0x73ae9ff4241ec400L, 0x1b424b95d80ca505L}, + /* 79 */ {10, 0.15863496, 0x836612ee9c4ce1e1L, 0xf2c1b982203a0dacL}, + /* 80 */ {10, 0.15817959, 0x9502f90000000000L, 0xb7cdfd9d7bdbab7dL}, + /* 81 */ {10, 0.15773244, 0xa8b8b452291fe821L, 0x846d550e37b5063dL}, + /* 82 */ {10, 0.15729325, 0xbebf59a07dab4400L, 0x57931eeaf85cf64fL}, + /* 83 */ {10, 0.15686177, 0xd7540d4093bc3109L, 0x305a944507c82f47L}, + /* 84 */ {10, 0.15643779, 0xf2b96616f1900000L, 0xe007ccc9c22781aL}, + /* 85 */ {9, 0.15602107, 0x336de62af2bca35L, 0x3e92c42e000eeed4L}, + /* 86 */ {9, 0.15561139, 0x39235ec33d49600L, 0x1ebe59130db2795eL}, + /* 87 */ {9, 0.15520856, 0x3f674e539585a17L, 0x268859e90f51b89L}, + /* 88 */ {9, 0.15481238, 0x4645b6958000000L, 0xd24cde0463108cfaL}, + /* 89 */ {9, 0.15442266, 0x4dcb74afbc49c19L, 0xa536009f37adc383L}, + /* 90 */ {9, 0.15403922, 0x56064e1d18d9a00L, 0x7cea06ce1c9ace10L}, + /* 91 */ {9, 0.15366189, 0x5f04fe2cd8a39fbL, 0x58db032e72e8ba43L}, + /* 92 */ {9, 0.15329049, 0x68d74421f5c0000L, 0x388cc17cae105447L}, + /* 93 */ {9, 0.15292487, 0x738df1f6ab4827dL, 0x1b92672857620ce0L}, + /* 94 */ {9, 0.15256487, 0x7f3afbc9cfb5e00L, 0x18c6a9575c2ade4L}, + /* 95 */ {9, 0.15221035, 0x8bf187fba88f35fL, 0xd44da7da8e44b24fL}, + /* 96 */ {9, 0.15186115, 0x99c600000000000L, 0xaa2f78f1b4cc6794L}, + /* 97 */ {9, 0.15151715, 0xa8ce21eb6531361L, 0x843c067d091ee4ccL}, + /* 98 */ {9, 0.15117821, 0xb92112c1a0b6200L, 0x62005e1e913356e3L}, + /* 99 */ {9, 0.15084420, 0xcad7718b8747c43L, 0x4316eed01dedd518L}, + /* 100 */ {9, 0.15051500, 0xde0b6b3a7640000L, 0x2725dd1d243aba0eL}, + /* 101 */ {9, 0.15019048, 0xf2d8cf5fe6d74c5L, 0xddd9057c24cb54fL}, + /* 102 */ {9, 0.14987054, 0x1095d25bfa712600L, 0xedeee175a736d2a1L}, + /* 103 */ {9, 0.14955506, 0x121b7c4c3698faa7L, 0xc4699f3df8b6b328L}, + /* 104 */ {9, 0.14924394, 0x13c09e8d68000000L, 0x9ebbe7d859cb5a7cL}, + /* 105 */ {9, 0.14893706, 0x15876ccb0b709ca9L, 0x7c828b9887eb2179L}, + /* 106 */ {9, 0.14863434, 0x17723c2976da2a00L, 0x5d652ab99001adcfL}, + /* 107 */ {9, 0.14833567, 0x198384e9c259048bL, 0x4114f1754e5d7b32L}, + /* 108 */ {9, 0.14804096, 0x1bbde41dfeec0000L, 0x274b7c902f7e0188L}, + /* 109 */ {9, 0.14775011, 0x1e241d6e3337910dL, 0xfc9e0fbb32e210cL}, + /* 110 */ {9, 0.14746305, 0x20b91cee9901ee00L, 0xf4afa3e594f8ea1fL}, + /* 111 */ {9, 0.14717969, 0x237ff9079863dfefL, 0xcd85c32e9e4437b0L}, + /* 112 */ {9, 0.14689994, 0x267bf47000000000L, 0xa9bbb147e0dd92a8L}, + /* 113 */ {9, 0.14662372, 0x29b08039fbeda7f1L, 0x8900447b70e8eb82L}, + /* 114 */ {9, 0.14635096, 0x2d213df34f65f200L, 0x6b0a92adaad5848aL}, + /* 115 */ {9, 0.14608158, 0x30d201d957a7c2d3L, 0x4f990ad8740f0ee5L}, + /* 116 */ {9, 0.14581551, 0x34c6d52160f40000L, 0x3670a9663a8d3610L}, + /* 117 */ {9, 0.14555268, 0x3903f855d8f4c755L, 0x1f5c44188057be3cL}, + /* 118 */ {9, 0.14529302, 0x3d8de5c8ec59b600L, 0xa2bea956c4e4977L}, + /* 119 */ {9, 0.14503647, 0x4269541d1ff01337L, 0xed68b23033c3637eL}, + /* 120 */ {9, 0.14478295, 0x479b38e478000000L, 0xc99cf624e50549c5L}, + /* 121 */ {9, 0.14453241, 0x4d28cb56c33fa539L, 0xa8adf7ae45e7577bL}, + /* 122 */ {9, 0.14428479, 0x5317871fa13aba00L, 0x8a5bc740b1c113e5L}, + /* 123 */ {9, 0.14404003, 0x596d2f44de9fa71bL, 0x6e6c7efb81cfbb9bL}, + /* 124 */ {9, 0.14379807, 0x602fd125c47c0000L, 0x54aba5c5cada5f10L}, + /* 125 */ {9, 0.14355885, 0x6765c793fa10079dL, 0x3ce9a36f23c0fc90L}, + /* 126 */ {9, 0.14332233, 0x6f15be069b847e00L, 0x26fb43de2c8cd2a8L}, + /* 127 */ {9, 0.14308844, 0x7746b3e82a77047fL, 0x12b94793db8486a1L}, + /* 128 */ {9, 0.14285714, 0x7L, 0x0L}, + /* 129 */ {9, 0.14262838, 0x894953f7ea890481L, 0xdd5deca404c0156dL}, + /* 130 */ {9, 0.14240211, 0x932abffea4848200L, 0xbd51373330291de0L}, + /* 131 */ {9, 0.14217828, 0x9dacb687d3d6a163L, 0x9fa4025d66f23085L}, + /* 132 */ {9, 0.14195685, 0xa8d8102a44840000L, 0x842530ee2db4949dL}, + /* 133 */ {9, 0.14173777, 0xb4b60f9d140541e5L, 0x6aa7f2766b03dc25L}, + /* 134 */ {9, 0.14152100, 0xc15065d4856e4600L, 0x53035ba7ebf32e8dL}, + /* 135 */ {9, 0.14130649, 0xceb1363f396d23c7L, 0x3d12091fc9fb4914L}, + /* 136 */ {9, 0.14109421, 0xdce31b2488000000L, 0x28b1cb81b1ef1849L}, + /* 137 */ {9, 0.14088412, 0xebf12a24bca135c9L, 0x15c35be67ae3e2c9L}, + /* 138 */ {9, 0.14067617, 0xfbe6f8dbf88f4a00L, 0x42a17bd09be1ff0L}, + /* 139 */ {8, 0.14047033, 0x1ef156c084ce761L, 0x8bf461f03cf0bbfL}, + /* 140 */ {8, 0.14026656, 0x20c4e3b94a10000L, 0xf3fbb43f68a32d05L}, + /* 141 */ {8, 0.14006482, 0x22b0695a08ba421L, 0xd84f44c48564dc19L}, + /* 142 */ {8, 0.13986509, 0x24b4f35d7a4c100L, 0xbe58ebcce7956abeL}, + /* 143 */ {8, 0.13966731, 0x26d397284975781L, 0xa5fac463c7c134b7L}, + /* 144 */ {8, 0.13947147, 0x290d74100000000L, 0x8f19241e28c7d757L}, + /* 145 */ {8, 0.13927753, 0x2b63b3a37866081L, 0x799a6d046c0ae1aeL}, + /* 146 */ {8, 0.13908545, 0x2dd789f4d894100L, 0x6566e37d746a9e40L}, + /* 147 */ {8, 0.13889521, 0x306a35e51b58721L, 0x526887dbfb5f788fL}, + /* 148 */ {8, 0.13870677, 0x331d01712e10000L, 0x408af3382b8efd3dL}, + /* 149 */ {8, 0.13852011, 0x35f14200a827c61L, 0x2fbb374806ec05f1L}, + /* 150 */ {8, 0.13833519, 0x38e858b62216100L, 0x1fe7c0f0afce87feL}, + /* 151 */ {8, 0.13815199, 0x3c03b2c13176a41L, 0x11003d517540d32eL}, + /* 152 */ {8, 0.13797047, 0x3f44c9b21000000L, 0x2f5810f98eff0dcL}, + /* 153 */ {8, 0.13779062, 0x42ad23cef3113c1L, 0xeb72e35e7840d910L}, + /* 154 */ {8, 0.13761241, 0x463e546b19a2100L, 0xd27de19593dc3614L}, + /* 155 */ {8, 0.13743580, 0x49f9fc3f96684e1L, 0xbaf391fd3e5e6fc2L}, + /* 156 */ {8, 0.13726078, 0x4de1c9c5dc10000L, 0xa4bd38c55228c81dL}, + /* 157 */ {8, 0.13708732, 0x51f77994116d2a1L, 0x8fc5a8de8e1de782L}, + /* 158 */ {8, 0.13691539, 0x563cd6bb3398100L, 0x7bf9265bea9d3a3bL}, + /* 159 */ {8, 0.13674498, 0x5ab3bb270beeb01L, 0x69454b325983dccdL}, + /* 160 */ {8, 0.13657605, 0x5f5e10000000000L, 0x5798ee2308c39df9L}, + /* 161 */ {8, 0.13640859, 0x643dce0ec16f501L, 0x46e40ba0fa66a753L}, + /* 162 */ {8, 0.13624257, 0x6954fe21e3e8100L, 0x3717b0870b0db3a7L}, + /* 163 */ {8, 0.13607797, 0x6ea5b9755f440a1L, 0x2825e6775d11cdebL}, + /* 164 */ {8, 0.13591477, 0x74322a1c0410000L, 0x1a01a1c09d1b4dacL}, + /* 165 */ {8, 0.13575295, 0x79fc8b6ae8a46e1L, 0xc9eb0a8bebc8f3eL}, + /* 166 */ {8, 0.13559250, 0x80072a66d512100L, 0xffe357ff59e6a004L}, + /* 167 */ {8, 0.13543338, 0x86546633b42b9c1L, 0xe7dfd1be05fa61a8L}, + /* 168 */ {8, 0.13527558, 0x8ce6b0861000000L, 0xd11ed6fc78f760e5L}, + /* 169 */ {8, 0.13511908, 0x93c08e16a022441L, 0xbb8db609dd29ebfeL}, + /* 170 */ {8, 0.13496386, 0x9ae49717f026100L, 0xa71aec8d1813d532L}, + /* 171 */ {8, 0.13480991, 0xa25577ae24c1a61L, 0x93b612a9f20fbc02L}, + /* 172 */ {8, 0.13465720, 0xaa15f068e610000L, 0x814fc7b19a67d317L}, + /* 173 */ {8, 0.13450572, 0xb228d6bf7577921L, 0x6fd9a03f2e0a4b7cL}, + /* 174 */ {8, 0.13435545, 0xba91158ef5c4100L, 0x5f4615a38d0d316eL}, + /* 175 */ {8, 0.13420637, 0xc351ad9aec0b681L, 0x4f8876863479a286L}, + /* 176 */ {8, 0.13405847, 0xcc6db6100000000L, 0x4094d8a3041b60ebL}, + /* 177 */ {8, 0.13391173, 0xd5e85d09025c181L, 0x32600b8ed883a09bL}, + /* 178 */ {8, 0.13376614, 0xdfc4e816401c100L, 0x24df8c6eb4b6d1f1L}, + /* 179 */ {8, 0.13362168, 0xea06b4c72947221L, 0x18097a8ee151acefL}, + /* 180 */ {8, 0.13347832, 0xf4b139365210000L, 0xbd48cc8ec1cd8e3L}, + /* 181 */ {8, 0.13333607, 0xffc80497d520961L, 0x3807a8d67485fbL}, + /* 182 */ {8, 0.13319491, 0x10b4ebfca1dee100L, 0xea5768860b62e8d8L}, + /* 183 */ {8, 0.13305481, 0x117492de921fc141L, 0xd54faf5b635c5005L}, + /* 184 */ {8, 0.13291577, 0x123bb2ce41000000L, 0xc14a56233a377926L}, + /* 185 */ {8, 0.13277777, 0x130a8b6157bdecc1L, 0xae39a88db7cd329fL}, + /* 186 */ {8, 0.13264079, 0x13e15dede0e8a100L, 0x9c10bde69efa7ab6L}, + /* 187 */ {8, 0.13250483, 0x14c06d941c0ca7e1L, 0x8ac36c42a2836497L}, + /* 188 */ {8, 0.13236988, 0x15a7ff487a810000L, 0x7a463c8b84f5ef67L}, + /* 189 */ {8, 0.13223591, 0x169859ddc5c697a1L, 0x6a8e5f5ad090fd4bL}, + /* 190 */ {8, 0.13210292, 0x1791c60f6fed0100L, 0x5b91a2943596fc56L}, + /* 191 */ {8, 0.13197089, 0x18948e8c0e6fba01L, 0x4d4667b1c468e8f0L}, + /* 192 */ {8, 0.13183981, 0x19a1000000000000L, 0x3fa39ab547994dafL}, + /* 193 */ {8, 0.13170967, 0x1ab769203dafc601L, 0x32a0a9b2faee1e2aL}, + /* 194 */ {8, 0.13158046, 0x1bd81ab557f30100L, 0x26357ceac0e96962L}, + /* 195 */ {8, 0.13145216, 0x1d0367a69fed1ba1L, 0x1a5a6f65caa5859eL}, + /* 196 */ {8, 0.13132477, 0x1e39a5057d810000L, 0xf08480f672b4e86L}, + /* 197 */ {8, 0.13119827, 0x1f7b2a18f29ac3e1L, 0x4383340615612caL}, + /* 198 */ {8, 0.13107265, 0x20c850694c2aa100L, 0xf3c77969ee4be5a2L}, + /* 199 */ {8, 0.13094791, 0x222173cc014980c1L, 0xe00993cc187c5ec9L}, + /* 200 */ {8, 0.13082402, 0x2386f26fc1000000L, 0xcd2b297d889bc2b6L}, + /* 201 */ {8, 0.13070099, 0x24f92ce8af296d41L, 0xbb214d5064862b22L}, + /* 202 */ {8, 0.13057879, 0x2678863cd0ece100L, 0xa9e1a7ca7ea10e20L}, + /* 203 */ {8, 0.13045743, 0x280563f0a9472d61L, 0x99626e72b39ea0cfL}, + /* 204 */ {8, 0.13033688, 0x29a02e1406210000L, 0x899a5ba9c13fafd9L}, + /* 205 */ {8, 0.13021715, 0x2b494f4efe6d2e21L, 0x7a80a705391e96ffL}, + /* 206 */ {8, 0.13009822, 0x2d0134ef21cbc100L, 0x6c0cfe23de23042aL}, + /* 207 */ {8, 0.12998007, 0x2ec84ef4da2ef581L, 0x5e377df359c944ddL}, + /* 208 */ {8, 0.12986271, 0x309f102100000000L, 0x50f8ac5fc8f53985L}, + /* 209 */ {8, 0.12974613, 0x3285ee02a1420281L, 0x44497266278e35b7L}, + /* 210 */ {8, 0.12963031, 0x347d6104fc324100L, 0x382316831f7ee175L}, + /* 211 */ {8, 0.12951524, 0x3685e47dade53d21L, 0x2c7f377833b8946eL}, + /* 212 */ {8, 0.12940092, 0x389ff6bb15610000L, 0x2157c761ab4163efL}, + /* 213 */ {8, 0.12928734, 0x3acc1912ebb57661L, 0x16a7071803cc49a9L}, + /* 214 */ {8, 0.12917448, 0x3d0acff111946100L, 0xc6781d80f8224fcL}, + /* 215 */ {8, 0.12906235, 0x3f5ca2e692eaf841L, 0x294092d370a900bL}, + /* 216 */ {8, 0.12895094, 0x41c21cb8e1000000L, 0xf24f62335024a295L}, + /* 217 */ {8, 0.12884022, 0x443bcb714399a5c1L, 0xe03b98f103fad6d2L}, + /* 218 */ {8, 0.12873021, 0x46ca406c81af2100L, 0xcee3d32cad2a9049L}, + /* 219 */ {8, 0.12862089, 0x496e106ac22aaae1L, 0xbe3f9df9277fdadaL}, + /* 220 */ {8, 0.12851224, 0x4c27d39fa5410000L, 0xae46f0d94c05e933L}, + /* 221 */ {8, 0.12840428, 0x4ef825c296e43ca1L, 0x9ef2280fb437a33dL}, + /* 222 */ {8, 0.12829698, 0x51dfa61f5ad88100L, 0x9039ff426d3f284bL}, + /* 223 */ {8, 0.12819034, 0x54def7a6d2f16901L, 0x82178c6d6b51f8f4L}, + /* 224 */ {8, 0.12808435, 0x57f6c10000000000L, 0x74843b1ee4c1e053L}, + /* 225 */ {8, 0.12797901, 0x5b27ac993df97701L, 0x6779c7f90dc42f48L}, + /* 226 */ {8, 0.12787431, 0x5e7268b9bbdf8100L, 0x5af23c74f9ad9fe9L}, + /* 227 */ {8, 0.12777024, 0x61d7a7932ff3d6a1L, 0x4ee7eae2acdc617eL}, + /* 228 */ {8, 0.12766680, 0x65581f53c8c10000L, 0x43556aa2ac262a0bL}, + /* 229 */ {8, 0.12756398, 0x68f48a385b8320e1L, 0x3835949593b8ddd1L}, + /* 230 */ {8, 0.12746176, 0x6cada69ed07c2100L, 0x2d837fbe78458762L}, + /* 231 */ {8, 0.12736016, 0x70843718cdbf27c1L, 0x233a7e150a54a555L}, + /* 232 */ {8, 0.12725915, 0x7479027ea1000000L, 0x19561984a50ff8feL}, + /* 233 */ {8, 0.12715874, 0x788cd40268f39641L, 0xfd211159fe3490fL}, + /* 234 */ {8, 0.12705891, 0x7cc07b437ecf6100L, 0x6aa563e655033e3L}, + /* 235 */ {8, 0.12695967, 0x8114cc6220762061L, 0xfbb614b3f2d3b14cL}, + /* 236 */ {8, 0.12686100, 0x858aa0135be10000L, 0xeac0f8837fb05773L}, + /* 237 */ {8, 0.12676290, 0x8a22d3b53c54c321L, 0xda6e4c10e8615ca5L}, + /* 238 */ {8, 0.12666537, 0x8ede496339f34100L, 0xcab755a8d01fa67fL}, + /* 239 */ {8, 0.12656839, 0x93bde80aec3a1481L, 0xbb95a9ae71aa3e0cL}, + /* 240 */ {8, 0.12647197, 0x98c29b8100000000L, 0xad0326c296b4f529L}, + /* 241 */ {8, 0.12637609, 0x9ded549671832381L, 0x9ef9f21eed31b7c1L}, + /* 242 */ {8, 0.12628075, 0xa33f092e0b1ac100L, 0x91747422be14b0b2L}, + /* 243 */ {8, 0.12618595, 0xa8b8b452291fe821L, 0x846d550e37b5063dL}, + /* 244 */ {8, 0.12609168, 0xae5b564ac3a10000L, 0x77df79e9a96c06f6L}, + /* 245 */ {8, 0.12599794, 0xb427f4b3be74c361L, 0x6bc6019636c7d0c2L}, + /* 246 */ {8, 0.12590471, 0xba1f9a938041e100L, 0x601c4205aebd9e47L}, + /* 247 */ {8, 0.12581200, 0xc0435871d1110f41L, 0x54ddc59756f05016L}, + /* 248 */ {8, 0.12571980, 0xc694446f01000000L, 0x4a0648979c838c18L}, + /* 249 */ {8, 0.12562811, 0xcd137a5b57ac3ec1L, 0x3f91b6e0bb3a053dL}, + /* 250 */ {8, 0.12553692, 0xd3c21bcecceda100L, 0x357c299a88ea76a5L}, + /* 251 */ {8, 0.12544622, 0xdaa150410b788de1L, 0x2bc1e517aecc56e3L}, + /* 252 */ {8, 0.12535601, 0xe1b24521be010000L, 0x225f56ceb3da9f5dL}, + /* 253 */ {8, 0.12526629, 0xe8f62df12777c1a1L, 0x1951136d53ad63acL}, + /* 254 */ {8, 0.12517705, 0xf06e445906fc0100L, 0x1093d504b3cd7d93L}, + /* 255 */ {8, 0.12508829, 0xf81bc845c81bf801L, 0x824794d1ec1814fL}, +}; +#endif diff --git a/lib/gmp/mpn/mul.c b/lib/gmp/mpn/mul.c new file mode 100644 index 00000000..960eb94e --- /dev/null +++ b/lib/gmp/mpn/mul.c @@ -0,0 +1,153 @@ +/* mpn_mul -- Multiply two natural numbers. + +Copyright (C) 1991, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +/* Multiply the natural numbers u (pointed to by UP, with USIZE limbs) + and v (pointed to by VP, with VSIZE limbs), and store the result at + PRODP. USIZE + VSIZE limbs are always stored, but if the input + operands are normalized. Return the most significant limb of the + result. + + NOTE: The space pointed to by PRODP is overwritten before finished + with U and V, so overlap is an error. + + Argument constraints: + 1. USIZE >= VSIZE. + 2. PRODP != UP and PRODP != VP, i.e. the destination + must be distinct from the multiplier and the multiplicand. */ + +/* If KARATSUBA_THRESHOLD is not already defined, define it to a + value which is good on most machines. */ +#ifndef KARATSUBA_THRESHOLD +#define KARATSUBA_THRESHOLD 32 +#endif + +mp_limb_t +#if __STDC__ +mpn_mul (mp_ptr prodp, + mp_srcptr up, mp_size_t usize, + mp_srcptr vp, mp_size_t vsize) +#else +mpn_mul (prodp, up, usize, vp, vsize) + mp_ptr prodp; + mp_srcptr up; + mp_size_t usize; + mp_srcptr vp; + mp_size_t vsize; +#endif +{ + mp_ptr prod_endp = prodp + usize + vsize - 1; + mp_limb_t cy; + mp_ptr tspace; + TMP_DECL (marker); + + if (vsize < KARATSUBA_THRESHOLD) + { + /* Handle simple cases with traditional multiplication. + + This is the most critical code of the entire function. All + multiplies rely on this, both small and huge. Small ones arrive + here immediately. Huge ones arrive here as this is the base case + for Karatsuba's recursive algorithm below. */ + mp_size_t i; + mp_limb_t cy_limb; + mp_limb_t v_limb; + + if (vsize == 0) + return 0; + + /* Multiply by the first limb in V separately, as the result can be + stored (not added) to PROD. We also avoid a loop for zeroing. */ + v_limb = vp[0]; + if (v_limb <= 1) + { + if (v_limb == 1) + MPN_COPY (prodp, up, usize); + else + MPN_ZERO (prodp, usize); + cy_limb = 0; + } + else + cy_limb = mpn_mul_1 (prodp, up, usize, v_limb); + + prodp[usize] = cy_limb; + prodp++; + + /* For each iteration in the outer loop, multiply one limb from + U with one limb from V, and add it to PROD. */ + for (i = 1; i < vsize; i++) + { + v_limb = vp[i]; + if (v_limb <= 1) + { + cy_limb = 0; + if (v_limb == 1) + cy_limb = mpn_add_n (prodp, prodp, up, usize); + } + else + cy_limb = mpn_addmul_1 (prodp, up, usize, v_limb); + + prodp[usize] = cy_limb; + prodp++; + } + return cy_limb; + } + + TMP_MARK (marker); + + tspace = (mp_ptr) TMP_ALLOC (2 * vsize * BYTES_PER_MP_LIMB); + MPN_MUL_N_RECURSE (prodp, up, vp, vsize, tspace); + + prodp += vsize; + up += vsize; + usize -= vsize; + if (usize >= vsize) + { + mp_ptr tp = (mp_ptr) TMP_ALLOC (2 * vsize * BYTES_PER_MP_LIMB); + do + { + MPN_MUL_N_RECURSE (tp, up, vp, vsize, tspace); + cy = mpn_add_n (prodp, prodp, tp, vsize); + mpn_add_1 (prodp + vsize, tp + vsize, vsize, cy); + prodp += vsize; + up += vsize; + usize -= vsize; + } + while (usize >= vsize); + } + + /* True: usize < vsize. */ + + /* Make life simple: Recurse. */ + + if (usize != 0) + { + mpn_mul (tspace, vp, vsize, up, usize); + cy = mpn_add_n (prodp, prodp, tspace, vsize); + mpn_add_1 (prodp + vsize, tspace + vsize, usize, cy); + } + + TMP_FREE (marker); + return *prod_endp; +} diff --git a/lib/gmp/mpn/mul_1.c b/lib/gmp/mpn/mul_1.c new file mode 100644 index 00000000..21aa9510 --- /dev/null +++ b/lib/gmp/mpn/mul_1.c @@ -0,0 +1,60 @@ +/* mpn_mul_1 -- Multiply a limb vector with a single limb and + store the product in a second limb vector. + +Copyright (C) 1991, 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +mp_limb_t +mpn_mul_1 (res_ptr, s1_ptr, s1_size, s2_limb) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + mp_size_t s1_size; + register mp_limb_t s2_limb; +{ + register mp_limb_t cy_limb; + register mp_size_t j; + register mp_limb_t prod_high, prod_low; + + /* The loop counter and index J goes from -S1_SIZE to -1. This way + the loop becomes faster. */ + j = -s1_size; + + /* Offset the base pointers to compensate for the negative indices. */ + s1_ptr -= j; + res_ptr -= j; + + cy_limb = 0; + do + { + umul_ppmm (prod_high, prod_low, s1_ptr[j], s2_limb); + + prod_low += cy_limb; + cy_limb = (prod_low < cy_limb) + prod_high; + + res_ptr[j] = prod_low; + } + while (++j != 0); + + return cy_limb; +} diff --git a/lib/gmp/mpn/mul_n.c b/lib/gmp/mpn/mul_n.c new file mode 100644 index 00000000..104d332f --- /dev/null +++ b/lib/gmp/mpn/mul_n.c @@ -0,0 +1,402 @@ +/* mpn_mul_n -- Multiply two natural numbers of length n. + +Copyright (C) 1991, 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +/* Multiply the natural numbers u (pointed to by UP) and v (pointed to by VP), + both with SIZE limbs, and store the result at PRODP. 2 * SIZE limbs are + always stored. Return the most significant limb. + + Argument constraints: + 1. PRODP != UP and PRODP != VP, i.e. the destination + must be distinct from the multiplier and the multiplicand. */ + +/* If KARATSUBA_THRESHOLD is not already defined, define it to a + value which is good on most machines. */ +#ifndef KARATSUBA_THRESHOLD +#define KARATSUBA_THRESHOLD 32 +#endif + +/* The code can't handle KARATSUBA_THRESHOLD smaller than 2. */ +#if KARATSUBA_THRESHOLD < 2 +#undef KARATSUBA_THRESHOLD +#define KARATSUBA_THRESHOLD 2 +#endif + +/* Handle simple cases with traditional multiplication. + + This is the most critical code of multiplication. All multiplies rely + on this, both small and huge. Small ones arrive here immediately. Huge + ones arrive here as this is the base case for Karatsuba's recursive + algorithm below. */ + +void +#if __STDC__ +impn_mul_n_basecase (mp_ptr prodp, mp_srcptr up, mp_srcptr vp, mp_size_t size) +#else +impn_mul_n_basecase (prodp, up, vp, size) + mp_ptr prodp; + mp_srcptr up; + mp_srcptr vp; + mp_size_t size; +#endif +{ + mp_size_t i; + mp_limb_t cy_limb; + mp_limb_t v_limb; + + /* Multiply by the first limb in V separately, as the result can be + stored (not added) to PROD. We also avoid a loop for zeroing. */ + v_limb = vp[0]; + if (v_limb <= 1) + { + if (v_limb == 1) + MPN_COPY (prodp, up, size); + else + MPN_ZERO (prodp, size); + cy_limb = 0; + } + else + cy_limb = mpn_mul_1 (prodp, up, size, v_limb); + + prodp[size] = cy_limb; + prodp++; + + /* For each iteration in the outer loop, multiply one limb from + U with one limb from V, and add it to PROD. */ + for (i = 1; i < size; i++) + { + v_limb = vp[i]; + if (v_limb <= 1) + { + cy_limb = 0; + if (v_limb == 1) + cy_limb = mpn_add_n (prodp, prodp, up, size); + } + else + cy_limb = mpn_addmul_1 (prodp, up, size, v_limb); + + prodp[size] = cy_limb; + prodp++; + } +} + +void +#if __STDC__ +impn_mul_n (mp_ptr prodp, + mp_srcptr up, mp_srcptr vp, mp_size_t size, mp_ptr tspace) +#else +impn_mul_n (prodp, up, vp, size, tspace) + mp_ptr prodp; + mp_srcptr up; + mp_srcptr vp; + mp_size_t size; + mp_ptr tspace; +#endif +{ + if ((size & 1) != 0) + { + /* The size is odd, the code code below doesn't handle that. + Multiply the least significant (size - 1) limbs with a recursive + call, and handle the most significant limb of S1 and S2 + separately. */ + /* A slightly faster way to do this would be to make the Karatsuba + code below behave as if the size were even, and let it check for + odd size in the end. I.e., in essence move this code to the end. + Doing so would save us a recursive call, and potentially make the + stack grow a lot less. */ + + mp_size_t esize = size - 1; /* even size */ + mp_limb_t cy_limb; + + MPN_MUL_N_RECURSE (prodp, up, vp, esize, tspace); + cy_limb = mpn_addmul_1 (prodp + esize, up, esize, vp[esize]); + prodp[esize + esize] = cy_limb; + cy_limb = mpn_addmul_1 (prodp + esize, vp, size, up[esize]); + + prodp[esize + size] = cy_limb; + } + else + { + /* Anatolij Alekseevich Karatsuba's divide-and-conquer algorithm. + + Split U in two pieces, U1 and U0, such that + U = U0 + U1*(B**n), + and V in V1 and V0, such that + V = V0 + V1*(B**n). + + UV is then computed recursively using the identity + + 2n n n n + UV = (B + B )U V + B (U -U )(V -V ) + (B + 1)U V + 1 1 1 0 0 1 0 0 + + Where B = 2**BITS_PER_MP_LIMB. */ + + mp_size_t hsize = size >> 1; + mp_limb_t cy; + int negflg; + + /*** Product H. ________________ ________________ + |_____U1 x V1____||____U0 x V0_____| */ + /* Put result in upper part of PROD and pass low part of TSPACE + as new TSPACE. */ + MPN_MUL_N_RECURSE (prodp + size, up + hsize, vp + hsize, hsize, tspace); + + /*** Product M. ________________ + |_(U1-U0)(V0-V1)_| */ + if (mpn_cmp (up + hsize, up, hsize) >= 0) + { + mpn_sub_n (prodp, up + hsize, up, hsize); + negflg = 0; + } + else + { + mpn_sub_n (prodp, up, up + hsize, hsize); + negflg = 1; + } + if (mpn_cmp (vp + hsize, vp, hsize) >= 0) + { + mpn_sub_n (prodp + hsize, vp + hsize, vp, hsize); + negflg ^= 1; + } + else + { + mpn_sub_n (prodp + hsize, vp, vp + hsize, hsize); + /* No change of NEGFLG. */ + } + /* Read temporary operands from low part of PROD. + Put result in low part of TSPACE using upper part of TSPACE + as new TSPACE. */ + MPN_MUL_N_RECURSE (tspace, prodp, prodp + hsize, hsize, tspace + size); + + /*** Add/copy product H. */ + MPN_COPY (prodp + hsize, prodp + size, hsize); + cy = mpn_add_n (prodp + size, prodp + size, prodp + size + hsize, hsize); + + /*** Add product M (if NEGFLG M is a negative number). */ + if (negflg) + cy -= mpn_sub_n (prodp + hsize, prodp + hsize, tspace, size); + else + cy += mpn_add_n (prodp + hsize, prodp + hsize, tspace, size); + + /*** Product L. ________________ ________________ + |________________||____U0 x V0_____| */ + /* Read temporary operands from low part of PROD. + Put result in low part of TSPACE using upper part of TSPACE + as new TSPACE. */ + MPN_MUL_N_RECURSE (tspace, up, vp, hsize, tspace + size); + + /*** Add/copy Product L (twice). */ + + cy += mpn_add_n (prodp + hsize, prodp + hsize, tspace, size); + if (cy) + mpn_add_1 (prodp + hsize + size, prodp + hsize + size, hsize, cy); + + MPN_COPY (prodp, tspace, hsize); + cy = mpn_add_n (prodp + hsize, prodp + hsize, tspace + hsize, hsize); + if (cy) + mpn_add_1 (prodp + size, prodp + size, size, 1); + } +} + +void +#if __STDC__ +impn_sqr_n_basecase (mp_ptr prodp, mp_srcptr up, mp_size_t size) +#else +impn_sqr_n_basecase (prodp, up, size) + mp_ptr prodp; + mp_srcptr up; + mp_size_t size; +#endif +{ + mp_size_t i; + mp_limb_t cy_limb; + mp_limb_t v_limb; + + /* Multiply by the first limb in V separately, as the result can be + stored (not added) to PROD. We also avoid a loop for zeroing. */ + v_limb = up[0]; + if (v_limb <= 1) + { + if (v_limb == 1) + MPN_COPY (prodp, up, size); + else + MPN_ZERO (prodp, size); + cy_limb = 0; + } + else + cy_limb = mpn_mul_1 (prodp, up, size, v_limb); + + prodp[size] = cy_limb; + prodp++; + + /* For each iteration in the outer loop, multiply one limb from + U with one limb from V, and add it to PROD. */ + for (i = 1; i < size; i++) + { + v_limb = up[i]; + if (v_limb <= 1) + { + cy_limb = 0; + if (v_limb == 1) + cy_limb = mpn_add_n (prodp, prodp, up, size); + } + else + cy_limb = mpn_addmul_1 (prodp, up, size, v_limb); + + prodp[size] = cy_limb; + prodp++; + } +} + +void +#if __STDC__ +impn_sqr_n (mp_ptr prodp, + mp_srcptr up, mp_size_t size, mp_ptr tspace) +#else +impn_sqr_n (prodp, up, size, tspace) + mp_ptr prodp; + mp_srcptr up; + mp_size_t size; + mp_ptr tspace; +#endif +{ + if ((size & 1) != 0) + { + /* The size is odd, the code code below doesn't handle that. + Multiply the least significant (size - 1) limbs with a recursive + call, and handle the most significant limb of S1 and S2 + separately. */ + /* A slightly faster way to do this would be to make the Karatsuba + code below behave as if the size were even, and let it check for + odd size in the end. I.e., in essence move this code to the end. + Doing so would save us a recursive call, and potentially make the + stack grow a lot less. */ + + mp_size_t esize = size - 1; /* even size */ + mp_limb_t cy_limb; + + MPN_SQR_N_RECURSE (prodp, up, esize, tspace); + cy_limb = mpn_addmul_1 (prodp + esize, up, esize, up[esize]); + prodp[esize + esize] = cy_limb; + cy_limb = mpn_addmul_1 (prodp + esize, up, size, up[esize]); + + prodp[esize + size] = cy_limb; + } + else + { + mp_size_t hsize = size >> 1; + mp_limb_t cy; + + /*** Product H. ________________ ________________ + |_____U1 x U1____||____U0 x U0_____| */ + /* Put result in upper part of PROD and pass low part of TSPACE + as new TSPACE. */ + MPN_SQR_N_RECURSE (prodp + size, up + hsize, hsize, tspace); + + /*** Product M. ________________ + |_(U1-U0)(U0-U1)_| */ + if (mpn_cmp (up + hsize, up, hsize) >= 0) + { + mpn_sub_n (prodp, up + hsize, up, hsize); + } + else + { + mpn_sub_n (prodp, up, up + hsize, hsize); + } + + /* Read temporary operands from low part of PROD. + Put result in low part of TSPACE using upper part of TSPACE + as new TSPACE. */ + MPN_SQR_N_RECURSE (tspace, prodp, hsize, tspace + size); + + /*** Add/copy product H. */ + MPN_COPY (prodp + hsize, prodp + size, hsize); + cy = mpn_add_n (prodp + size, prodp + size, prodp + size + hsize, hsize); + + /*** Add product M (if NEGFLG M is a negative number). */ + cy -= mpn_sub_n (prodp + hsize, prodp + hsize, tspace, size); + + /*** Product L. ________________ ________________ + |________________||____U0 x U0_____| */ + /* Read temporary operands from low part of PROD. + Put result in low part of TSPACE using upper part of TSPACE + as new TSPACE. */ + MPN_SQR_N_RECURSE (tspace, up, hsize, tspace + size); + + /*** Add/copy Product L (twice). */ + + cy += mpn_add_n (prodp + hsize, prodp + hsize, tspace, size); + if (cy) + mpn_add_1 (prodp + hsize + size, prodp + hsize + size, hsize, cy); + + MPN_COPY (prodp, tspace, hsize); + cy = mpn_add_n (prodp + hsize, prodp + hsize, tspace + hsize, hsize); + if (cy) + mpn_add_1 (prodp + size, prodp + size, size, 1); + } +} + +/* This should be made into an inline function in gmp.h. */ +inline void +#if __STDC__ +mpn_mul_n (mp_ptr prodp, mp_srcptr up, mp_srcptr vp, mp_size_t size) +#else +mpn_mul_n (prodp, up, vp, size) + mp_ptr prodp; + mp_srcptr up; + mp_srcptr vp; + mp_size_t size; +#endif +{ + TMP_DECL (marker); + TMP_MARK (marker); + if (up == vp) + { + if (size < KARATSUBA_THRESHOLD) + { + impn_sqr_n_basecase (prodp, up, size); + } + else + { + mp_ptr tspace; + tspace = (mp_ptr) TMP_ALLOC (2 * size * BYTES_PER_MP_LIMB); + impn_sqr_n (prodp, up, size, tspace); + } + } + else + { + if (size < KARATSUBA_THRESHOLD) + { + impn_mul_n_basecase (prodp, up, vp, size); + } + else + { + mp_ptr tspace; + tspace = (mp_ptr) TMP_ALLOC (2 * size * BYTES_PER_MP_LIMB); + impn_mul_n (prodp, up, vp, size, tspace); + } + } + TMP_FREE (marker); +} diff --git a/lib/gmp/mpn/sub_n.c b/lib/gmp/mpn/sub_n.c new file mode 100644 index 00000000..09478577 --- /dev/null +++ b/lib/gmp/mpn/sub_n.c @@ -0,0 +1,63 @@ +/* mpn_sub_n -- Subtract two limb vectors of equal, non-zero length. + +Copyright (C) 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" + +mp_limb_t +#if __STDC__ +mpn_sub_n (mp_ptr res_ptr, mp_srcptr s1_ptr, mp_srcptr s2_ptr, mp_size_t size) +#else +mpn_sub_n (res_ptr, s1_ptr, s2_ptr, size) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + register mp_srcptr s2_ptr; + mp_size_t size; +#endif +{ + register mp_limb_t x, y, cy; + register mp_size_t j; + + /* The loop counter and index J goes from -SIZE to -1. This way + the loop becomes faster. */ + j = -size; + + /* Offset the base pointers to compensate for the negative indices. */ + s1_ptr -= j; + s2_ptr -= j; + res_ptr -= j; + + cy = 0; + do + { + y = s2_ptr[j]; + x = s1_ptr[j]; + y += cy; /* add previous carry to subtrahend */ + cy = (y < cy); /* get out carry from that addition */ + y = x - y; /* main subtract */ + cy = (y > x) + cy; /* get out carry from the subtract, combine */ + res_ptr[j] = y; + } + while (++j != 0); + + return cy; +} diff --git a/lib/gmp/mpn/submul_1.c b/lib/gmp/mpn/submul_1.c new file mode 100644 index 00000000..8af60a7c --- /dev/null +++ b/lib/gmp/mpn/submul_1.c @@ -0,0 +1,66 @@ +/* mpn_submul_1 -- multiply the S1_SIZE long limb vector pointed to by S1_PTR + by S2_LIMB, subtract the S1_SIZE least significant limbs of the product + from the limb vector pointed to by RES_PTR. Return the most significant + limb of the product, adjusted for carry-out from the subtraction. + +Copyright (C) 1992, 1993, 1994, 1996 Free Software Foundation, Inc. + +This file is part of the GNU MP Library. + +The GNU MP Library is free software; you can redistribute it and/or modify +it under the terms of the GNU Library General Public License as published by +the Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +The GNU MP Library is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY +or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public +License for more details. + +You should have received a copy of the GNU Library General Public License +along with the GNU MP Library; see the file COPYING.LIB. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, +MA 02111-1307, USA. */ + +#include +#include "gmp.h" +#include "gmp-impl.h" +#include "longlong.h" + +mp_limb_t +mpn_submul_1 (res_ptr, s1_ptr, s1_size, s2_limb) + register mp_ptr res_ptr; + register mp_srcptr s1_ptr; + mp_size_t s1_size; + register mp_limb_t s2_limb; +{ + register mp_limb_t cy_limb; + register mp_size_t j; + register mp_limb_t prod_high, prod_low; + register mp_limb_t x; + + /* The loop counter and index J goes from -SIZE to -1. This way + the loop becomes faster. */ + j = -s1_size; + + /* Offset the base pointers to compensate for the negative indices. */ + res_ptr -= j; + s1_ptr -= j; + + cy_limb = 0; + do + { + umul_ppmm (prod_high, prod_low, s1_ptr[j], s2_limb); + + prod_low += cy_limb; + cy_limb = (prod_low < cy_limb) + prod_high; + + x = res_ptr[j]; + prod_low = x - prod_low; + cy_limb += (prod_low > x); + res_ptr[j] = prod_low; + } + while (++j != 0); + + return cy_limb; +} diff --git a/lib/julcal/ChangeLog b/lib/julcal/ChangeLog new file mode 100644 index 00000000..29810492 --- /dev/null +++ b/lib/julcal/ChangeLog @@ -0,0 +1,49 @@ +Sun Jan 2 21:32:13 2000 Ben Pfaff + + * julcal.c: Comment fixes. Most of the code was rewritten. + (_juldnj) Renamed calendar_to_julian. Interface changed. + (juldnj) Removed. + (juldnd) Renamed julian_to_calendar. Interface changed. + (julcd) Removed. + (julcdd) Removed. + (julian_to_mday) New function. + (julian_to_wday) New function. + [STANDALONE] (main) New test routines. + + * julcal.h: Replaced. + +Sat Jan 3 17:09:07 1998 Ben Pfaff + + * README: New file. + +Fri Dec 26 15:43:57 1997 Ben Pfaff + + * julcal.c: (julian_offset) Move glob var definition here. + +Sun Jul 6 19:12:18 1997 Ben Pfaff + + * Makefile.am: Fixed INCLUDES to include intl; fixed directories. + +Sun Jun 1 17:27:17 1997 Ben Pfaff + + * julcal.h: Made the declaration of macros with arguments a lot + nicer looking. + +Fri Apr 18 16:48:41 1997 Ben Pfaff + + * Makefile.am: Refers to src/ as include directory instead of + include/. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-clean Makefile.in. + +Thu Oct 24 17:47:14 1996 Ben Pfaff + + * julcal.h: Comment fix. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/lib/julcal/Makefile.am b/lib/julcal/Makefile.am new file mode 100644 index 00000000..90674584 --- /dev/null +++ b/lib/julcal/Makefile.am @@ -0,0 +1,11 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +noinst_LIBRARIES = libjulcal.a + +INCLUDES = -I$(srcdir) -I$(top_srcdir)/src -I$(top_srcdir) \ +-I$(top_srcdir)/intl + +libjulcal_a_SOURCES = julcal.c +noinst_HEADERS = julcal.h + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/julcal/README b/lib/julcal/README new file mode 100644 index 00000000..7cc95aa3 --- /dev/null +++ b/lib/julcal/README @@ -0,0 +1,5 @@ +Please note that julcal is not part of PSPP. Instead, it is a +separate library that is included in the PSPP distribution for +convenience in compiling. + + -blp diff --git a/lib/julcal/julcal.c b/lib/julcal/julcal.c new file mode 100644 index 00000000..46b07657 --- /dev/null +++ b/lib/julcal/julcal.c @@ -0,0 +1,183 @@ +/* + Modified BLP 8/28/95, 12/15/99 for PSPP. + + Original sources for julcal.c and julcal.h can be found at + ftp.cdrom.com in /pub/algorithms/c/julcal10/{julcal.c,julcal.h}. + */ + +/* + Translated from Pascal to C by Jim Van Zandt, July 1992. + + Error-free translation based on error-free PL/I source + + Based on Pascal code copyright 1985 by Michael A. Covington, + published in P.C. Tech Journal, December 1985, based on formulae + appearing in Astronomical Formulae for Calculators by Jean Meeus + */ + +/*#include */ +#include +#include +#include "julcal.h" + +#define JUL_OFFSET 2299160L + +/* Takes Y, M, and D, and returns the corresponding Julian date as an + offset in days from the midnight separating 8 Oct 1582 and 9 Oct + 1582. (Y,M,D) = (1999,10,1) corresponds to 1 Oct 1999. */ +long +calendar_to_julian (int y, int m, int d) +{ + m--; + y += m / 12; + m -= m / 12 * 12; + + assert (m > -12 && m < 12); + if (m < 0) + { + m += 12; + y--; + } + + assert (m >= 0 && m < 12); + if (m < 2) + { + m += 13; + y--; + } + else + m++; + + return ((1461 * (y + 4716L) / 4) + + (153 * (m + 1) / 5) + + (d - 1) + - 1524 + + 3 + - y / 100 + + y / 400 + - y / 4000 + - JUL_OFFSET); +} + +/* Takes a Julian date JD and sets *Y0, *M0, and *D0 to the + corresponding year, month, and day, respectively, where + (*Y0,*M0,*D0) = (1999,10,1) would be 1 Oct 1999. */ +void +julian_to_calendar (long jd, int *y0, int *m0, int *d0) +{ + int a, ay, em; + + jd += JUL_OFFSET; + + { + long aa, ab; + + aa = jd - 1721120L; + ab = 31 * (aa / 1460969L); + aa %= 1460969L; + ab += 3 * (aa / 146097L); + aa = aa % 146097L; + if (aa == 146096L) + ab += 3; + else + ab += aa / 36524L; + a = jd + (ab - 2); + } + + { + long ee, b, d; + + b = a + 1524; + ay = (20 * b - 2442) / 7305; + d = 1461L * ay / 4; + ee = b - d; + em = 10000 * ee / 306001; + if (d0 != NULL) + *d0 = ee - 306001L * em / 10000L; + } + + if (y0 != NULL || m0 != NULL) + { + int m = em - 1; + if (m > 12) + m -= 12; + if (m0 != NULL) + *m0 = m; + + if (y0 != NULL) + { + if (m > 2) + *y0 = ay - 4716; + else + *y0 = ay - 4715; + } + + } +} + +/* Takes a julian date JD and returns the corresponding year-relative + Julian date, with 1=Jan 1. */ +int +julian_to_jday (long jd) +{ + int year; + + julian_to_calendar (jd, &year, NULL, NULL); + return jd - calendar_to_julian (year, 1, 1) + 1; +} + + +/* Takes a julian date JD and returns the corresponding weekday 1...7, + with 1=Sunday. */ +int +julian_to_wday (long jd) +{ + return (jd - 3) % 7 + 1; +} + +#if STANDALONE +#include + +int +main (void) +{ + { + long julian[] = + { + 1, 50000, 102, 1157, 14288, 87365, 109623, 153211, 152371, 144623, + }; + size_t j; + + for (j = 0; j < sizeof julian / sizeof *julian; j++) + { + int y, m, d; + long jd; + julian_to_calendar (julian[j], &y, &m, &d); + jd = calendar_to_julian (y, m, d); + printf ("%ld => %d/%d/%d => %ld\n", julian[j], y, m, d, jd); + } + } + + { + int date[][3] = + { + {1582,10,15}, {1719,9,6}, {1583,1,24}, {1585,12,14}, + {1621,11,26}, {1821,12,25}, {1882,12,3}, {2002,4,6}, + {1999,12,19}, {1978,10,1}, + }; + size_t j; + + for (j = 0; j < sizeof date / sizeof *date; j++) + { + int y = date[j][0], m = date[j][1], d = date[j][2]; + long jd = calendar_to_julian (y, m, d); + int y2, m2, d2; + julian_to_calendar (jd, &y2, &m2, &d2); + printf ("%d/%d/%d => %ld => %d/%d/%d\n", + y, m, d, jd, y2, m2, d2); + } + } + + return 0; +} +#endif diff --git a/lib/julcal/julcal.h b/lib/julcal/julcal.h new file mode 100644 index 00000000..e1a4415b --- /dev/null +++ b/lib/julcal/julcal.h @@ -0,0 +1,15 @@ +/* + Declarations for Julian date routines. + + Modified BLP 8/28/95, 9/26/95, 12/15/99 for PSPP. + */ + +#if !julcal_h +#define julcal_h 1 + +long calendar_to_julian (int y, int m, int d); +void julian_to_calendar (long jd, int *y, int *m, int *d); +int julian_to_wday (long jd); +int julian_to_jday (long jd); + +#endif /* !julcal_h */ diff --git a/lib/misc/ChangeLog b/lib/misc/ChangeLog new file mode 100644 index 00000000..9bcae51a --- /dev/null +++ b/lib/misc/ChangeLog @@ -0,0 +1,148 @@ +Sun Jan 2 21:35:47 2000 Ben Pfaff + + * qsort.c: Change headers. Fix __attribute__ for gcc 2.7.2. + + * strcasecmp.c: Remove duplicate inclusion of ctype.h. + + * strncasecmp.c: (strncasecmp) Must cast argument of tolower() to + unsigned char. + +Sat Jan 23 12:50:16 1999 Ben Pfaff + + * strcasecmp.c: (strcasecmp) Fix behavior for zero-length strings. + +Sun Jul 5 00:15:44 1998 Ben Pfaff + + * qsort.c: (blp_quicksort) Add unused qualifier to temp_buf when + alloca is in use. + +1998-02-23 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add strtok_r.c. + + * strtok_r.c: New file. + +1998-02-16 Ben Pfaff + + * memmem.c: Cast void * to char * before dereferencing, in a + different place. + +Fri Feb 13 15:35:55 1998 Ben Pfaff + + * memmem.c: Cast void * to char * before dereferencing. Reported + by palme@uni-wuppertal.de (Hubert Palme). + +Sun Jan 18 00:30:38 1998 Ben Pfaff + + * memmem.c: Fix argument types. + +Sun Oct 5 15:54:37 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add strerror.c. From Alexandre Oliva + . + + * strerror.c: New file. From Alexandre Oliva + . + +Thu Sep 18 21:34:07 1997 Ben Pfaff + + * Makefile.am: (libmisc_a_SOURCES) Added getopt.c, getopt1.c. + (EXTRA_DIST) Removed getopt.c, getopt1.c. + +Thu Jul 17 01:50:43 1997 Ben Pfaff + + * strncasecmp.c: (strncasecmp) Rewritten to fix undefined + behavior. + +Fri Jul 11 14:06:04 1997 Ben Pfaff + + * getdelim.c: Added in some necessary #include's. + + * getline.c: #include's . Added getdelim() prototype. + + * memmem.c: #include's . + (memmem) `i' now a size_t. Avoid subtraction of unsigned's. + +Sun Jul 6 19:12:35 1997 Ben Pfaff + + * Makefile.am: Fixed INCLUDES to include intl; fixed directories. + +Mon Jun 2 14:22:24 1997 Ben Pfaff + + * getopt.c: Marked strings for gettext. + +Fri Apr 18 16:48:41 1997 Ben Pfaff + + * Makefile.am: Refers to src/ as include directory instead of + include/. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-clean Makefile.in. + +Thu Mar 27 01:11:29 1997 Ben Pfaff + + * alloca.c: Only compiled if necessary. + + * getdelim.c: New file. + * getline.c: New file. + * memchr.c: New file. + * memcpy.c: New file. + * memmem.c: New file. + * memmove.c: New file. + * memset.c: New file. + * strcasecmp.c: New file. + * strncasecmp.c: New file. + * strpbrk.c: New file. + * strstr.c: New file. + * strtol.c: New file. + * strtoul.c: New file. + +Sun Dec 15 15:32:16 1996 Ben Pfaff + + * qsort.c: New file, essentially unchanged from the glibc-1.09 + distribution. + +Mon Nov 11 15:34:09 1996 Ben Pfaff + + * avl.c: (destroy) Format fix. + (avl_destroy) Only calls destroy() if the tree has a non-NULL + root. + +Thu Nov 7 20:52:28 1996 Ben Pfaff + + * avl.h: (force_avl_insert, force_avl_delete) New macros/functions + that assure that a node was successfully added/deleted, active + only when GLOBAL_DEBUGGING. Most occurrences of + avl_insert/avl_delete changed to use these instead. + + * avl.c: [GLOBAL_DEBUGGING] (force_avl_delete) New function. + +Tue Sep 24 18:39:09 1996 Ben Pfaff + + * stpcpy.c: Comment fix. + +Fri Sep 20 22:52:28 1996 Ben Pfaff + + * alloca.c: Changed conditions for inclusion. + +Tue Jul 23 21:48:36 1996 Ben Pfaff + + * avl.c: Formatting fixes. + (balance) Fixed bug introduced in last patchlevel that reversed + the truth value returned by final statement. + (find) Always returns NULL if end of function reached. + (avl_walk) Split into two functions, walk_inorder and + walk_preorder. All callers and callees changed. + (avl_sort) New function. + +Fri Jul 19 19:11:13 1996 Ben Pfaff + + * avl.h, avl.c: Completely reworked, might as well be considered + new files. All callers, all references to AVL trees changed. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/lib/misc/Makefile.am b/lib/misc/Makefile.am new file mode 100644 index 00000000..bedc884d --- /dev/null +++ b/lib/misc/Makefile.am @@ -0,0 +1,16 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +noinst_LIBRARIES = libmisc.a + +INCLUDES = -I$(srcdir) -I$(top_srcdir)/src -I$(top_srcdir) \ +-I$(top_srcdir)/intl + +libmisc_a_SOURCES = qsort.c getopt.c getopt1.c +libmisc_a_LIBADD = @ALLOCA@ @LIBOBJS@ +libmisc_a_DEPENDENCIES = @ALLOCA@ @LIBOBJS@ + +EXTRA_DIST = alloca.c getdelim.c getline.c memchr.c memcmp.c memcpy.c \ +memmem.c memmove.c memset.c stpcpy.c strcasecmp.c strerror.c \ +strncasecmp.c strpbrk.c strstr.c strtok_r.c strtol.c strtoul.c + +MAINTAINERCLEANFILES = Makefile.in diff --git a/lib/misc/alloca.c b/lib/misc/alloca.c new file mode 100644 index 00000000..be1f0c42 --- /dev/null +++ b/lib/misc/alloca.c @@ -0,0 +1,178 @@ +/* + alloca -- (mostly) portable public-domain implementation -- D A Gwyn + + edited 8/22/95, 2/28/96, 3/28/96 by BLP for PSPP + + edited 86/05/30 rms + include config.h, since on VMS it renames some symbols. + Use xmalloc instead of malloc. + + This implementation of the PWB library alloca() function, + which is used to allocate space off the run-time stack so + that it is automatically reclaimed upon procedure exit, + was inspired by discussions with J. Q. Johnson of Cornell. + + It should work under any C implementation that uses an + actual procedure stack (as opposed to a linked list of + frames). There are some preprocessor constants that can + be defined when compiling for your specific system, for + improved efficiency; however, the defaults should be okay. + + The general concept of this implementation is to keep + track of all alloca()-allocated blocks, and reclaim any + that are found to be deeper in the stack than the current + invocation. This heuristic does not reclaim storage as + soon as it becomes invalid, but it will do so eventually. + + As a special case, alloca(0) reclaims storage without + allocating any. It is a good idea to use alloca(0) in + your main control loop, etc. to force garbage collection. + */ + +#if C_ALLOCA + +#include +#include +#include "common.h" + +typedef void *pointer; /* generic pointer type */ +#define NULL 0 /* null pointer constant */ + +extern void free (); +extern pointer xmalloc (); + +/* + Define STACK_DIRECTION if you know the direction of stack + growth for your system; otherwise it will be automatically + deduced at run-time. + + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown + */ + +#ifndef STACK_DIRECTION +#define STACK_DIRECTION 0 /* direction unknown */ +#endif + +#if STACK_DIRECTION != 0 + +#define STACK_DIR STACK_DIRECTION /* known at compile-time */ + +#else /* STACK_DIRECTION == 0; need run-time code */ + +static int stack_dir; /* 1 or -1 once known */ +#define STACK_DIR stack_dir + +static void +find_stack_direction (void) +{ + static char *addr = NULL; /* address of first + `dummy', once known */ + auto char dummy; /* to get stack address */ + + if (addr == NULL) + { /* initial entry */ + addr = &dummy; + + find_stack_direction (); /* recurse once */ + } + else + /* second entry */ if (&dummy > addr) + stack_dir = 1; /* stack grew upward */ + else + stack_dir = -1; /* stack grew downward */ +} + +#endif /* STACK_DIRECTION == 0 */ + +/* + An "alloca header" is used to: + (a) chain together all alloca()ed blocks; + (b) keep track of stack depth. + + PORTME: It is very important that sizeof(header) agree with + malloc() alignment chunk size. The following default should + work okay. */ + +#ifndef ALIGN_SIZE +#define ALIGN_SIZE sizeof(double) +#endif + +typedef union hdr +{ + char align[ALIGN_SIZE]; /* to force sizeof(header) */ + struct + { + union hdr *next; /* for chaining headers */ + char *deep; /* for stack depth measure */ + } + h; +} +header; + +/* + alloca( size ) returns a pointer to at least `size' bytes of + storage which will be automatically reclaimed upon exit from + the procedure that called alloca(). Originally, this space + was supposed to be taken from the current stack frame of the + caller, but that method cannot be made to work for some + implementations of C, for example under Gould's UTX/32. + */ + +static header *last_alloca_header = NULL; /* -> last alloca header */ + +pointer +alloca (unsigned size) /* returns pointer to storage */ +{ + auto char probe; /* probes stack depth: */ + register char *depth = &probe; + +#if STACK_DIRECTION == 0 + if (STACK_DIR == 0) /* unknown growth direction */ + find_stack_direction (); +#endif + + /* Reclaim garbage, defined as all alloca()ed storage that + was allocated from deeper in the stack than currently. */ + + { + register header *hp; /* traverses linked list */ + + for (hp = last_alloca_header; hp != NULL;) + if (STACK_DIR > 0 && hp->h.deep > depth + || STACK_DIR < 0 && hp->h.deep < depth) + { + register header *np = hp->h.next; + + free ((pointer) hp); /* collect garbage */ + + hp = np; /* -> next header */ + } + else + break; /* rest are not deeper */ + + last_alloca_header = hp; /* -> last valid storage */ + } + + if (size == 0) + return NULL; /* no allocation required */ + + /* Allocate combined header + user data storage. */ + + { + register pointer new = xmalloc (sizeof (header) + size); + /* address of header */ + + ((header *) new)->h.next = last_alloca_header; + ((header *) new)->h.deep = depth; + + last_alloca_header = (header *) new; + + /* User storage begins just after header. */ + + return (pointer) ((char *) new + sizeof (header)); + } +} + +#endif /* !__GNUC__ && !__BORLANDC__ */ diff --git a/lib/misc/getdelim.c b/lib/misc/getdelim.c new file mode 100644 index 00000000..3e74f947 --- /dev/null +++ b/lib/misc/getdelim.c @@ -0,0 +1,72 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "common.h" + +/* Reads a DELIMITER-separated field of any length from file STREAM. + *LINEPTR is a malloc'd string of size N; if *LINEPTR is NULL, it is + allocated. *LINEPTR is allocated/enlarged as necessary. Returns + -1 if at eof when entered; otherwise eof causes return of string + without a terminating DELIMITER. Normally DELIMITER is the last + character in *LINEPTR on return (besides the null character which + is always present). Returns number of characters read, including + terminating field delimiter if present. */ +long +getdelim (char **lineptr, size_t *n, int delimiter, FILE *stream) +{ + /* Number of characters stored in *lineptr so far. */ + size_t len; + + /* Last character read. */ + int c; + + if (*lineptr == NULL || *n < 2) + { + *lineptr = xrealloc (*lineptr, 128); + *n = 128; + } + assert (*n > 0); + + len = 0; + c = getc (stream); + if (c == EOF) + return -1; + while (1) + { + if (len + 1 >= *n) + { + *n *= 2; + *lineptr = xrealloc (*lineptr, *n); + } + (*lineptr)[len++] = c; + + if (c == delimiter) + break; + + c = getc (stream); + if (c == EOF) + break; + } + (*lineptr)[len] = '\0'; + return len; +} diff --git a/lib/misc/getline.c b/lib/misc/getline.c new file mode 100644 index 00000000..5da0e0bd --- /dev/null +++ b/lib/misc/getline.c @@ -0,0 +1,32 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include + +#if !HAVE_GETDELIM +long getdelim (char **lineptr, size_t *n, int delimiter, FILE *stream); +#endif + +long +getline (char **lineptr, size_t *n, FILE *stream) +{ + return getdelim (lineptr, n, '\n', stream); +} diff --git a/lib/misc/getopt.c b/lib/misc/getopt.c new file mode 100644 index 00000000..fa215170 --- /dev/null +++ b/lib/misc/getopt.c @@ -0,0 +1,754 @@ +/* Getopt for GNU. + NOTE: getopt is now part of the C library, so if you don't know what + "Keep this file name-space clean" means, talk to roland@gnu.org + before changing it! + + Copyright (C) 1987, 88, 89, 90, 91, 92, 93, 94 + Free Software Foundation, Inc. + + This file is part of the GNU C Library. Its master source is NOT part of + the C library, however. The master source lives in /gd/gnu/lib. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If + not, write to the Free Software Foundation, Inc., 675 Mass Ave, + Cambridge, MA 02139, USA. */ + +/* This file has been modified from the GNU libc distribution. */ + +/* This tells Alpha OSF/1 not to define a getopt prototype in . + Ditto for AIX 3.2 and . */ +#ifndef _NO_PROTO +#define _NO_PROTO +#endif + +#include + +#if !defined (__STDC__) || !__STDC__ +/* This is a separate conditional since some stdc systems + reject `defined (const)'. */ +#ifndef const +#define const +#endif +#endif + +#include + +/* Comment out all this code if we are using the GNU C Library, and are not + actually compiling the library itself. This code is part of the GNU C + Library, but also included in many other GNU distributions. Compiling + and linking in this code is a waste when using the GNU C library + (especially if it is a shared library). Rather than having every GNU + program understand `configure --with-gnu-libc' and omit the object files, + it is simpler to just do this in the source for each such file. */ + +#if defined (_LIBC) || !defined (__GNU_LIBRARY__) + + +/* This needs to come after some library #include + to get __GNU_LIBRARY__ defined. */ +#ifdef __GNU_LIBRARY__ +/* Don't include stdlib.h for non-GNU C libraries because some of them + contain conflicting prototypes for getopt. */ +#include +#endif /* GNU C library. */ + +/* This version of `getopt' appears to the caller like standard Unix `getopt' + but it behaves differently for the user, since it allows the user + to intersperse the options with the other arguments. + + As `getopt' works, it permutes the elements of ARGV so that, + when it is done, all the options precede everything else. Thus + all application programs are extended to handle flexible argument order. + + Setting the environment variable POSIXLY_CORRECT disables permutation. + Then the behavior is completely standard. + + GNU application programs can use a third alternative mode in which + they can distinguish the relative order of options and other arguments. */ + +#include "getopt.h" + +/* For communication from `getopt' to the caller. + When `getopt' finds an option that takes an argument, + the argument value is returned here. + Also, when `ordering' is RETURN_IN_ORDER, + each non-option ARGV-element is returned here. */ + +char *optarg = NULL; + +/* Index in ARGV of the next element to be scanned. + This is used for communication to and from the caller + and for communication between successive calls to `getopt'. + + On entry to `getopt', zero means this is the first call; initialize. + + When `getopt' returns EOF, this is the index of the first of the + non-option elements that the caller should itself scan. + + Otherwise, `optind' communicates from one call to the next + how much of ARGV has been scanned so far. */ + +/* XXX 1003.2 says this must be 1 before any call. */ +int optind = 0; + +/* The next char to be scanned in the option-element + in which the last option character we returned was found. + This allows us to pick up the scan where we left off. + + If this is zero, or a null string, it means resume the scan + by advancing to the next ARGV-element. */ + +static char *nextchar; + +/* Callers store zero here to inhibit the error message + for unrecognized options. */ + +int opterr = 1; + +/* Set to an option character which was unrecognized. + This must be initialized on some systems to avoid linking in the + system's own getopt implementation. */ + +int optopt = '?'; + +/* Describe how to deal with options that follow non-option ARGV-elements. + + If the caller did not specify anything, + the default is REQUIRE_ORDER if the environment variable + POSIXLY_CORRECT is defined, PERMUTE otherwise. + + REQUIRE_ORDER means don't recognize them as options; + stop option processing when the first non-option is seen. + This is what Unix does. + This mode of operation is selected by either setting the environment + variable POSIXLY_CORRECT, or using `+' as the first character + of the list of option characters. + + PERMUTE is the default. We permute the contents of ARGV as we scan, + so that eventually all the non-options are at the end. This allows options + to be given in any order, even with programs that were not written to + expect this. + + RETURN_IN_ORDER is an option available to programs that were written + to expect options and other ARGV-elements in any order and that care about + the ordering of the two. We describe each non-option ARGV-element + as if it were the argument of an option with character code 1. + Using `-' as the first character of the list of option characters + selects this mode of operation. + + The special argument `--' forces an end of option-scanning regardless + of the value of `ordering'. In the case of RETURN_IN_ORDER, only + `--' can cause `getopt' to return EOF with `optind' != ARGC. */ + +static enum + { + REQUIRE_ORDER, PERMUTE, RETURN_IN_ORDER + } +ordering; + +/* Value of POSIXLY_CORRECT environment variable. */ +static char *posixly_correct; + +#ifdef __GNU_LIBRARY__ +/* We want to avoid inclusion of string.h with non-GNU libraries + because there are many ways it can cause trouble. + On some systems, it contains special magic macros that don't work + in GCC. */ +#include +#define my_index strchr +#else + +/* Avoid depending on library functions or files + whose names are inconsistent. */ + +char *getenv (); + +static char * +my_index (str, chr) + const char *str; + int chr; +{ + while (*str) + { + if (*str == chr) + return (char *) str; + str++; + } + return 0; +} + +/* If using GCC, we can safely declare strlen this way. + If not using GCC, it is ok not to declare it. */ +#ifdef __GNUC__ +/* Note that Motorola Delta 68k R3V7 comes with GCC but not stddef.h. + That was relevant to code that was here before. */ +#if !defined (__STDC__) || !__STDC__ +/* gcc with -traditional declares the built-in strlen to return int, + and has done so at least since version 2.4.5. -- rms. */ +extern int strlen (const char *); +#endif /* not __STDC__ */ +#endif /* __GNUC__ */ + +#endif /* not __GNU_LIBRARY__ */ + +/* Handle permutation of arguments. */ + +/* Describe the part of ARGV that contains non-options that have + been skipped. `first_nonopt' is the index in ARGV of the first of them; + `last_nonopt' is the index after the last of them. */ + +static int first_nonopt; +static int last_nonopt; + +/* Exchange two adjacent subsequences of ARGV. + One subsequence is elements [first_nonopt,last_nonopt) + which contains all the non-options that have been skipped so far. + The other is elements [last_nonopt,optind), which contains all + the options processed since those non-options were skipped. + + `first_nonopt' and `last_nonopt' are relocated so that they describe + the new indices of the non-options in ARGV after they are moved. */ + +static void +exchange (argv) + char **argv; +{ + int bottom = first_nonopt; + int middle = last_nonopt; + int top = optind; + char *tem; + + /* Exchange the shorter segment with the far end of the longer segment. + That puts the shorter segment into the right place. + It leaves the longer segment in the right place overall, + but it consists of two parts that need to be swapped next. */ + + while (top > middle && middle > bottom) + { + if (top - middle > middle - bottom) + { + /* Bottom segment is the short one. */ + int len = middle - bottom; + register int i; + + /* Swap it with the top part of the top segment. */ + for (i = 0; i < len; i++) + { + tem = argv[bottom + i]; + argv[bottom + i] = argv[top - (middle - bottom) + i]; + argv[top - (middle - bottom) + i] = tem; + } + /* Exclude the moved bottom segment from further swapping. */ + top -= len; + } + else + { + /* Top segment is the short one. */ + int len = top - middle; + register int i; + + /* Swap it with the bottom part of the bottom segment. */ + for (i = 0; i < len; i++) + { + tem = argv[bottom + i]; + argv[bottom + i] = argv[middle + i]; + argv[middle + i] = tem; + } + /* Exclude the moved top segment from further swapping. */ + bottom += len; + } + } + + /* Update records for the slots the non-options now occupy. */ + + first_nonopt += (optind - last_nonopt); + last_nonopt = optind; +} + +/* Initialize the internal data when the first call is made. */ + +static const char * +_getopt_initialize (optstring) + const char *optstring; +{ + /* Start processing options with ARGV-element 1 (since ARGV-element 0 + is the program name); the sequence of previously skipped + non-option ARGV-elements is empty. */ + + first_nonopt = last_nonopt = optind = 1; + + nextchar = NULL; + + posixly_correct = getenv ("POSIXLY_CORRECT"); + + /* Determine how to handle the ordering of options and nonoptions. */ + + if (optstring[0] == '-') + { + ordering = RETURN_IN_ORDER; + ++optstring; + } + else if (optstring[0] == '+') + { + ordering = REQUIRE_ORDER; + ++optstring; + } + else if (posixly_correct != NULL) + ordering = REQUIRE_ORDER; + else + ordering = PERMUTE; + + return optstring; +} + +/* Scan elements of ARGV (whose length is ARGC) for option characters + given in OPTSTRING. + + If an element of ARGV starts with '-', and is not exactly "-" or "--", + then it is an option element. The characters of this element + (aside from the initial '-') are option characters. If `getopt' + is called repeatedly, it returns successively each of the option characters + from each of the option elements. + + If `getopt' finds another option character, it returns that character, + updating `optind' and `nextchar' so that the next call to `getopt' can + resume the scan with the following option character or ARGV-element. + + If there are no more option characters, `getopt' returns `EOF'. + Then `optind' is the index in ARGV of the first ARGV-element + that is not an option. (The ARGV-elements have been permuted + so that those that are not options now come last.) + + OPTSTRING is a string containing the legitimate option characters. + If an option character is seen that is not listed in OPTSTRING, + return '?' after printing an error message. If you set `opterr' to + zero, the error message is suppressed but we still return '?'. + + If a char in OPTSTRING is followed by a colon, that means it wants an arg, + so the following text in the same ARGV-element, or the text of the following + ARGV-element, is returned in `optarg'. Two colons mean an option that + wants an optional arg; if there is text in the current ARGV-element, + it is returned in `optarg', otherwise `optarg' is set to zero. + + If OPTSTRING starts with `-' or `+', it requests different methods of + handling the non-option ARGV-elements. + See the comments about RETURN_IN_ORDER and REQUIRE_ORDER, above. + + Long-named options begin with `--' instead of `-'. + Their names may be abbreviated as long as the abbreviation is unique + or is an exact match for some defined option. If they have an + argument, it follows the option name in the same ARGV-element, separated + from the option name by a `=', or else the in next ARGV-element. + When `getopt' finds a long-named option, it returns 0 if that option's + `flag' field is nonzero, the value of the option's `val' field + if the `flag' field is zero. + + The elements of ARGV aren't really const, because we permute them. + But we pretend they're const in the prototype to be compatible + with other systems. + + LONGOPTS is a vector of `struct option' terminated by an + element containing a name which is zero. + + LONGIND returns the index in LONGOPT of the long-named option found. + It is only valid when a long-named option has been found by the most + recent call. + + If LONG_ONLY is nonzero, '-' as well as '--' can introduce + long-named options. */ + +int +_getopt_internal (argc, argv, optstring, longopts, longind, long_only) + int argc; + char *const *argv; + const char *optstring; + const struct option *longopts; + int *longind; + int long_only; +{ + optarg = NULL; + + if (optind == 0) + optstring = _getopt_initialize (optstring); + + if (nextchar == NULL || *nextchar == '\0') + { + /* Advance to the next ARGV-element. */ + + if (ordering == PERMUTE) + { + /* If we have just processed some options following some non-options, + exchange them so that the options come first. */ + + if (first_nonopt != last_nonopt && last_nonopt != optind) + exchange ((char **) argv); + else if (last_nonopt != optind) + first_nonopt = optind; + + /* Skip any additional non-options + and extend the range of non-options previously skipped. */ + + while (optind < argc + && (argv[optind][0] != '-' || argv[optind][1] == '\0')) + optind++; + last_nonopt = optind; + } + + /* The special ARGV-element `--' means premature end of options. + Skip it like a null option, + then exchange with previous non-options as if it were an option, + then skip everything else like a non-option. */ + + if (optind != argc && !strcmp (argv[optind], "--")) + { + optind++; + + if (first_nonopt != last_nonopt && last_nonopt != optind) + exchange ((char **) argv); + else if (first_nonopt == last_nonopt) + first_nonopt = optind; + last_nonopt = argc; + + optind = argc; + } + + /* If we have done all the ARGV-elements, stop the scan + and back over any non-options that we skipped and permuted. */ + + if (optind == argc) + { + /* Set the next-arg-index to point at the non-options + that we previously skipped, so the caller will digest them. */ + if (first_nonopt != last_nonopt) + optind = first_nonopt; + return EOF; + } + + /* If we have come to a non-option and did not permute it, + either stop the scan or describe it to the caller and pass it by. */ + + if ((argv[optind][0] != '-' || argv[optind][1] == '\0')) + { + if (ordering == REQUIRE_ORDER) + return EOF; + optarg = argv[optind++]; + return 1; + } + + /* We have found another option-ARGV-element. + Skip the initial punctuation. */ + + nextchar = (argv[optind] + 1 + + (longopts != NULL && argv[optind][1] == '-')); + } + + /* Decode the current option-ARGV-element. */ + + /* Check whether the ARGV-element is a long option. + + If long_only and the ARGV-element has the form "-f", where f is + a valid short option, don't consider it an abbreviated form of + a long option that starts with f. Otherwise there would be no + way to give the -f short option. + + On the other hand, if there's a long option "fubar" and + the ARGV-element is "-fu", do consider that an abbreviation of + the long option, just like "--fu", and not "-f" with arg "u". + + This distinction seems to be the most useful approach. */ + + if (longopts != NULL + && (argv[optind][1] == '-' + || (long_only && (argv[optind][2] + || !my_index (optstring, argv[optind][1]))))) + { + char *nameend; + const struct option *p; + const struct option *pfound = NULL; + int exact = 0; + int ambig = 0; + int indfound; + int option_index; + + for (nameend = nextchar; *nameend && *nameend != '='; nameend++) + /* Do nothing. */ ; + + /* Test all long options for either exact match + or abbreviated matches. */ + for (p = longopts, option_index = 0; p->name; p++, option_index++) + if (!strncmp (p->name, nextchar, nameend - nextchar)) + { + if (nameend - nextchar == strlen (p->name)) + { + /* Exact match found. */ + pfound = p; + indfound = option_index; + exact = 1; + break; + } + else if (pfound == NULL) + { + /* First nonexact match found. */ + pfound = p; + indfound = option_index; + } + else + /* Second or later nonexact match found. */ + ambig = 1; + } + + if (ambig && !exact) + { + if (opterr) + fprintf (stderr, _("%s: option `%s' is ambiguous\n"), + argv[0], argv[optind]); + nextchar += strlen (nextchar); + optind++; + return '?'; + } + + if (pfound != NULL) + { + option_index = indfound; + optind++; + if (*nameend) + { + /* Don't test has_arg with >, because some C compilers don't + allow it to be used on enums. */ + if (pfound->has_arg) + optarg = nameend + 1; + else + { + if (opterr) + { + if (argv[optind - 1][1] == '-') + /* --option */ + fprintf (stderr, + _("%s: option `--%s' doesn't allow an argument\n"), + argv[0], pfound->name); + else + /* +option or -option */ + fprintf (stderr, + _("%s: option `%c%s' doesn't allow an argument\n"), + argv[0], argv[optind - 1][0], pfound->name); + } + nextchar += strlen (nextchar); + return '?'; + } + } + else if (pfound->has_arg == 1) + { + if (optind < argc) + optarg = argv[optind++]; + else + { + if (opterr) + fprintf (stderr, _("%s: option `%s' requires an argument\n"), + argv[0], argv[optind - 1]); + nextchar += strlen (nextchar); + return optstring[0] == ':' ? ':' : '?'; + } + } + nextchar += strlen (nextchar); + if (longind != NULL) + *longind = option_index; + if (pfound->flag) + { + *(pfound->flag) = pfound->val; + return 0; + } + return pfound->val; + } + + /* Can't find it as a long option. If this is not getopt_long_only, + or the option starts with '--' or is not a valid short + option, then it's an error. + Otherwise interpret it as a short option. */ + if (!long_only || argv[optind][1] == '-' + || my_index (optstring, *nextchar) == NULL) + { + if (opterr) + { + if (argv[optind][1] == '-') + /* --option */ + fprintf (stderr, _("%s: unrecognized option `--%s'\n"), + argv[0], nextchar); + else + /* +option or -option */ + fprintf (stderr, _("%s: unrecognized option `%c%s'\n"), + argv[0], argv[optind][0], nextchar); + } + nextchar = (char *) ""; + optind++; + return '?'; + } + } + + /* Look at and handle the next short option-character. */ + + { + char c = *nextchar++; + char *temp = my_index (optstring, c); + + /* Increment `optind' when we start to process its last character. */ + if (*nextchar == '\0') + ++optind; + + if (temp == NULL || c == ':') + { + if (opterr) + { + if (posixly_correct) + /* 1003.2 specifies the format of this message. */ + fprintf (stderr, _("%s: illegal option -- %c\n"), argv[0], c); + else + fprintf (stderr, _("%s: invalid option -- %c\n"), argv[0], c); + } + optopt = c; + return '?'; + } + if (temp[1] == ':') + { + if (temp[2] == ':') + { + /* This is an option that accepts an argument optionally. */ + if (*nextchar != '\0') + { + optarg = nextchar; + optind++; + } + else + optarg = NULL; + nextchar = NULL; + } + else + { + /* This is an option that requires an argument. */ + if (*nextchar != '\0') + { + optarg = nextchar; + /* If we end this ARGV-element by taking the rest as an arg, + we must advance to the next element now. */ + optind++; + } + else if (optind == argc) + { + if (opterr) + { + /* 1003.2 specifies the format of this message. */ + fprintf (stderr, _("%s: option requires an argument -- %c\n"), + argv[0], c); + } + optopt = c; + if (optstring[0] == ':') + c = ':'; + else + c = '?'; + } + else + /* We already incremented `optind' once; + increment it again when taking next ARGV-elt as argument. */ + optarg = argv[optind++]; + nextchar = NULL; + } + } + return c; + } +} + +int +getopt (argc, argv, optstring) + int argc; + char *const *argv; + const char *optstring; +{ + return _getopt_internal (argc, argv, optstring, + (const struct option *) 0, + (int *) 0, + 0); +} + +#endif /* _LIBC or not __GNU_LIBRARY__. */ + +#ifdef TEST + +/* Compile with -DTEST to make an executable for use in testing + the above definition of `getopt'. */ + +int +main (argc, argv) + int argc; + char **argv; +{ + int c; + int digit_optind = 0; + + while (1) + { + int this_option_optind = optind ? optind : 1; + + c = getopt (argc, argv, "abc:d:0123456789"); + if (c == EOF) + break; + + switch (c) + { + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (digit_optind != 0 && digit_optind != this_option_optind) + printf ("digits occur in two different argv-elements.\n"); + digit_optind = this_option_optind; + printf ("option %c\n", c); + break; + + case 'a': + printf ("option a\n"); + break; + + case 'b': + printf ("option b\n"); + break; + + case 'c': + printf ("option c with value `%s'\n", optarg); + break; + + case '?': + break; + + default: + printf ("?? getopt returned character code 0%o ??\n", c); + } + } + + if (optind < argc) + { + printf ("non-option ARGV-elements: "); + while (optind < argc) + printf ("%s ", argv[optind++]); + printf ("\n"); + } + + exit (0); +} + +#endif /* TEST */ diff --git a/lib/misc/getopt1.c b/lib/misc/getopt1.c new file mode 100644 index 00000000..361872a3 --- /dev/null +++ b/lib/misc/getopt1.c @@ -0,0 +1,183 @@ +/* getopt_long and getopt_long_only entry points for GNU getopt. + Copyright (C) 1987, 88, 89, 90, 91, 92, 1993, 1994 + Free Software Foundation, Inc. + + This file is part of the GNU C Library. Its master source is NOT part of + the C library, however. The master source lives in /gd/gnu/lib. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If + not, write to the Free Software Foundation, Inc., 675 Mass Ave, + Cambridge, MA 02139, USA. */ + +/* This file has been modified from the GNU libc distribution. */ +#include + +#include "getopt.h" + +#if !defined (__STDC__) || !__STDC__ +/* This is a separate conditional since some stdc systems + reject `defined (const)'. */ +#ifndef const +#define const +#endif +#endif + +#include + +/* Comment out all this code if we are using the GNU C Library, and are not + actually compiling the library itself. This code is part of the GNU C + Library, but also included in many other GNU distributions. Compiling + and linking in this code is a waste when using the GNU C library + (especially if it is a shared library). Rather than having every GNU + program understand `configure --with-gnu-libc' and omit the object files, + it is simpler to just do this in the source for each such file. */ + +#if defined (_LIBC) || !defined (__GNU_LIBRARY__) + + +/* This needs to come after some library #include + to get __GNU_LIBRARY__ defined. */ +#ifdef __GNU_LIBRARY__ +#include +#else +char *getenv (); +#endif + +#ifndef NULL +#define NULL 0 +#endif + +int +getopt_long (argc, argv, options, long_options, opt_index) + int argc; + char *const *argv; + const char *options; + const struct option *long_options; + int *opt_index; +{ + return _getopt_internal (argc, argv, options, long_options, opt_index, 0); +} + +/* Like getopt_long, but '-' as well as '--' can indicate a long option. + If an option that starts with '-' (not '--') doesn't match a long option, + but does match a short option, it is parsed as a short option + instead. */ + +int +getopt_long_only (argc, argv, options, long_options, opt_index) + int argc; + char *const *argv; + const char *options; + const struct option *long_options; + int *opt_index; +{ + return _getopt_internal (argc, argv, options, long_options, opt_index, 1); +} + + +#endif /* _LIBC or not __GNU_LIBRARY__. */ + +#ifdef TEST + +#include + +int +main (argc, argv) + int argc; + char **argv; +{ + int c; + int digit_optind = 0; + + while (1) + { + int this_option_optind = optind ? optind : 1; + int option_index = 0; + static struct option long_options[] = + { + {"add", 1, 0, 0}, + {"append", 0, 0, 0}, + {"delete", 1, 0, 0}, + {"verbose", 0, 0, 0}, + {"create", 0, 0, 0}, + {"file", 1, 0, 0}, + {0, 0, 0, 0} + }; + + c = getopt_long (argc, argv, "abc:d:0123456789", + long_options, &option_index); + if (c == EOF) + break; + + switch (c) + { + case 0: + printf ("option %s", long_options[option_index].name); + if (optarg) + printf (" with arg %s", optarg); + printf ("\n"); + break; + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + if (digit_optind != 0 && digit_optind != this_option_optind) + printf ("digits occur in two different argv-elements.\n"); + digit_optind = this_option_optind; + printf ("option %c\n", c); + break; + + case 'a': + printf ("option a\n"); + break; + + case 'b': + printf ("option b\n"); + break; + + case 'c': + printf ("option c with value `%s'\n", optarg); + break; + + case 'd': + printf ("option d with value `%s'\n", optarg); + break; + + case '?': + break; + + default: + printf ("?? getopt returned character code 0%o ??\n", c); + } + } + + if (optind < argc) + { + printf ("non-option ARGV-elements: "); + while (optind < argc) + printf ("%s ", argv[optind++]); + printf ("\n"); + } + + exit (0); +} + +#endif /* TEST */ diff --git a/lib/misc/memchr.c b/lib/misc/memchr.c new file mode 100644 index 00000000..44482489 --- /dev/null +++ b/lib/misc/memchr.c @@ -0,0 +1,199 @@ +/* Copyright (C) 1991, 1993 Free Software Foundation, Inc. + Based on strlen implemention by Torbjorn Granlund (tege@sics.se), + with help from Dan Sahlin (dan@sics.se) and + commentary by Jim Blandy (jimb@ai.mit.edu); + adaptation to memchr suggested by Dick Karpinski (dick@cca.ucsf.edu), + and implemented by Roland McGrath (roland@ai.mit.edu). + +NOTE: The canonical source of this file is maintained with the GNU C Library. +Bugs can be reported to bug-glibc@prep.ai.mit.edu. + +This program is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. */ + +#ifdef HAVE_CONFIG_H +#include +#endif + +#undef __ptr_t +#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) +# define __ptr_t void * +#else /* Not C++ or ANSI C. */ +# define __ptr_t char * +#endif /* C++ or ANSI C. */ + +#if defined (_LIBC) +# include +#endif + +#if defined (HAVE_LIMITS_H) || defined (_LIBC) +# include +#endif + +#define LONG_MAX_32_BITS 2147483647 + +#ifndef LONG_MAX +#define LONG_MAX LONG_MAX_32_BITS +#endif + +#include + + +/* Search no more than N bytes of S for C. */ + +__ptr_t +memchr (s, c, n) + const __ptr_t s; + int c; + size_t n; +{ + const unsigned char *char_ptr; + const unsigned long int *longword_ptr; + unsigned long int longword, magic_bits, charmask; + + c = (unsigned char) c; + + /* Handle the first few characters by reading one character at a time. + Do this until CHAR_PTR is aligned on a longword boundary. */ + for (char_ptr = (const unsigned char *) s; + n > 0 && ((unsigned long int) char_ptr + & (sizeof (longword) - 1)) != 0; + --n, ++char_ptr) + if (*char_ptr == c) + return (__ptr_t) char_ptr; + + /* All these elucidatory comments refer to 4-byte longwords, + but the theory applies equally well to 8-byte longwords. */ + + longword_ptr = (unsigned long int *) char_ptr; + + /* Bits 31, 24, 16, and 8 of this number are zero. Call these bits + the "holes." Note that there is a hole just to the left of + each byte, with an extra at the end: + + bits: 01111110 11111110 11111110 11111111 + bytes: AAAAAAAA BBBBBBBB CCCCCCCC DDDDDDDD + + The 1-bits make sure that carries propagate to the next 0-bit. + The 0-bits provide holes for carries to fall into. */ + + if (sizeof (longword) != 4 && sizeof (longword) != 8) + abort (); + +#if LONG_MAX <= LONG_MAX_32_BITS + magic_bits = 0x7efefeff; +#else + magic_bits = ((unsigned long int) 0x7efefefe << 32) | 0xfefefeff; +#endif + + /* Set up a longword, each of whose bytes is C. */ + charmask = c | (c << 8); + charmask |= charmask << 16; +#if LONG_MAX > LONG_MAX_32_BITS + charmask |= charmask << 32; +#endif + + /* Instead of the traditional loop which tests each character, + we will test a longword at a time. The tricky part is testing + if *any of the four* bytes in the longword in question are zero. */ + while (n >= sizeof (longword)) + { + /* We tentatively exit the loop if adding MAGIC_BITS to + LONGWORD fails to change any of the hole bits of LONGWORD. + + 1) Is this safe? Will it catch all the zero bytes? + Suppose there is a byte with all zeros. Any carry bits + propagating from its left will fall into the hole at its + least significant bit and stop. Since there will be no + carry from its most significant bit, the LSB of the + byte to the left will be unchanged, and the zero will be + detected. + + 2) Is this worthwhile? Will it ignore everything except + zero bytes? Suppose every byte of LONGWORD has a bit set + somewhere. There will be a carry into bit 8. If bit 8 + is set, this will carry into bit 16. If bit 8 is clear, + one of bits 9-15 must be set, so there will be a carry + into bit 16. Similarly, there will be a carry into bit + 24. If one of bits 24-30 is set, there will be a carry + into bit 31, so all of the hole bits will be changed. + + The one misfire occurs when bits 24-30 are clear and bit + 31 is set; in this case, the hole at bit 31 is not + changed. If we had access to the processor carry flag, + we could close this loophole by putting the fourth hole + at bit 32! + + So it ignores everything except 128's, when they're aligned + properly. + + 3) But wait! Aren't we looking for C, not zero? + Good point. So what we do is XOR LONGWORD with a longword, + each of whose bytes is C. This turns each byte that is C + into a zero. */ + + longword = *longword_ptr++ ^ charmask; + + /* Add MAGIC_BITS to LONGWORD. */ + if ((((longword + magic_bits) + + /* Set those bits that were unchanged by the addition. */ + ^ ~longword) + + /* Look at only the hole bits. If any of the hole bits + are unchanged, most likely one of the bytes was a + zero. */ + & ~magic_bits) != 0) + { + /* Which of the bytes was C? If none of them were, it was + a misfire; continue the search. */ + + const unsigned char *cp = (const unsigned char *) (longword_ptr - 1); + + if (cp[0] == c) + return (__ptr_t) cp; + if (cp[1] == c) + return (__ptr_t) &cp[1]; + if (cp[2] == c) + return (__ptr_t) &cp[2]; + if (cp[3] == c) + return (__ptr_t) &cp[3]; +#if LONG_MAX > 2147483647 + if (cp[4] == c) + return (__ptr_t) &cp[4]; + if (cp[5] == c) + return (__ptr_t) &cp[5]; + if (cp[6] == c) + return (__ptr_t) &cp[6]; + if (cp[7] == c) + return (__ptr_t) &cp[7]; +#endif + } + + n -= sizeof (longword); + } + + char_ptr = (const unsigned char *) longword_ptr; + + while (n-- > 0) + { + if (*char_ptr == c) + return (__ptr_t) char_ptr; + else + ++char_ptr; + } + + return 0; +} diff --git a/lib/misc/memcmp.c b/lib/misc/memcmp.c new file mode 100644 index 00000000..ae4644e2 --- /dev/null +++ b/lib/misc/memcmp.c @@ -0,0 +1,364 @@ +/* Copyright (C) 1991, 1993 Free Software Foundation, Inc. + Contributed by Torbjorn Granlund (tege@sics.se). + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If + not, write to the Free Software Foundation, Inc., 675 Mass Ave, + Cambridge, MA 02139, USA. */ + +#if HAVE_CONFIG_H +#include "config.h" +#endif + +#undef __ptr_t +#if defined (__cplusplus) || (defined (__STDC__) && __STDC__) +#define __ptr_t void * +#else /* Not C++ or ANSI C. */ +#undef const +#define const +#define __ptr_t char * +#endif /* C++ or ANSI C. */ + +#if defined (HAVE_STRING_H) || defined (_LIBC) +#include +#endif + +#ifdef _LIBC + +#include + +#else /* Not in the GNU C library. */ + +#include + +/* Type to use for aligned memory operations. + This should normally be the biggest type supported by a single load + and store. Must be an unsigned type. */ +#define op_t unsigned long int +#define OPSIZ (sizeof(op_t)) + +/* Threshold value for when to enter the unrolled loops. */ +#define OP_T_THRES 16 + +/* Type to use for unaligned operations. */ +typedef unsigned char byte; + +#ifndef WORDS_BIGENDIAN +#define MERGE(w0, sh_1, w1, sh_2) (((w0) >> (sh_1)) | ((w1) << (sh_2))) +#else +#define MERGE(w0, sh_1, w1, sh_2) (((w0) << (sh_1)) | ((w1) >> (sh_2))) +#endif + +#endif /* In the GNU C library. */ + +#ifdef WORDS_BIGENDIAN +#define CMP_LT_OR_GT(a, b) ((a) > (b) ? 1 : -1) +#else +#define CMP_LT_OR_GT(a, b) memcmp_bytes ((a), (b)) +#endif + +/* BE VERY CAREFUL IF YOU CHANGE THIS CODE! */ + +/* The strategy of this memcmp is: + + 1. Compare bytes until one of the block pointers is aligned. + + 2. Compare using memcmp_common_alignment or + memcmp_not_common_alignment, regarding the alignment of the other + block after the initial byte operations. The maximum number of + full words (of type op_t) are compared in this way. + + 3. Compare the few remaining bytes. */ + +#ifndef WORDS_BIGENDIAN +/* memcmp_bytes -- Compare A and B bytewise in the byte order of the machine. + A and B are known to be different. + This is needed only on little-endian machines. */ +#ifdef __GNUC__ +__inline +#endif +static int +memcmp_bytes (a, b) + op_t a, b; +{ + long int srcp1 = (long int) &a; + long int srcp2 = (long int) &b; + op_t a0, b0; + + do + { + a0 = ((byte *) srcp1)[0]; + b0 = ((byte *) srcp2)[0]; + srcp1 += 1; + srcp2 += 1; + } + while (a0 == b0); + return a0 - b0; +} +#endif + +/* memcmp_common_alignment -- Compare blocks at SRCP1 and SRCP2 with LEN `op_t' + objects (not LEN bytes!). Both SRCP1 and SRCP2 should be aligned for + memory operations on `op_t's. */ +#ifdef __GNUC__ +__inline +#endif +static int +memcmp_common_alignment (srcp1, srcp2, len) + long int srcp1; + long int srcp2; + size_t len; +{ + op_t a0, a1; + op_t b0, b1; + + switch (len % 4) + { + case 2: + a0 = ((op_t *) srcp1)[0]; + b0 = ((op_t *) srcp2)[0]; + srcp1 -= 2 * OPSIZ; + srcp2 -= 2 * OPSIZ; + len += 2; + goto do1; + case 3: + a1 = ((op_t *) srcp1)[0]; + b1 = ((op_t *) srcp2)[0]; + srcp1 -= OPSIZ; + srcp2 -= OPSIZ; + len += 1; + goto do2; + case 0: + if (OP_T_THRES <= 3 * OPSIZ && len == 0) + return 0; + a0 = ((op_t *) srcp1)[0]; + b0 = ((op_t *) srcp2)[0]; + goto do3; + case 1: + a1 = ((op_t *) srcp1)[0]; + b1 = ((op_t *) srcp2)[0]; + srcp1 += OPSIZ; + srcp2 += OPSIZ; + len -= 1; + if (OP_T_THRES <= 3 * OPSIZ && len == 0) + goto do0; + /* Fall through. */ + } + + do + { + a0 = ((op_t *) srcp1)[0]; + b0 = ((op_t *) srcp2)[0]; + if (a1 != b1) + return CMP_LT_OR_GT (a1, b1); + + do3: + a1 = ((op_t *) srcp1)[1]; + b1 = ((op_t *) srcp2)[1]; + if (a0 != b0) + return CMP_LT_OR_GT (a0, b0); + + do2: + a0 = ((op_t *) srcp1)[2]; + b0 = ((op_t *) srcp2)[2]; + if (a1 != b1) + return CMP_LT_OR_GT (a1, b1); + + do1: + a1 = ((op_t *) srcp1)[3]; + b1 = ((op_t *) srcp2)[3]; + if (a0 != b0) + return CMP_LT_OR_GT (a0, b0); + + srcp1 += 4 * OPSIZ; + srcp2 += 4 * OPSIZ; + len -= 4; + } + while (len != 0); + + /* This is the right position for do0. Please don't move + it into the loop. */ +do0: + if (a1 != b1) + return CMP_LT_OR_GT (a1, b1); + return 0; +} + +/* memcmp_not_common_alignment -- Compare blocks at SRCP1 and SRCP2 with LEN + `op_t' objects (not LEN bytes!). SRCP2 should be aligned for memory + operations on `op_t', but SRCP1 *should be unaligned*. */ +#ifdef __GNUC__ +__inline +#endif +static int +memcmp_not_common_alignment (srcp1, srcp2, len) + long int srcp1; + long int srcp2; + size_t len; +{ + op_t a0, a1, a2, a3; + op_t b0, b1, b2, b3; + op_t x; + int shl, shr; + + /* Calculate how to shift a word read at the memory operation + aligned srcp1 to make it aligned for comparison. */ + + shl = 8 * (srcp1 % OPSIZ); + shr = 8 * OPSIZ - shl; + + /* Make SRCP1 aligned by rounding it down to the beginning of the `op_t' + it points in the middle of. */ + srcp1 &= -OPSIZ; + + switch (len % 4) + { + case 2: + a1 = ((op_t *) srcp1)[0]; + a2 = ((op_t *) srcp1)[1]; + b2 = ((op_t *) srcp2)[0]; + srcp1 -= 1 * OPSIZ; + srcp2 -= 2 * OPSIZ; + len += 2; + goto do1; + case 3: + a0 = ((op_t *) srcp1)[0]; + a1 = ((op_t *) srcp1)[1]; + b1 = ((op_t *) srcp2)[0]; + srcp2 -= 1 * OPSIZ; + len += 1; + goto do2; + case 0: + if (OP_T_THRES <= 3 * OPSIZ && len == 0) + return 0; + a3 = ((op_t *) srcp1)[0]; + a0 = ((op_t *) srcp1)[1]; + b0 = ((op_t *) srcp2)[0]; + srcp1 += 1 * OPSIZ; + goto do3; + case 1: + a2 = ((op_t *) srcp1)[0]; + a3 = ((op_t *) srcp1)[1]; + b3 = ((op_t *) srcp2)[0]; + srcp1 += 2 * OPSIZ; + srcp2 += 1 * OPSIZ; + len -= 1; + if (OP_T_THRES <= 3 * OPSIZ && len == 0) + goto do0; + /* Fall through. */ + } + + do + { + a0 = ((op_t *) srcp1)[0]; + b0 = ((op_t *) srcp2)[0]; + x = MERGE (a2, shl, a3, shr); + if (x != b3) + return CMP_LT_OR_GT (x, b3); + + do3: + a1 = ((op_t *) srcp1)[1]; + b1 = ((op_t *) srcp2)[1]; + x = MERGE (a3, shl, a0, shr); + if (x != b0) + return CMP_LT_OR_GT (x, b0); + + do2: + a2 = ((op_t *) srcp1)[2]; + b2 = ((op_t *) srcp2)[2]; + x = MERGE (a0, shl, a1, shr); + if (x != b1) + return CMP_LT_OR_GT (x, b1); + + do1: + a3 = ((op_t *) srcp1)[3]; + b3 = ((op_t *) srcp2)[3]; + x = MERGE (a1, shl, a2, shr); + if (x != b2) + return CMP_LT_OR_GT (x, b2); + + srcp1 += 4 * OPSIZ; + srcp2 += 4 * OPSIZ; + len -= 4; + } + while (len != 0); + + /* This is the right position for do0. Please don't move + it into the loop. */ +do0: + x = MERGE (a2, shl, a3, shr); + if (x != b3) + return CMP_LT_OR_GT (x, b3); + return 0; +} + +int +memcmp (s1, s2, len) + const __ptr_t s1; + const __ptr_t s2; + size_t len; +{ + op_t a0; + op_t b0; + long int srcp1 = (long int) s1; + long int srcp2 = (long int) s2; + op_t res; + + if (len >= OP_T_THRES) + { + /* There are at least some bytes to compare. No need to test + for LEN == 0 in this alignment loop. */ + while (srcp2 % OPSIZ != 0) + { + a0 = ((byte *) srcp1)[0]; + b0 = ((byte *) srcp2)[0]; + srcp1 += 1; + srcp2 += 1; + res = a0 - b0; + if (res != 0) + return res; + len -= 1; + } + + /* SRCP2 is now aligned for memory operations on `op_t'. + SRCP1 alignment determines if we can do a simple, + aligned compare or need to shuffle bits. */ + + if (srcp1 % OPSIZ == 0) + res = memcmp_common_alignment (srcp1, srcp2, len / OPSIZ); + else + res = memcmp_not_common_alignment (srcp1, srcp2, len / OPSIZ); + if (res != 0) + return res; + + /* Number of bytes remaining in the interval [0..OPSIZ-1]. */ + srcp1 += len & -OPSIZ; + srcp2 += len & -OPSIZ; + len %= OPSIZ; + } + + /* There are just a few bytes to compare. Use byte memory operations. */ + while (len != 0) + { + a0 = ((byte *) srcp1)[0]; + b0 = ((byte *) srcp2)[0]; + srcp1 += 1; + srcp2 += 1; + res = a0 - b0; + if (res != 0) + return res; + len -= 1; + } + + return 0; +} diff --git a/lib/misc/memcpy.c b/lib/misc/memcpy.c new file mode 100644 index 00000000..d36cef20 --- /dev/null +++ b/lib/misc/memcpy.c @@ -0,0 +1,20 @@ +/* Copy LEN bytes starting at SRCADDR to DESTADDR. Result undefined + if the source overlaps with the destination. + Return DESTADDR. */ + +#if HAVE_CONFIG_H +# include +#endif + +char * +memcpy (destaddr, srcaddr, len) + char *destaddr; + const char *srcaddr; + int len; +{ + char *dest = destaddr; + + while (len-- > 0) + *destaddr++ = *srcaddr++; + return dest; +} diff --git a/lib/misc/memmem.c b/lib/misc/memmem.c new file mode 100644 index 00000000..1ffbc29b --- /dev/null +++ b/lib/misc/memmem.c @@ -0,0 +1,42 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +int memcmp (); + +/* Finds the first NEEDLE of length NEEDLE_LEN in a HAYSTACK of length + HAYSTACK_LEN. Returns a pointer to the match or NULL on + failure. */ +void * +memmem (const void *haystack, size_t haystack_len, + const void *needle, size_t needle_len) +{ + size_t i; + + if (needle_len > haystack_len) + return NULL; + + for (i = 0; i <= haystack_len - needle_len; i++) + if (!memcmp (needle, &((const char *) haystack)[i], needle_len)) + return (void *) (&((const char *) haystack)[i]); + + return NULL; +} + diff --git a/lib/misc/memmove.c b/lib/misc/memmove.c new file mode 100644 index 00000000..d83cad32 --- /dev/null +++ b/lib/misc/memmove.c @@ -0,0 +1,36 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* Written by Tristan Gingold . */ + +void +memmove (const char *src, char *dest, int len) +{ + if (dest < src) + while (len--) + *dest++ = *src++; + else + { + char *lasts = (char *)src + (len-1); + char *lastd = dest + (len-1); + while (len--) + *(char *)lastd-- = *(char *)lasts--; + } +} + diff --git a/lib/misc/memset.c b/lib/misc/memset.c new file mode 100644 index 00000000..a0db560a --- /dev/null +++ b/lib/misc/memset.c @@ -0,0 +1,29 @@ +/* memset.c -- set an area of memory to a given value + Copyright (C) 1991 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +char * +memset (str, c, len) + char *str; + int c; + unsigned len; +{ + register char *st = str; + + while (len-- > 0) + *st++ = c; + return str; +} diff --git a/lib/misc/qsort.c b/lib/misc/qsort.c new file mode 100644 index 00000000..23f47c58 --- /dev/null +++ b/lib/misc/qsort.c @@ -0,0 +1,257 @@ +/* Copyright (C) 1991, 1992 Free Software Foundation, Inc. + This file is part of the GNU C Library. + Written by Douglas C. Schmidt (schmidt@ics.uci.edu). + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If + not, write to the Free Software Foundation, Inc., 675 Mass Ave, + Cambridge, MA 02139, USA. */ + +/* Modified 12/15/96 by Ben Pfaff for PSPP. */ + +#include +#include +#include +#include "alloc.h" + +/* Byte-wise swap two items of size SIZE. */ +#define SWAP(a, b, size) \ + do \ + { \ + register size_t __size = (size); \ + register char *__a = (a), *__b = (b); \ + do \ + { \ + char __tmp = *__a; \ + *__a++ = *__b; \ + *__b++ = __tmp; \ + } while (--__size > 0); \ + } while (0) + +/* Discontinue quicksort algorithm when partition gets below this size. + This particular magic number was chosen to work best on a Sun 4/260. */ +#define MAX_THRESH 4 + +/* Stack node declarations used to store unfulfilled partition obligations. */ +typedef struct + { + char *lo; + char *hi; + } +stack_node; + +/* The next 4 #defines implement a very fast in-line stack abstraction. */ +#define STACK_SIZE (8 * sizeof(unsigned long int)) +#define PUSH(low, high) ((void) ((top->lo = (low)), (top->hi = (high)), ++top)) +#define POP(low, high) ((void) (--top, (low = top->lo), (high = top->hi))) +#define STACK_NOT_EMPTY (stack < top) + + +/* Order size using quicksort. This implementation incorporates + four optimizations discussed in Sedgewick: + + 1. Non-recursive, using an explicit stack of pointer that store the + next array partition to sort. To save time, this maximum amount + of space required to store an array of MAX_INT is allocated on the + stack. Assuming a 32-bit integer, this needs only 32 * + sizeof(stack_node) == 136 bits. Pretty cheap, actually. + + 2. Chose the pivot element using a median-of-three decision tree. + This reduces the probability of selecting a bad pivot value and + eliminates certain extraneous comparisons. + + 3. Only quicksorts TOTAL_ELEMS / MAX_THRESH partitions, leaving + insertion sort to order the MAX_THRESH items within each partition. + This is a big win, since insertion sort is faster for small, mostly + sorted array segements. + + 4. The larger of the two sub-partitions is always pushed onto the + stack first, with the algorithm then concentrating on the + smaller partition. This *guarantees* no more than log (n) + stack size is needed (actually O(1) in this case)! */ + +void +blp_quicksort (void *pbase, size_t total_elems, size_t size, + int (*cmp) (const void *, const void *), + void *temp_buf +#if HAVE_ALLOCA + unused +#endif + ) +{ + register char *base_ptr = (char *) pbase; + + /* Allocating SIZE bytes for a pivot buffer facilitates a better + algorithm below since we can do comparisons directly on the pivot. */ +#if HAVE_ALLOCA + char *pivot_buffer = (char *) local_alloc (size); +#else + char *pivot_buffer = temp_buf; +#endif + const size_t max_thresh = MAX_THRESH * size; + + if (total_elems == 0) + { + /* Avoid lossage with unsigned arithmetic below. */ + local_free (pivot_buffer); + return; + } + + if (total_elems > MAX_THRESH) + { + char *lo = base_ptr; + char *hi = &lo[size * (total_elems - 1)]; + /* Largest size needed for 32-bit int!!! */ + stack_node stack[STACK_SIZE]; + stack_node *top = stack + 1; + + while (STACK_NOT_EMPTY) + { + char *left_ptr; + char *right_ptr; + + char *pivot = pivot_buffer; + + /* Select median value from among LO, MID, and HI. Rearrange + LO and HI so the three values are sorted. This lowers the + probability of picking a pathological pivot value and + skips a comparison for both the LEFT_PTR and RIGHT_PTR. */ + + char *mid = lo + size * ((hi - lo) / size >> 1); + + if ((*cmp) ((void *) mid, (void *) lo) < 0) + SWAP (mid, lo, size); + if ((*cmp) ((void *) hi, (void *) mid) < 0) + SWAP (mid, hi, size); + else + goto jump_over; + if ((*cmp) ((void *) mid, (void *) lo) < 0) + SWAP (mid, lo, size); + jump_over:; + memcpy (pivot, mid, size); + pivot = pivot_buffer; + + left_ptr = lo + size; + right_ptr = hi - size; + + /* Here's the famous ``collapse the walls'' section of quicksort. + Gotta like those tight inner loops! They are the main reason + that this algorithm runs much faster than others. */ + do + { + while ((*cmp) ((void *) left_ptr, (void *) pivot) < 0) + left_ptr += size; + + while ((*cmp) ((void *) pivot, (void *) right_ptr) < 0) + right_ptr -= size; + + if (left_ptr < right_ptr) + { + SWAP (left_ptr, right_ptr, size); + left_ptr += size; + right_ptr -= size; + } + else if (left_ptr == right_ptr) + { + left_ptr += size; + right_ptr -= size; + break; + } + } + while (left_ptr <= right_ptr); + + /* Set up pointers for next iteration. First determine whether + left and right partitions are below the threshold size. If so, + ignore one or both. Otherwise, push the larger partition's + bounds on the stack and continue sorting the smaller one. */ + + if ((size_t) (right_ptr - lo) <= max_thresh) + { + if ((size_t) (hi - left_ptr) <= max_thresh) + /* Ignore both small partitions. */ + POP (lo, hi); + else + /* Ignore small left partition. */ + lo = left_ptr; + } + else if ((size_t) (hi - left_ptr) <= max_thresh) + /* Ignore small right partition. */ + hi = right_ptr; + else if ((right_ptr - lo) > (hi - left_ptr)) + { + /* Push larger left partition indices. */ + PUSH (lo, right_ptr); + lo = left_ptr; + } + else + { + /* Push larger right partition indices. */ + PUSH (left_ptr, hi); + hi = right_ptr; + } + } + } + + /* Once the BASE_PTR array is partially sorted by quicksort the rest + is completely sorted using insertion sort, since this is efficient + for partitions below MAX_THRESH size. BASE_PTR points to the beginning + of the array to sort, and END_PTR points at the very last element in + the array (*not* one beyond it!). */ + +#define min(x, y) ((x) < (y) ? (x) : (y)) + + { + char *const end_ptr = &base_ptr[size * (total_elems - 1)]; + char *tmp_ptr = base_ptr; + char *thresh = min (end_ptr, base_ptr + max_thresh); + register char *run_ptr; + + /* Find smallest element in first threshold and place it at the + array's beginning. This is the smallest array element, + and the operation speeds up insertion sort's inner loop. */ + + for (run_ptr = tmp_ptr + size; run_ptr <= thresh; run_ptr += size) + if ((*cmp) ((void *) run_ptr, (void *) tmp_ptr) < 0) + tmp_ptr = run_ptr; + + if (tmp_ptr != base_ptr) + SWAP (tmp_ptr, base_ptr, size); + + /* Insertion sort, running from left-hand-side up to right-hand-side. */ + + run_ptr = base_ptr + size; + while ((run_ptr += size) <= end_ptr) + { + tmp_ptr = run_ptr - size; + while ((*cmp) ((void *) run_ptr, (void *) tmp_ptr) < 0) + tmp_ptr -= size; + + tmp_ptr += size; + if (tmp_ptr != run_ptr) + { + char *trav; + + trav = run_ptr + size; + while (--trav >= run_ptr) + { + char c = *trav; + char *hi, *lo; + + for (hi = lo = trav; (lo -= size) >= tmp_ptr; hi = lo) + *hi = *lo; + *hi = c; + } + } + } + } +} diff --git a/lib/misc/stpcpy.c b/lib/misc/stpcpy.c new file mode 100644 index 00000000..b9df2972 --- /dev/null +++ b/lib/misc/stpcpy.c @@ -0,0 +1,47 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +/* Some old versions of Linux libc prototype stpcpy() in string.h but + fail to include it in their C library. By not including string.h + on these systems we can avoid conflicting prototypes. Of course, + in theory this might be dangerous, if the prototype specifies some + weird calling convention, but for GNU/Linux at least it shouldn't + cause problems. + + This might be needed for systems other than GNU/Linux; let me + know. */ + +#ifdef __linux__ +void *memcpy (void *, const void *, size_t); +size_t strlen (const char *); +#else +#include "str.h" +#endif + +/* Copies SRC to DEST, returning the address of the terminating '\0' + in DEST. */ +char * +stpcpy (char *dest, const char *src) +{ + int len = strlen (src); + memcpy (dest, src, len + 1); + return &dest[len]; +} diff --git a/lib/misc/strcasecmp.c b/lib/misc/strcasecmp.c new file mode 100644 index 00000000..c71940b7 --- /dev/null +++ b/lib/misc/strcasecmp.c @@ -0,0 +1,33 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +int +strcasecmp (const char *s1, const char *s2) +{ + for (;;) + { + if (!*s1 || !*s2 + || tolower ((unsigned char) *s1) != tolower ((unsigned char) *s2)) + return (unsigned char) *s1 - (unsigned char) *s2; + s1++; + s2++; + } +} diff --git a/lib/misc/strerror.c b/lib/misc/strerror.c new file mode 100644 index 00000000..f2ed4d74 --- /dev/null +++ b/lib/misc/strerror.c @@ -0,0 +1,48 @@ +/* A replacement version of strerror + + Copyright (C) 1996 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2, or (at + your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ + +#ifdef HAVE_CONFIG_H +#include +#endif + +#include +#ifdef HAVE_ERRNO_H +#include +#endif + +#if defined (HAVE_SYS_ERRLIST) && !defined (HAVE_SYS_ERRLIST_DECL) +extern int sys_nerr; +extern char *sys_errlist[]; +#endif + +/* Return a string describing the system error code ERR. The returned value + may be in a static buffer (and in any case shouldn't be written to). */ +const char * +strerror (int err) +{ +#ifdef HAVE_SYS_ERRLIST + if (err >= 0 && err < sys_nerr && sys_errlist[err]) + return sys_errlist[err]; + else +#endif + { + static char buf[100]; + sprintf (buf, "Error %d", err); + return buf; + } +} diff --git a/lib/misc/strncasecmp.c b/lib/misc/strncasecmp.c new file mode 100644 index 00000000..ad14c2f0 --- /dev/null +++ b/lib/misc/strncasecmp.c @@ -0,0 +1,37 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +int +strncasecmp (const char *s1, const char *s2, size_t n) +{ + size_t index; + + for (index = 0; index < n; index++) + { + if (tolower ((unsigned char) s1[index]) + != tolower ((unsigned char) s2[index])) + return (((unsigned const char *)s1)[index] + - ((unsigned const char *)s2)[index]); + if (s1[index] == 0) + return 0; + } + return 0; +} diff --git a/lib/misc/strpbrk.c b/lib/misc/strpbrk.c new file mode 100644 index 00000000..75b2ed14 --- /dev/null +++ b/lib/misc/strpbrk.c @@ -0,0 +1,38 @@ +/* Copyright (C) 1991, 1994, 1996 Free Software Foundation, Inc. + This file is part of the GNU C Library. + + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + The GNU C Library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with the GNU C Library; see the file COPYING.LIB. If not, + write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, + Boston, MA 02111-1307, USA. */ + +#include + + +/* Find the first occurrence in S of any character in ACCEPT. */ +char * +strpbrk (s, accept) + const char *s; + const char *accept; +{ + while (*s != '\0') + { + const char *a = accept; + while (*a != '\0') + if (*a++ == *s) + return (char *) s; + ++s; + } + + return NULL; +} diff --git a/lib/misc/strstr.c b/lib/misc/strstr.c new file mode 100644 index 00000000..990cae53 --- /dev/null +++ b/lib/misc/strstr.c @@ -0,0 +1,24 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +char * +strstr (const char *haystack, const char *needle) +{ + return memmem (haystack, strlen (haystack), needle, strlen (needle)); +} diff --git a/lib/misc/strtok_r.c b/lib/misc/strtok_r.c new file mode 100644 index 00000000..fb68ad8c --- /dev/null +++ b/lib/misc/strtok_r.c @@ -0,0 +1,62 @@ +/* Reentrant string tokenizer. Generic version. +Copyright (C) 1991, 1996 Free Software Foundation, Inc. +This file is part of the GNU C Library. + +The GNU C Library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library General Public License as +published by the Free Software Foundation; either version 2 of the +License, or (at your option) any later version. + +The GNU C Library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Library General Public License for more details. + +You should have received a copy of the GNU Library General Public +License along with the GNU C Library; see the file COPYING.LIB. If +not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +#include + + +/* Parse S into tokens separated by characters in DELIM. + If S is NULL, the saved pointer in SAVE_PTR is used as + the next starting point. For example: + char s[] = "-abc-=-def"; + char *sp; + x = strtok_r(s, "-", &sp); // x = "abc", sp = "=-def" + x = strtok_r(NULL, "-=", &sp); // x = "def", sp = NULL + x = strtok_r(NULL, "=", &sp); // x = NULL + // s = "abc\0-def\0" +*/ +char * +strtok_r (s, delim, save_ptr) + char *s; + const char *delim; + char **save_ptr; +{ + char *token; + + if (s == NULL) + s = *save_ptr; + + /* Scan leading delimiters. */ + s += strspn (s, delim); + if (*s == '\0') + return NULL; + + /* Find the end of the token. */ + token = s; + s = strpbrk (token, delim); + if (s == NULL) + /* This token finishes the string. */ + *save_ptr = strchr (token, '\0'); + else + { + /* Terminate the token and make *SAVE_PTR point past it. */ + *s = '\0'; + *save_ptr = s + 1; + } + return token; +} diff --git a/lib/misc/strtol.c b/lib/misc/strtol.c new file mode 100644 index 00000000..025287a3 --- /dev/null +++ b/lib/misc/strtol.c @@ -0,0 +1,368 @@ +/* strtol - Convert string representation of a number into an integer value. + Copyright (C) 1991, 92, 94, 95, 96 Free Software Foundation, Inc. + NOTE: The canonical source of this file is maintained with the GNU C + Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. + + This program is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by the + Free Software Foundation; either version 2, or (at your option) any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software Foundation, + Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#if HAVE_CONFIG_H +# include +#endif + +#ifdef _LIBC +# define USE_NUMBER_GROUPING +# define STDC_HEADERS +# define HAVE_LIMITS_H +#endif + +#include +#include +#ifndef errno +extern int errno; +#endif +#ifndef __set_errno +# define __set_errno(Val) errno = (Val) +#endif + +#ifdef HAVE_LIMITS_H +# include +#endif + +#ifdef STDC_HEADERS +# include +# include +# include +#else +# ifndef NULL +# define NULL 0 +# endif +#endif + +#ifdef USE_NUMBER_GROUPING +# include "../locale/localeinfo.h" +#endif + +/* Nonzero if we are defining `strtoul' or `strtouq', operating on + unsigned integers. */ +#ifndef UNSIGNED +# define UNSIGNED 0 +# define INT LONG int +#else +# define INT unsigned LONG int +#endif + +/* Determine the name. */ +#if UNSIGNED +# ifdef USE_WIDE_CHAR +# ifdef QUAD +# define strtol wcstouq +# else +# define strtol wcstoul +# endif +# else +# ifdef QUAD +# define strtol strtouq +# else +# define strtol strtoul +# endif +# endif +#else +# ifdef USE_WIDE_CHAR +# ifdef QUAD +# define strtol wcstoq +# else +# define strtol wcstol +# endif +# else +# ifdef QUAD +# define strtol strtoq +# endif +# endif +#endif + +/* If QUAD is defined, we are defining `strtoq' or `strtouq', + operating on `long long int's. */ +#ifdef QUAD +# define LONG long long +# undef LONG_MIN +# define LONG_MIN LONG_LONG_MIN +# undef LONG_MAX +# define LONG_MAX LONG_LONG_MAX +# undef ULONG_MAX +# define ULONG_MAX ULONG_LONG_MAX +# if __GNUC__ == 2 && __GNUC_MINOR__ < 7 + /* Work around gcc bug with using this constant. */ + static const unsigned long long int maxquad = ULONG_LONG_MAX; +# undef ULONG_MAX +# define ULONG_MAX maxquad +# endif +#else +# define LONG long + +#ifndef ULONG_MAX +# define ULONG_MAX ((unsigned long) ~(unsigned long) 0) +#endif +#ifndef LONG_MAX +# define LONG_MAX ((long int) (ULONG_MAX >> 1)) +#endif +#endif + +#ifdef USE_WIDE_CHAR +# include +# include +# define L_(Ch) L##Ch +# define UCHAR_TYPE wint_t +# define STRING_TYPE wchar_t +# define ISSPACE(Ch) iswspace (Ch) +# define ISALPHA(Ch) iswalpha (Ch) +# define TOUPPER(Ch) towupper (Ch) +#else +# define L_(Ch) Ch +# define UCHAR_TYPE unsigned char +# define STRING_TYPE char +# define ISSPACE(Ch) isspace (Ch) +# define ISALPHA(Ch) isalpha (Ch) +# define TOUPPER(Ch) toupper (Ch) +#endif + +#ifdef __STDC__ +# define INTERNAL(X) INTERNAL1(X) +# define INTERNAL1(X) __##X##_internal +# define WEAKNAME(X) WEAKNAME1(X) +#else +# define INTERNAL(X) __/**/X/**/_internal +#endif + +#ifdef USE_NUMBER_GROUPING +/* This file defines a function to check for correct grouping. */ +# include "grouping.h" +#endif + + +/* Convert NPTR to an `unsigned long int' or `long int' in base BASE. + If BASE is 0 the base is determined by the presence of a leading + zero, indicating octal or a leading "0x" or "0X", indicating hexadecimal. + If BASE is < 2 or > 36, it is reset to 10. + If ENDPTR is not NULL, a pointer to the character after the last + one converted is stored in *ENDPTR. */ + +INT +INTERNAL (strtol) (nptr, endptr, base, group) + const STRING_TYPE *nptr; + STRING_TYPE **endptr; + int base; + int group; +{ + int negative; + register unsigned LONG int cutoff; + register unsigned int cutlim; + register unsigned LONG int i; + register const STRING_TYPE *s; + register UCHAR_TYPE c; + const STRING_TYPE *save, *end; + int overflow; + +#ifdef USE_NUMBER_GROUPING + /* The thousands character of the current locale. */ + wchar_t thousands; + /* The numeric grouping specification of the current locale, + in the format described in . */ + const char *grouping; + + if (group) + { + grouping = _NL_CURRENT (LC_NUMERIC, GROUPING); + if (*grouping <= 0 || *grouping == CHAR_MAX) + grouping = NULL; + else + { + /* Figure out the thousands separator character. */ + if (mbtowc (&thousands, _NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP), + strlen (_NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP))) <= 0) + thousands = (wchar_t) *_NL_CURRENT (LC_NUMERIC, THOUSANDS_SEP); + if (thousands == L'\0') + grouping = NULL; + } + } + else + grouping = NULL; +#endif + + if (base < 0 || base == 1 || base > 36) + base = 10; + + save = s = nptr; + + /* Skip white space. */ + while (ISSPACE (*s)) + ++s; + if (*s == L_('\0')) + goto noconv; + + /* Check for a sign. */ + if (*s == L_('-')) + { + negative = 1; + ++s; + } + else if (*s == L_('+')) + { + negative = 0; + ++s; + } + else + negative = 0; + + if (base == 16 && s[0] == L_('0') && TOUPPER (s[1]) == L_('X')) + s += 2; + + /* If BASE is zero, figure it out ourselves. */ + if (base == 0) + if (*s == L_('0')) + { + if (TOUPPER (s[1]) == L_('X')) + { + s += 2; + base = 16; + } + else + base = 8; + } + else + base = 10; + + /* Save the pointer so we can check later if anything happened. */ + save = s; + +#ifdef USE_NUMBER_GROUPING + if (group) + { + /* Find the end of the digit string and check its grouping. */ + end = s; + for (c = *end; c != L_('\0'); c = *++end) + if ((wchar_t) c != thousands + && ((wchar_t) c < L_('0') || (wchar_t) c > L_('9')) + && (!ISALPHA (c) || (int) (TOUPPER (c) - L_('A') + 10) >= base)) + break; + if (*s == thousands) + end = s; + else + end = correctly_grouped_prefix (s, end, thousands, grouping); + } + else +#endif + end = NULL; + + cutoff = ULONG_MAX / (unsigned LONG int) base; + cutlim = ULONG_MAX % (unsigned LONG int) base; + + overflow = 0; + i = 0; + for (c = *s; c != L_('\0'); c = *++s) + { + if (s == end) + break; + if (c >= L_('0') && c <= L_('9')) + c -= L_('0'); + else if (ISALPHA (c)) + c = TOUPPER (c) - L_('A') + 10; + else + break; + if ((int) c >= base) + break; + /* Check for overflow. */ + if (i > cutoff || (i == cutoff && c > cutlim)) + overflow = 1; + else + { + i *= (unsigned LONG int) base; + i += c; + } + } + + /* Check if anything actually happened. */ + if (s == save) + goto noconv; + + /* Store in ENDPTR the address of one character + past the last character we converted. */ + if (endptr != NULL) + *endptr = (STRING_TYPE *) s; + +#if !UNSIGNED + /* Check for a value that is within the range of + `unsigned LONG int', but outside the range of `LONG int'. */ + if (overflow == 0 + && i > (negative + ? -((unsigned LONG int) (LONG_MIN + 1)) + 1 + : (unsigned LONG int) LONG_MAX)) + overflow = 1; +#endif + + if (overflow) + { + __set_errno (ERANGE); +#if UNSIGNED + return ULONG_MAX; +#else + return negative ? LONG_MIN : LONG_MAX; +#endif + } + + /* Return the result of the appropriate sign. */ + return (negative ? -i : i); + +noconv: + /* We must handle a special case here: the base is 0 or 16 and the + first two characters are '0' and 'x', but the rest are no + hexadecimal digits. This is no error case. We return 0 and + ENDPTR points to the `x`. */ + if (endptr != NULL) + if (save - nptr >= 2 && TOUPPER (save[-1]) == L_('X') + && save[-2] == L_('0')) + *endptr = (STRING_TYPE *) &save[-1]; + else + /* There was no number to convert. */ + *endptr = (STRING_TYPE *) nptr; + + return 0L; +} + +/* External user entry point. */ + +#if _LIBC - 0 == 0 +# undef PARAMS +# if defined (__STDC__) && __STDC__ +# define PARAMS(Args) Args +# else +# define PARAMS(Args) () +# endif + +/* Prototype. */ +INT strtol PARAMS ((const STRING_TYPE *nptr, STRING_TYPE **endptr, int base)); +#endif + + +INT +#ifdef weak_function +weak_function +#endif +strtol (nptr, endptr, base) + const STRING_TYPE *nptr; + STRING_TYPE **endptr; + int base; +{ + return INTERNAL (strtol) (nptr, endptr, base, 0); +} diff --git a/lib/misc/strtoul.c b/lib/misc/strtoul.c new file mode 100644 index 00000000..715ba30b --- /dev/null +++ b/lib/misc/strtoul.c @@ -0,0 +1,22 @@ +/* Copyright (C) 1991 Free Software Foundation, Inc. + +NOTE: The canonical source of this file is maintained with the GNU C Library. +Bugs can be reported to bug-glibc@prep.ai.mit.edu. + +This program is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2, or (at your option) any +later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software Foundation, +Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#define UNSIGNED 1 + +#include diff --git a/po/ChangeLog b/po/ChangeLog new file mode 100644 index 00000000..b7fcbbb8 --- /dev/null +++ b/po/ChangeLog @@ -0,0 +1,53 @@ +Sat Jan 1 23:27:03 2000 Ben Pfaff + + * POTFILES.in: Update. + +Thu Jan 8 22:27:38 1998 Ben Pfaff + + * POTFILES.in: Recreate. + + * Makefile.in.in: Upcase `pspp' within maintainer-clean target. + +Tue Dec 2 14:35:47 1997 Ben Pfaff + + * POTFILES.in: Add src/aggregate.c; alphabetize. + +Wed Oct 8 15:53:13 1997 Ben Pfaff + + * Makefile.in.in: Updated to gettext-0.10.32 while retaining local + fixes. + +Tue Oct 7 20:22:25 1997 Ben Pfaff + + * Makefile.in.in: Maintainer-cleans Makefile. + +Thu Jul 17 01:51:23 1997 Ben Pfaff + + * POTFILES.in: Remove src/display.c. + +Sat Jul 5 23:44:30 1997 Ben Pfaff + + * POTFILES.in: Fix file list. + +Tue Jun 3 23:29:57 1997 Ben Pfaff + + * Makefile.in.in: Maintainer-cleans fiasco.pot. + +Mon Jun 2 14:22:59 1997 Ben Pfaff + + * Makefile.in.in: Maintainer-cleans cat-id-tbl.c, stamp-cat-id. + + * POTFILES.in: Added all the files that have internationalized + strings; basically this is `grep -l `find . -name \*.[qc]`'. + +Sun Jun 1 23:36:32 1997 Ben Pfaff + + * Makefile.in.in: New file, taken from gettext-0.10.27. + + * POTFILES.in: New file (empty). + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/po/Makefile.in.in b/po/Makefile.in.in new file mode 100644 index 00000000..280fae2c --- /dev/null +++ b/po/Makefile.in.in @@ -0,0 +1,247 @@ +# Makefile for program source directory in GNU NLS utilities package. +# Copyright (C) 1995, 1996, 1997 by Ulrich Drepper +# +# This file file be copied and used freely without restrictions. It can +# be used in projects which are not available under the GNU Public License +# but which still want to provide support for the GNU gettext functionality. +# Please note that the actual code is *not* freely available. + +PACKAGE = @PACKAGE@ +VERSION = @VERSION@ + +SHELL = /bin/sh +@SET_MAKE@ + +srcdir = @srcdir@ +top_srcdir = @top_srcdir@ +VPATH = @srcdir@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +datadir = $(prefix)/@DATADIRNAME@ +localedir = $(datadir)/locale +gnulocaledir = $(prefix)/share/locale +gettextsrcdir = $(prefix)/share/gettext/po +subdir = po + +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ +MKINSTALLDIRS = $(top_srcdir)/@MKINSTALLDIRS@ + +CC = @CC@ +GENCAT = @GENCAT@ +GMSGFMT = PATH=../src:$$PATH @GMSGFMT@ +MSGFMT = @MSGFMT@ +XGETTEXT = PATH=../src:$$PATH @XGETTEXT@ +MSGMERGE = PATH=../src:$$PATH msgmerge + +DEFS = @DEFS@ +CFLAGS = @CFLAGS@ +CPPFLAGS = @CPPFLAGS@ + +INCLUDES = -I.. -I$(top_srcdir)/intl + +COMPILE = $(CC) -c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) $(XCFLAGS) + +SOURCES = cat-id-tbl.c +POFILES = @POFILES@ +GMOFILES = @GMOFILES@ +DISTFILES = ChangeLog Makefile.in.in POTFILES.in $(PACKAGE).pot \ +stamp-cat-id $(POFILES) $(GMOFILES) $(SOURCES) + +POTFILES = \ + +CATALOGS = @CATALOGS@ +CATOBJEXT = @CATOBJEXT@ +INSTOBJEXT = @INSTOBJEXT@ + +.SUFFIXES: +.SUFFIXES: .c .o .po .pox .gmo .mo .msg .cat + +.c.o: + $(COMPILE) $< + +.po.pox: + $(MAKE) $(PACKAGE).pot + $(MSGMERGE) $< $(srcdir)/$(PACKAGE).pot -o $*.pox + +.po.mo: + $(MSGFMT) -o $@ $< + +.po.gmo: + file=$(srcdir)/`echo $* | sed 's,.*/,,'`.gmo \ + && rm -f $$file && $(GMSGFMT) -o $$file $< + +.po.cat: + sed -f ../intl/po2msg.sed < $< > $*.msg \ + && rm -f $@ && $(GENCAT) $@ $*.msg + + +all: all-@USE_NLS@ + +all-yes: cat-id-tbl.c $(CATALOGS) +all-no: + +$(srcdir)/$(PACKAGE).pot: $(POTFILES) + $(XGETTEXT) --default-domain=$(PACKAGE) --directory=$(top_srcdir) \ + --add-comments --keyword=_ --keyword=N_ \ + --files-from=$(srcdir)/POTFILES.in + rm -f $(srcdir)/$(PACKAGE).pot + mv $(PACKAGE).po $(srcdir)/$(PACKAGE).pot + +$(srcdir)/cat-id-tbl.c: stamp-cat-id; @: +$(srcdir)/stamp-cat-id: $(PACKAGE).pot + rm -f cat-id-tbl.tmp + sed -f ../intl/po2tbl.sed $(srcdir)/$(PACKAGE).pot \ + | sed -e "s/@PACKAGE NAME@/$(PACKAGE)/" > cat-id-tbl.tmp + if cmp -s cat-id-tbl.tmp $(srcdir)/cat-id-tbl.c; then \ + rm cat-id-tbl.tmp; \ + else \ + echo cat-id-tbl.c changed; \ + rm -f $(srcdir)/cat-id-tbl.c; \ + mv cat-id-tbl.tmp $(srcdir)/cat-id-tbl.c; \ + fi + cd $(srcdir) && rm -f stamp-cat-id && echo timestamp > stamp-cat-id + + +install: install-exec install-data +install-exec: +install-data: install-data-@USE_NLS@ +install-data-no: all +install-data-yes: all + if test -r $(MKINSTALLDIRS); then \ + $(MKINSTALLDIRS) $(datadir); \ + else \ + $(top_srcdir)/mkinstalldirs $(datadir); \ + fi + @catalogs='$(CATALOGS)'; \ + for cat in $$catalogs; do \ + cat=`basename $$cat`; \ + case "$$cat" in \ + *.gmo) destdir=$(gnulocaledir);; \ + *) destdir=$(localedir);; \ + esac; \ + lang=`echo $$cat | sed 's/\$(CATOBJEXT)$$//'`; \ + dir=$$destdir/$$lang/LC_MESSAGES; \ + if test -r $(MKINSTALLDIRS); then \ + $(MKINSTALLDIRS) $$dir; \ + else \ + $(top_srcdir)/mkinstalldirs $$dir; \ + fi; \ + if test -r $$cat; then \ + $(INSTALL_DATA) $$cat $$dir/$(PACKAGE)$(INSTOBJEXT); \ + echo "installing $$cat as $$dir/$(PACKAGE)$(INSTOBJEXT)"; \ + else \ + $(INSTALL_DATA) $(srcdir)/$$cat $$dir/$(PACKAGE)$(INSTOBJEXT); \ + echo "installing $(srcdir)/$$cat as" \ + "$$dir/$(PACKAGE)$(INSTOBJEXT)"; \ + fi; \ + if test -r $$cat.m; then \ + $(INSTALL_DATA) $$cat.m $$dir/$(PACKAGE)$(INSTOBJEXT).m; \ + echo "installing $$cat.m as $$dir/$(PACKAGE)$(INSTOBJEXT).m"; \ + else \ + if test -r $(srcdir)/$$cat.m ; then \ + $(INSTALL_DATA) $(srcdir)/$$cat.m \ + $$dir/$(PACKAGE)$(INSTOBJEXT).m; \ + echo "installing $(srcdir)/$$cat as" \ + "$$dir/$(PACKAGE)$(INSTOBJEXT).m"; \ + else \ + true; \ + fi; \ + fi; \ + done + if test "$(PACKAGE)" = "gettext"; then \ + if test -r $(MKINSTALLDIRS); then \ + $(MKINSTALLDIRS) $(gettextsrcdir); \ + else \ + $(top_srcdir)/mkinstalldirs $(gettextsrcdir); \ + fi; \ + $(INSTALL_DATA) $(srcdir)/Makefile.in.in \ + $(gettextsrcdir)/Makefile.in.in; \ + else \ + : ; \ + fi + +# Define this as empty until I found a useful application. +installcheck: + +uninstall: + catalogs='$(CATALOGS)'; \ + for cat in $$catalogs; do \ + cat=`basename $$cat`; \ + lang=`echo $$cat | sed 's/\$(CATOBJEXT)$$//'`; \ + rm -f $(localedir)/$$lang/LC_MESSAGES/$(PACKAGE)$(INSTOBJEXT); \ + rm -f $(localedir)/$$lang/LC_MESSAGES/$(PACKAGE)$(INSTOBJEXT).m; \ + rm -f $(gnulocaledir)/$$lang/LC_MESSAGES/$(PACKAGE)$(INSTOBJEXT); \ + rm -f $(gnulocaledir)/$$lang/LC_MESSAGES/$(PACKAGE)$(INSTOBJEXT).m; \ + done + rm -f $(gettextsrcdir)/po-Makefile.in.in + +check: all + +cat-id-tbl.o: ../intl/libgettext.h + +dvi info tags TAGS ID: + +mostlyclean: + rm -f core core.* *.pox $(PACKAGE).po *.old.po cat-id-tbl.tmp + rm -fr *.o + +clean: mostlyclean + +distclean: clean + rm -f Makefile Makefile.in POTFILES *.mo *.msg *.cat *.cat.m + +maintainer-clean: distclean + @echo "This command is intended for maintainers to use;" + @echo "it deletes files that may require special tools to rebuild." + rm -f $(GMOFILES) Makefile PSPP.pot cat-id-tbl.c stamp-cat-id + +distdir = ../$(PACKAGE)-$(VERSION)/$(subdir) +dist distdir: update-po $(DISTFILES) + dists="$(DISTFILES)"; \ + for file in $$dists; do \ + ln $(srcdir)/$$file $(distdir) 2> /dev/null \ + || cp -p $(srcdir)/$$file $(distdir); \ + done + +update-po: Makefile + $(MAKE) $(PACKAGE).pot + PATH=`pwd`/../src:$$PATH; \ + cd $(srcdir); \ + catalogs='$(CATALOGS)'; \ + for cat in $$catalogs; do \ + cat=`basename $$cat`; \ + lang=`echo $$cat | sed 's/\$(CATOBJEXT)$$//'`; \ + mv $$lang.po $$lang.old.po; \ + echo "$$lang:"; \ + if $(MSGMERGE) $$lang.old.po $(PACKAGE).pot -o $$lang.po; then \ + rm -f $$lang.old.po; \ + else \ + echo "msgmerge for $$cat failed!"; \ + rm -f $$lang.po; \ + mv $$lang.old.po $$lang.po; \ + fi; \ + done + +POTFILES: POTFILES.in + ( if test 'x$(srcdir)' != 'x.'; then \ + posrcprefix='$(top_srcdir)/'; \ + else \ + posrcprefix="../"; \ + fi; \ + rm -f $@-t $@ \ + && (sed -e '/^#/d' -e '/^[ ]*$$/d' \ + -e "s@.*@ $$posrcprefix& \\\\@" < $(srcdir)/$@.in \ + | sed -e '$$s/\\$$//') > $@-t \ + && chmod a-w $@-t \ + && mv $@-t $@ ) + +Makefile: Makefile.in.in ../config.status POTFILES + cd .. \ + && CONFIG_FILES=$(subdir)/$@.in CONFIG_HEADERS= \ + $(SHELL) ./config.status + +# Tell versions [3.59,3.63) of GNU make not to export all variables. +# Otherwise a system limit (for SysV at least) may be exceeded. +.NOEXPORT: diff --git a/po/POTFILES.in b/po/POTFILES.in new file mode 100644 index 00000000..2a206113 --- /dev/null +++ b/po/POTFILES.in @@ -0,0 +1,138 @@ +# List of source files containing translatable strings. +# Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + +# Common library files +lib/misc/strtol.c +lib/misc/getopt.c + +# Package source files +src/aggregate.c +src/alloc.c +src/expr-evl.c +src/expr-prs.c +src/expr-opt.c +src/debug-print.h +src/alloc.h +src/approx.h +src/avl.c +src/avl.h +src/hash.c +src/bitvector.h +src/filename.c +src/apply-dict.c +src/filename.h +src/hash.h +src/heap.c +src/heap.h +src/pool.c +src/pool.h +src/stat.h +src/str.c +src/str.h +src/data-in.c +src/data-in.h +src/data-list.c +src/dfm.c +src/dfm.h +src/file-handle.h +src/file-handle.q +src/file-type.c +src/format.c +src/format.h +src/formats.c +src/get.c +src/inpt-pgm.c +src/inpt-pgm.h +src/matrix-data.c +src/pfm-read.c +src/pfm-write.c +src/pfm.h +src/sfm-read.c +src/sfm-write.c +src/sfm.h +src/sfmP.h +src/sysfile-info.c +src/exprP.h +src/expr.h +src/command.c +src/command.h +src/getline.c +src/getline.h +src/lexer.c +src/lexer.h +src/cmdline.c +src/error.c +src/error.h +src/glob.c +src/main.c +src/main.h +src/misc.c +src/misc.h +src/version.h +src/ascii.c +src/magic.c +src/magic.h +src/matrix.c +src/matrix.h +src/random.c +src/random.h +src/stats.c +src/stats.h +src/cases.c +src/data-out.c +src/font.h +src/groff-font.c +src/html.c +src/htmlP.h +src/log.h +src/output.c +src/output.h +src/postscript.c +src/som.c +src/som.h +src/tab.c +src/tab.h +src/do-if.c +src/correlations.q +src/crosstabs.q +src/descript.q +src/frequencies.q +src/list.q +src/means.q +src/t-test.q +src/cases.h +src/count.c +src/var.h +src/vars-atr.c +src/vars-prs.c +src/vfm.c +src/vfm.h +src/vfmP.h +src/autorecode.c +src/compute.c +src/flip.c +src/print.c +src/recode.c +src/sel-if.c +src/sort.c +src/sort.h +src/do-ifP.h +src/include.c +src/loop.c +src/repeat.c +src/mis-val.c +src/modify-vars.c +src/numeric.c +src/rename-vars.c +src/sample.c +src/set.q +src/settings.h +src/split-file.c +src/temporary.c +src/title.c +src/val-labs.c +src/var-labs.c +src/vector.c +src/vector.h +src/weight.c + diff --git a/po/pspp.pot b/po/pspp.pot new file mode 100644 index 00000000..ba2ecf3d --- /dev/null +++ b/po/pspp.pot @@ -0,0 +1,5355 @@ +# SOME DESCRIPTIVE TITLE. +# Copyright (C) YEAR Free Software Foundation, Inc. +# FIRST AUTHOR , YEAR. +# +#, fuzzy +msgid "" +msgstr "" +"Project-Id-Version: PACKAGE VERSION\n" +"POT-Creation-Date: 2000-01-07 20:39-0500\n" +"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME \n" +"Language-Team: LANGUAGE \n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=CHARSET\n" +"Content-Transfer-Encoding: ENCODING\n" + +#: lib/misc/getopt.c:514 +#, c-format +msgid "%s: option `%s' is ambiguous\n" +msgstr "" + +#: lib/misc/getopt.c:538 +#, c-format +msgid "%s: option `--%s' doesn't allow an argument\n" +msgstr "" + +#: lib/misc/getopt.c:543 +#, c-format +msgid "%s: option `%c%s' doesn't allow an argument\n" +msgstr "" + +#: lib/misc/getopt.c:557 +#, c-format +msgid "%s: option `%s' requires an argument\n" +msgstr "" + +#. --option +#: lib/misc/getopt.c:585 +#, c-format +msgid "%s: unrecognized option `--%s'\n" +msgstr "" + +#. +option or -option +#: lib/misc/getopt.c:589 +#, c-format +msgid "%s: unrecognized option `%c%s'\n" +msgstr "" + +#. 1003.2 specifies the format of this message. +#: lib/misc/getopt.c:614 +#, c-format +msgid "%s: illegal option -- %c\n" +msgstr "" + +#: lib/misc/getopt.c:616 +#, c-format +msgid "%s: invalid option -- %c\n" +msgstr "" + +#. 1003.2 specifies the format of this message. +#: lib/misc/getopt.c:650 +#, c-format +msgid "%s: option requires an argument -- %c\n" +msgstr "" + +#: src/aggregate.c:191 +msgid "OUTFILE specified multiple times." +msgstr "" + +#: src/aggregate.c:217 +msgid "while expecting COLUMNWISE" +msgstr "" + +#: src/aggregate.c:232 +msgid "BREAK specified multiple times." +msgstr "" + +#: src/aggregate.c:261 +msgid "BREAK subcommand not specified." +msgstr "" + +#: src/aggregate.c:504 +msgid "expecting aggregation function" +msgstr "" + +#: src/aggregate.c:520 +#, c-format +msgid "Unknown aggregation function %s." +msgstr "" + +#: src/aggregate.c:535 +msgid "expecting `('" +msgstr "" + +#: src/aggregate.c:570 +#, c-format +msgid "Missing argument %d to %s." +msgstr "" + +#: src/aggregate.c:578 +#, c-format +msgid "Arguments to %s must be of same type as source variables." +msgstr "" + +#: src/aggregate.c:588 src/expr-prs.c:664 +msgid "expecting `)'" +msgstr "" + +#: src/aggregate.c:600 src/autorecode.c:114 +#, c-format +msgid "" +"Number of source variables (%d) does not match number of target variables " +"(%d)." +msgstr "" + +#: src/aggregate.c:671 +#, c-format +msgid "" +"Variable name %s is not unique within the aggregate file dictionary, which " +"contains the aggregate variables and the break variables." +msgstr "" + +#: src/expr-evl.c:1180 +msgid "" +"A number being treated as a Boolean in an expression was found to have a " +"value other than 0 (false), 1 (true), or the system-missing value. The " +"result was forced to 0." +msgstr "" + +#: src/expr-evl.c:1224 +#, c-format +msgid "" +"SYSMIS is not a valid index value for vector %s. The result will be set to " +"SYSMIS." +msgstr "" + +#: src/expr-evl.c:1228 +#, c-format +msgid "" +"%g is not a valid index value for vector %s. The result will be set to " +"SYSMIS." +msgstr "" + +#: src/expr-evl.c:1246 +#, c-format +msgid "" +"SYSMIS is not a valid index value for vector %s. The result will be set to " +"the empty string." +msgstr "" + +#: src/expr-evl.c:1251 +#, c-format +msgid "" +"%g is not a valid index value for vector %s. The result will be set to the " +"empty string." +msgstr "" + +#: src/expr-evl.c:1362 +#, c-format +msgid "evaluate_expression(): not implemented: %s\n" +msgstr "" + +#: src/expr-evl.c:1365 +#, c-format +msgid "evaluate_expression(): not implemented: %d\n" +msgstr "" + +#: src/expr-prs.c:140 +msgid "" +"A string expression was supplied in a place where a Boolean expression was " +"expected." +msgstr "" + +#: src/expr-prs.c:151 +msgid "" +"A numeric expression was expected in a place where one was not supplied." +msgstr "" + +#: src/expr-prs.c:159 +msgid "A string expression was expected in a place where one was not supplied." +msgstr "" + +#: src/expr-prs.c:173 +msgid "The OR operator cannot take string operands." +msgstr "" + +#: src/expr-prs.c:221 +msgid "The AND operator cannot take string operands." +msgstr "" + +#: src/expr-prs.c:270 +msgid "The NOT operator cannot take a string operand." +msgstr "" + +#: src/expr-prs.c:297 +msgid "" +"Strings cannot be compared with numeric or Boolean values with the " +"relational operators = >= > <= < <>." +msgstr "" + +#: src/expr-prs.c:354 +msgid "The `+' and `-' operators may only be used with numeric operands." +msgstr "" + +#: src/expr-prs.c:406 +msgid "The `*' and `/' operators may only be used with numeric operands." +msgstr "" + +#: src/expr-prs.c:457 +msgid "The unary minus (-) operator can only take a numeric operand." +msgstr "" + +#: src/expr-prs.c:487 +msgid "Both operands to the ** operator must be numeric." +msgstr "" + +#: src/expr-prs.c:581 +msgid "Use of $LENGTH is obsolete, returning default of 66." +msgstr "" + +#: src/expr-prs.c:586 +msgid "Use of $WIDTH is obsolete, returning default of 131." +msgstr "" + +#: src/expr-prs.c:591 +#, c-format +msgid "Unknown system variable %s." +msgstr "" + +#: src/expr-prs.c:630 +msgid "expecting variable name" +msgstr "" + +#: src/expr-prs.c:672 +msgid "in expression" +msgstr "" + +#: src/expr-prs.c:849 +msgid "Argument 2 to LAG must be a small positive integer constant." +msgstr "" + +#: src/expr-prs.c:922 src/expr-prs.c:961 +#, c-format +msgid "" +"Type mismatch in argument %d of %s, which was expected to be of %s type. It " +"was actually of %s type. " +msgstr "" + +#: src/expr-prs.c:948 +#, c-format +msgid "%s cannot take Boolean operands." +msgstr "" + +#: src/expr-prs.c:980 +msgid "in function call" +msgstr "" + +#: src/expr-prs.c:994 +msgid "RANGE requires an odd number of arguments, but at least three." +msgstr "" + +#: src/expr-prs.c:1004 +#, c-format +msgid "%s requires at least two arguments." +msgstr "" + +#: src/expr-prs.c:1019 +#, c-format +msgid "%s.%d requires at least %d arguments." +msgstr "" + +#: src/expr-prs.c:1061 +#, c-format +msgid "" +"Argument %d to CONCAT is type %s. All arguments to CONCAT must be strings." +msgstr "" + +#: src/expr-prs.c:1120 +#, c-format +msgid "" +"Argument %d to %s was expected to be of %s type. It was actually of type %s." +msgstr "" + +#: src/apply-dict.c:72 src/apply-dict.c:73 src/expr-prs.c:1123 +#: src/expr-prs.c:1464 src/expr-prs.c:1483 src/formats.c:105 +#: src/pfm-read.c:654 src/print.c:719 src/sfm-read.c:1009 src/sfm-read.c:1137 +#: src/sfm-read.c:1138 +msgid "numeric" +msgstr "" + +#: src/apply-dict.c:72 src/apply-dict.c:73 src/expr-prs.c:1123 +#: src/expr-prs.c:1467 src/expr-prs.c:1485 src/formats.c:105 +#: src/pfm-read.c:654 src/print.c:719 src/sfm-read.c:1009 src/sfm-read.c:1137 +#: src/sfm-read.c:1138 +msgid "string" +msgstr "" + +#: src/expr-prs.c:1139 +#, c-format +msgid "%s is not a numeric format." +msgstr "" + +#: src/expr-prs.c:1165 +#, c-format +msgid "Too few arguments to function %s." +msgstr "" + +#: src/expr-prs.c:1197 +#, c-format +msgid "" +"Type mismatch in argument %d of %s, which was expected to be numeric. It " +"was actually type %s." +msgstr "" + +#: src/expr-prs.c:1206 +#, c-format +msgid "Missing comma following argument %d of %s." +msgstr "" + +#: src/expr-prs.c:1244 +msgid "The index value after a vector name must be numeric." +msgstr "" + +#: src/expr-prs.c:1251 +msgid "`)' expected after a vector index value." +msgstr "" + +#: src/expr-prs.c:1283 +#, c-format +msgid "There is no function named %s." +msgstr "" + +#: src/expr-prs.c:1288 +#, c-format +msgid "Function %s may not be given a minimum number of arguments." +msgstr "" + +#: src/expr-prs.c:1297 +#, c-format +msgid "expecting `)' after %s function" +msgstr "" + +#. FE +#: src/error.c:281 src/error.c:288 src/error.c:291 src/expr-prs.c:1458 +msgid "error" +msgstr "" + +#: src/expr-prs.c:1461 +msgid "Boolean" +msgstr "" + +#: src/expr-prs.c:1689 +msgid "!!TERMINAL!!" +msgstr "" + +#: src/expr-prs.c:1715 +msgid "!!SENTINEL!!" +msgstr "" + +#: src/expr-prs.c:1718 +#, c-format +msgid "!!ERROR%d!!" +msgstr "" + +#: src/expr-prs.c:1736 +msgid "postfix:" +msgstr "" + +#: src/expr-opt.c:662 +msgid "" +"While optimizing a constant expression, there was a bad value for the third " +"argument to INDEX." +msgstr "" + +#: src/expr-opt.c:687 +msgid "" +"While optimizing a constant expression, there was a bad value for the third " +"argument to RINDEX." +msgstr "" + +#: src/expr-opt.c:746 +#, c-format +msgid "Third argument to %cPAD() must be at least one character in length." +msgstr "" + +#: src/expr-opt.c:779 +#, c-format +msgid "Second argument to %cTRIM() must be at least one character in length." +msgstr "" + +#: src/expr-opt.c:880 +msgid "" +"When optimizing a constant expression, an integer that was being used as an " +"Boolean value was found to have a constant value other than 0, 1, or SYSMIS." +msgstr "" + +#: src/hash.c:315 +msgid "hash table:" +msgstr "" + +#: src/filename.c:240 +#, c-format +msgid "Searching for `%s'..." +msgstr "" + +#: src/filename.c:248 src/filename.c:280 +msgid "Search unsuccessful!" +msgstr "" + +#: src/filename.c:273 +#, c-format +msgid "Found `%s'." +msgstr "" + +#: src/filename.c:694 +#, c-format +msgid "Not opening pipe file `%s' because SAFER option set." +msgstr "" + +#: src/apply-dict.c:69 +#, c-format +msgid "Variable %s is %s in target file, but %s in source file." +msgstr "" + +#: src/apply-dict.c:85 +#, c-format +msgid "Cannot add value labels from source file to long string variable %s." +msgstr "" + +#: src/apply-dict.c:121 +#, c-format +msgid "" +"Cannot apply missing values from source file to long string variable %s." +msgstr "" + +#: src/apply-dict.c:153 +msgid "No matching variables found between the source and target files." +msgstr "" + +#: src/heap.c:167 +#, c-format +msgid "bad ordering of keys %d and %d\n" +msgstr "" + +#: src/heap.c:177 +msgid "Heap contents:\n" +msgstr "" + +#: src/data-in.c:71 +msgid "data-file error: " +msgstr "" + +#: src/data-in.c:73 +#, c-format +msgid "(column %d" +msgstr "" + +#: src/data-in.c:75 +#, c-format +msgid "(columns %d-%d" +msgstr "" + +#: src/data-in.c:76 +#, c-format +msgid ", field type %s) " +msgstr "" + +#: src/data-in.c:225 +msgid "Field contents followed by garbage." +msgstr "" + +#. Return an overflow error. +#: src/data-in.c:258 +msgid "Overflow in floating-point constant." +msgstr "" + +#. Return an underflow error. +#: src/data-in.c:264 +msgid "Underflow in floating-point constant." +msgstr "" + +#. There was no number. +#: src/data-in.c:270 +msgid "Field does not form a valid floating-point constant." +msgstr "" + +#: src/data-in.c:295 +msgid "All characters in field must be digits." +msgstr "" + +#: src/data-in.c:320 +msgid "Unrecognized character in field." +msgstr "" + +#: src/data-in.c:338 src/data-in.c:592 +msgid "Field must have even length." +msgstr "" + +#: src/data-in.c:348 src/data-in.c:602 +msgid "Field must contain only hex digits." +msgstr "" + +#: src/data-in.c:385 +msgid "" +"Quality of zoned decimal (Z) input format code is suspect. Check your " +"results three times, report bugs to author." +msgstr "" + +#: src/data-in.c:397 +msgid "Zoned decimal field contains fewer than 2 characters." +msgstr "" + +#: src/data-in.c:405 +msgid "Bad sign byte in zoned decimal number." +msgstr "" + +#: src/data-in.c:422 +msgid "Format error in zoned decimal number." +msgstr "" + +#: src/data-in.c:436 +msgid "Error in syntax of zoned decimal number." +msgstr "" + +#: src/data-in.c:647 +msgid "Unexpected end of field." +msgstr "" + +#: src/data-in.c:673 +msgid "Digit expected in field." +msgstr "" + +#: src/data-in.c:698 +#, c-format +msgid "Day (%ld) must be between 1 and 31." +msgstr "" + +#: src/data-in.c:723 +msgid "Delimiter expected between fields in date." +msgstr "" + +#: src/data-in.c:820 +#, c-format +msgid "Month (%ld) must be between 1 and 12." +msgstr "" + +#: src/data-in.c:861 +#, c-format +msgid "Month (%s) must be between I and XII." +msgstr "" + +#: src/data-in.c:888 +#, c-format +msgid "Month name (%s...) is too long." +msgstr "" + +#: src/data-in.c:899 +#, c-format +msgid "Bad month name (%s)." +msgstr "" + +#: src/data-in.c:915 +#, c-format +msgid "Year (%ld) must be between 1582 and 19999." +msgstr "" + +#: src/data-in.c:926 +#, c-format +msgid "Trailing garbage \"%s\" following date." +msgstr "" + +#: src/data-in.c:941 +#, c-format +msgid "Julian day (%d) must be between 1 and 366." +msgstr "" + +#: src/data-in.c:953 +#, c-format +msgid "Year (%d) must be between 1582 and 19999." +msgstr "" + +#: src/data-in.c:969 +#, c-format +msgid "Quarter (%ld) must be between 1 and 4." +msgstr "" + +#: src/data-in.c:979 +msgid "`Q' expected between quarter and year." +msgstr "" + +#: src/data-in.c:995 +#, c-format +msgid "Week (%ld) must be between 1 and 53." +msgstr "" + +#: src/data-in.c:1006 +msgid "`WK' expected between week and year." +msgstr "" + +#: src/data-in.c:1029 +msgid "Delimiter expected between fields in time." +msgstr "" + +#: src/data-in.c:1041 +#, c-format +msgid "Hour (%ld) must be positive." +msgstr "" + +#: src/data-in.c:1053 +#, c-format +msgid "Minute (%ld) must be between 0 and 59." +msgstr "" + +#: src/data-in.c:1100 +#, c-format +msgid "Hour (%ld) must be between 0 and 23." +msgstr "" + +#: src/data-in.c:1114 src/data-in.c:1149 +msgid "Day of the week expected in date value." +msgstr "" + +#: src/data-in.c:1200 +msgid "Date is not in valid range between 15 Oct 1582 and 31 Dec 19999." +msgstr "" + +#: src/data-in.c:1528 +#, c-format +msgid "Field too long (%d characters). Truncated after character %d." +msgstr "" + +#: src/data-list.c:154 +msgid "" +"DATA LIST may not use a different file from that specified on its " +"surrounding FILE TYPE." +msgstr "" + +#: src/data-list.c:173 +msgid "The END subcommand may only be specified once." +msgstr "" + +#: src/data-list.c:209 +msgid "Only one of FIXED, FREE, or LIST may be specified." +msgstr "" + +#: src/data-list.c:339 src/print.c:320 +#, c-format +msgid "" +"The record number specified, %ld, is before the previous record, %d. Data " +"fields must be listed in order of increasing record number." +msgstr "" + +#: src/data-list.c:371 src/data-list.c:1635 +msgid "" +"SPSS-like or FORTRAN-like format specification expected after variable names." +msgstr "" + +#: src/data-list.c:382 src/print.c:352 +msgid "" +"Variables are specified on records that should not exist according to " +"RECORDS subcommand." +msgstr "" + +#: src/autorecode.c:125 src/command.c:714 src/compute.c:361 +#: src/data-list.c:390 src/data-list.c:840 src/data-list.c:1646 +#: src/do-if.c:267 src/file-handle.q:90 src/get.c:436 src/lexer.c:384 +#: src/loop.c:250 src/matrix-data.c:527 src/print.c:359 src/print.c:1100 +#: src/recode.c:411 src/sel-if.c:56 src/sel-if.c:136 src/vector.c:208 +msgid "expecting end of command" +msgstr "" + +#: src/data-list.c:414 src/data-list.c:427 src/print.c:529 src/print.c:542 +msgid "Column positions for fields must be positive." +msgstr "" + +#: src/data-list.c:432 +msgid "The ending column for a field must be greater than the starting column." +msgstr "" + +#: src/data-list.c:456 src/print.c:570 +msgid "A format specifier on this line has extra characters on the end." +msgstr "" + +#: src/data-list.c:471 src/print.c:586 +msgid "The value for number of decimal places must be at least 1." +msgstr "" + +#: src/data-list.c:485 src/print.c:599 +#, c-format +msgid "Input format %s doesn't accept decimal places." +msgstr "" + +#: src/data-list.c:506 src/print.c:619 +#, c-format +msgid "The %d columns %d-%d can't be evenly divided into %d fields." +msgstr "" + +#: src/data-list.c:539 src/data-list.c:626 src/data-list.c:823 +#, c-format +msgid "%s is a duplicate variable name." +msgstr "" + +#: src/data-list.c:544 +#, c-format +msgid "There is already a variable %s of a different type." +msgstr "" + +#: src/data-list.c:551 +#, c-format +msgid "There is already a string variable %s of a different width." +msgstr "" + +#: src/data-list.c:615 src/print.c:708 +msgid "" +"The number of format specifications exceeds the number of variable names " +"given." +msgstr "" + +#: src/data-list.c:699 src/print.c:792 +msgid "" +"There aren't enough format specifications to match the number of variable " +"names given." +msgstr "" + +#: src/data-list.c:733 src/data-list.c:867 src/descript.q:799 src/print.c:824 +#: src/sysfile-info.c:130 src/sysfile-info.c:369 src/vfm.c:1133 +msgid "Variable" +msgstr "" + +#: src/data-list.c:734 src/print.c:825 +msgid "Record" +msgstr "" + +#: src/data-list.c:735 src/print.c:826 +msgid "Columns" +msgstr "" + +#: src/data-list.c:736 src/data-list.c:868 src/print.c:827 +msgid "Format" +msgstr "" + +#: src/data-list.c:758 +#, c-format +msgid "Reading %d record%s from file %s." +msgstr "" + +#: src/data-list.c:759 +#, c-format +msgid "Reading %d record%s from the command file." +msgstr "" + +#: src/data-list.c:764 src/data-list.c:765 +msgid "Occurrence data specifications." +msgstr "" + +#: src/data-list.c:891 +#, c-format +msgid "Reading free-form data from file %s." +msgstr "" + +#: src/data-list.c:892 +msgid "Reading free-form data from the command file." +msgstr "" + +#: src/data-list.c:943 src/matrix-data.c:957 +msgid "Scope of string exceeds line." +msgstr "" + +#: src/data-list.c:1004 +msgid "Attempt to read past end of file." +msgstr "" + +#: src/data-list.c:1033 +msgid "abort in write_case()\n" +msgstr "" + +#. Note that this can't occur on the first record. +#: src/data-list.c:1064 +#, c-format +msgid "Partial case of %d of %d records discarded." +msgstr "" + +#: src/data-list.c:1113 +#, c-format +msgid "Partial case discarded. The first variable missing was %s." +msgstr "" + +#: src/data-list.c:1154 +#, c-format +msgid "" +"Missing value(s) for all variables from %s onward. These will be filled " +"with the system-missing value or blanks, as appropriate." +msgstr "" + +#: src/data-list.c:1312 +msgid "" +"REPEATING DATA must use the same file as its corresponding DATA LIST or FILE " +"TYPE." +msgstr "" + +#: src/data-list.c:1322 +msgid "STARTS subcommand given multiple times." +msgstr "" + +#: src/data-list.c:1346 +#, c-format +msgid "STARTS beginning column (%d) exceeds STARTS ending column (%d)." +msgstr "" + +#: src/data-list.c:1357 +msgid "OCCURS subcommand given multiple times." +msgstr "" + +#: src/data-list.c:1370 +msgid "LENGTH subcommand given multiple times." +msgstr "" + +#: src/data-list.c:1383 +msgid "CONTINUED subcommand given multiple times." +msgstr "" + +#: src/data-list.c:1402 +#, c-format +msgid "CONTINUED beginning column (%d) exceeds CONTINUED ending column (%d)." +msgstr "" + +#: src/data-list.c:1416 +msgid "ID subcommand given multiple times." +msgstr "" + +#: src/data-list.c:1425 +#, c-format +msgid "ID beginning column (%ld) must be positive." +msgstr "" + +#: src/data-list.c:1440 +#, c-format +msgid "ID ending column (%ld) must be positive." +msgstr "" + +#: src/data-list.c:1446 +#, c-format +msgid "ID ending column (%ld) cannot be less than ID beginning column (%d)." +msgstr "" + +#: src/data-list.c:1485 +msgid "Missing required specification STARTS." +msgstr "" + +#: src/data-list.c:1487 +msgid "Missing required specification OCCURS." +msgstr "" + +#: src/data-list.c:1494 +msgid "ID specified without CONTINUED." +msgstr "" + +#: src/data-list.c:1582 +msgid "String variable not allowed here." +msgstr "" + +#: src/data-list.c:1592 +#, c-format +msgid "%s (%d) must be at least 1." +msgstr "" + +#: src/data-list.c:1598 +#, c-format +msgid "Variable or integer expected for %s." +msgstr "" + +#: src/data-list.c:1737 +#, c-format +msgid "Mismatched case ID (%s). Expected value was %s." +msgstr "" + +#: src/data-list.c:1769 +#, c-format +msgid "" +"Variable %s startging in column %d extends beyond physical record length of " +"%d." +msgstr "" + +#: src/data-list.c:1837 +#, c-format +msgid "Invalid value %d for OCCURS." +msgstr "" + +#: src/data-list.c:1843 +#, c-format +msgid "Beginning column for STARTS (%d) must be at least 1." +msgstr "" + +#: src/data-list.c:1851 +#, c-format +msgid "Ending column for STARTS (%d) is less than beginning column (%d)." +msgstr "" + +#: src/data-list.c:1859 +#, c-format +msgid "Invalid value %d for LENGTH." +msgstr "" + +#: src/data-list.c:1866 +#, c-format +msgid "Beginning column for CONTINUED (%d) must be at least 1." +msgstr "" + +#: src/data-list.c:1874 +#, c-format +msgid "Ending column for CONTINUED (%d) is less than beginning column (%d)." +msgstr "" + +#: src/data-list.c:1897 +#, c-format +msgid "" +"Number of repetitions specified on OCCURS (%d) exceed number of repetitions " +"available in space on STARTS (%d), and CONTINUED not specified." +msgstr "" + +#: src/data-list.c:1914 +#, c-format +msgid "Unexpected end of file with %d repetitions remaining out of %d." +msgstr "" + +#: src/dfm.c:92 +#, c-format +msgid "%s: Closing data-file handle %s." +msgstr "" + +#: src/dfm.c:117 +msgid "<>" +msgstr "" + +#: src/dfm.c:139 +#, c-format +msgid "%s: Opening data-file handle %s for reading." +msgstr "" + +#: src/dfm.c:156 src/dfm.c:173 +msgid "BEGIN DATA expected." +msgstr "" + +#: src/dfm.c:193 +#, c-format +msgid "An error occurred while opening \"%s\" for reading as a data file: %s." +msgstr "" + +#: src/dfm.c:222 +#, c-format +msgid "%s: Opening data-file handle %s for writing." +msgstr "" + +#: src/dfm.c:228 +msgid "Cannot open the inline file for writing." +msgstr "" + +#: src/dfm.c:243 +#, c-format +msgid "An error occurred while opening \"%s\" for writing as a data file: %s." +msgstr "" + +#: src/dfm.c:388 +msgid "" +"Unexpected end-of-file while reading data in BEGIN DATA. This probably " +"indicates a missing or misformatted END DATA command. END DATA must appear " +"by itself on a single line with exactly one space between words." +msgstr "" + +#: src/dfm.c:421 src/dfm.c:442 +#, c-format +msgid "Error reading file %s: %s." +msgstr "" + +#: src/dfm.c:445 +#, c-format +msgid "%s: Partial record at end of file." +msgstr "" + +#: src/dfm.c:501 +#, c-format +msgid "Cannot read from file %s already opened for %s." +msgstr "" + +#: src/dfm.c:515 +#, c-format +msgid "Attempt to read beyond end-of-file on file %s." +msgstr "" + +#: src/dfm.c:609 +#, c-format +msgid "Cannot write to file %s already opened for %s." +msgstr "" + +#: src/dfm.c:633 +#, c-format +msgid "Error writing file %s: %s." +msgstr "" + +#: src/dfm.c:676 +msgid "" +"This command is not valid here since the current input program does not " +"access the inline file." +msgstr "" + +#. Initialize inline_file. +#: src/dfm.c:683 +msgid "inline file: Opening for reading." +msgstr "" + +#: src/dfm.c:697 +msgid "Skipping remaining inline data." +msgstr "" + +#: src/dfm.c:709 +msgid "reading as a data file" +msgstr "" + +#: src/dfm.c:716 +msgid "writing as a data file" +msgstr "" + +#: src/file-handle.q:74 +#, c-format +msgid "" +"File handle %s had already been defined to refer to file %s. It is not " +"possible to redefine a file handle within a session." +msgstr "" + +#: src/file-handle.q:96 +msgid "The FILE HANDLE required subcommand NAME is not present." +msgstr "" + +#: src/file-handle.q:109 +msgid "" +"Fixed length records were specified on /RECFORM, but record length was not " +"specified on /LRECL. 80-character records will be assumed." +msgstr "" + +#: src/file-handle.q:116 +#, c-format +msgid "" +"Record length (%ld) must be at least one byte. 80-character records will be " +"assumed." +msgstr "" + +#: src/file-handle.q:127 +msgid "" +"/RECFORM SPANNED is not implemented, as the author doesn't know what it is " +"supposed to do. Send the author a note." +msgstr "" + +#: src/file-handle.q:140 +msgid "" +"/MODE IMAGE is not implemented, as the author doesn't know what it is " +"supposed to do. Send the author a note." +msgstr "" + +#: src/file-handle.q:147 +msgid "/MODE MULTIPUNCH is not implemented. If you care, complain." +msgstr "" + +#: src/file-handle.q:151 +msgid "/MODE 360 is not implemented. If you care, complain." +msgstr "" + +#: src/file-handle.q:233 +#, c-format +msgid "File handle `%s' has not been previously declared on FILE HANDLE." +msgstr "" + +#: src/file-handle.q:309 +msgid "" +msgstr "" + +#: src/file-handle.q:328 +msgid "expecting a file name or handle" +msgstr "" + +#: src/file-type.c:126 +msgid "MIXED, GROUPED, or NESTED expected." +msgstr "" + +#: src/file-type.c:149 +msgid "The CASE subcommand is not valid on FILE TYPE MIXED." +msgstr "" + +#: src/file-type.c:167 +msgid "WARN or NOWARN expected after WILD." +msgstr "" + +#: src/file-type.c:175 +msgid "The DUPLICATE subcommand is not valid on FILE TYPE MIXED." +msgstr "" + +#: src/file-type.c:189 +msgid "DUPLICATE=CASE is only valid on FILE TYPE NESTED." +msgstr "" + +#: src/file-type.c:198 +#, c-format +msgid "WARN%s expected after DUPLICATE." +msgstr "" + +#: src/file-type.c:199 +msgid ", NOWARN, or CASE" +msgstr "" + +#: src/file-type.c:200 +msgid " or NOWARN" +msgstr "" + +#: src/file-type.c:208 +msgid "The MISSING subcommand is not valid on FILE TYPE MIXED." +msgstr "" + +#: src/file-type.c:220 +msgid "WARN or NOWARN after MISSING." +msgstr "" + +#: src/file-type.c:228 +msgid "ORDERED is only valid on FILE TYPE GROUPED." +msgstr "" + +#: src/file-type.c:239 +msgid "YES or NO expected after ORDERED." +msgstr "" + +#: src/file-type.c:245 src/file-type.c:555 src/get.c:420 +msgid "while expecting a valid subcommand" +msgstr "" + +#: src/file-type.c:252 +msgid "The required RECORD subcommand was not present." +msgstr "" + +#: src/file-type.c:260 +msgid "The required CASE subcommand was not present." +msgstr "" + +#: src/file-type.c:266 +msgid "CASE and RECORD must specify different variable names." +msgstr "" + +#: src/file-type.c:317 +msgid "Column value must be positive." +msgstr "" + +#: src/file-type.c:332 +msgid "Ending column precedes beginning column." +msgstr "" + +#: src/file-type.c:351 +msgid "Bad format specifier name." +msgstr "" + +#: src/file-type.c:417 src/file-type.c:576 +msgid "" +"This command may only appear within a FILE TYPE/END FILE TYPE structure." +msgstr "" + +#: src/file-type.c:424 +msgid "OTHER may appear only on the last RECORD TYPE command." +msgstr "" + +#: src/file-type.c:434 +msgid "No input commands (DATA LIST, REPEATING DATA) for above RECORD TYPE." +msgstr "" + +#: src/file-type.c:488 +msgid "" +"The CASE subcommand is not allowed on the RECORD TYPE command for FILE TYPE " +"MIXED." +msgstr "" + +#: src/file-type.c:498 +msgid "" +"No variable name may be specified for the CASE subcommand on RECORD TYPE." +msgstr "" + +#: src/file-type.c:506 +msgid "" +"The CASE column specification on RECORD TYPE must give a format specifier " +"that is the same type as that of the CASE column specification given on FILE " +"TYPE." +msgstr "" + +#: src/file-type.c:522 +msgid "WARN or NOWARN expected on DUPLICATE subcommand." +msgstr "" + +#: src/file-type.c:536 +msgid "WARN or NOWARN expected on MISSING subcommand." +msgstr "" + +#: src/file-type.c:549 +msgid "YES or NO expected on SPREAD subcommand." +msgstr "" + +#: src/file-type.c:589 +msgid "No input commands (DATA LIST, REPEATING DATA) on above RECORD TYPE." +msgstr "" + +#: src/file-type.c:596 +msgid "No commands between FILE TYPE and END FILE TYPE." +msgstr "" + +#: src/file-type.c:661 +#, c-format +msgid "Unknown record type \"%.*s\"." +msgstr "" + +#: src/file-type.c:685 +#, c-format +msgid "Unknown record type %g." +msgstr "" + +#: src/format.c:75 +msgid "X and T format specifiers not allowed here." +msgstr "" + +#: src/format.c:81 +#, c-format +msgid "%s is not a valid data format." +msgstr "" + +#: src/format.c:112 +#, c-format +msgid "Format %s may not be used as an input format." +msgstr "" + +#: src/format.c:117 +#, c-format +msgid "" +"Input format %s specifies a bad width %d. Format %s requires a width " +"between %d and %d." +msgstr "" + +#: src/format.c:124 +#, c-format +msgid "" +"Input format %s specifies an odd width %d, but format %s requires an even " +"width between %d and %d." +msgstr "" + +#: src/format.c:131 +#, c-format +msgid "" +"Input format %s specifies a bad number of implied decimal places %d. Input " +"format %s allows up to 16 implied decimal places." +msgstr "" + +#: src/format.c:151 +#, c-format +msgid "" +"Output format %s specifies a bad width %d. Format %s requires a width " +"between %d and %d." +msgstr "" + +#: src/format.c:161 +#, c-format +msgid "" +"Output format %s requires minimum width %d to allow %d decimal places. Try " +"%s%d.%d instead of %s." +msgstr "" + +#: src/format.c:169 +#, c-format +msgid "" +"Output format %s specifies an odd width %d, but output format %s requires an " +"even width between %d and %d." +msgstr "" + +#: src/format.c:176 +#, c-format +msgid "" +"Output format %s specifies a bad number of implied decimal places %d. " +"Output format %s allows a number of implied decimal places between 1 and 16." +msgstr "" + +#: src/format.c:193 +#, c-format +msgid "Can't display a string variable of width %d with format specifier %s." +msgstr "" + +#: src/format.c:303 +msgid "Format specifier expected." +msgstr "" + +#: src/format.c:314 +#, c-format +msgid "Data format %s does not specify a width." +msgstr "" + +#: src/format.c:331 +#, c-format +msgid "Data format %s is not valid." +msgstr "" + +#: src/formats.c:95 +msgid "`(' expected after variable list" +msgstr "" + +#: src/formats.c:104 +#, c-format +msgid "Format %s may not be assigned to a %s variable." +msgstr "" + +#: src/formats.c:125 src/numeric.c:68 src/numeric.c:142 +msgid "`)' expected after output format." +msgstr "" + +#: src/formats.c:155 +msgid "Formats:\n" +msgstr "" + +#: src/formats.c:156 +msgid " Name Print Write\n" +msgstr "" + +#: src/get.c:125 +msgid "GET translation table from file to memory:\n" +msgstr "" + +#: src/get.c:130 src/get.c:1487 +#, c-format +msgid " %8s from %3d,%3d to %3d,%3d\n" +msgstr "" + +#: src/get.c:426 +msgid "All variables deleted from system file dictionary." +msgstr "" + +#: src/get.c:472 +#, c-format +msgid "" +"Cannot rename %s as %s because there already exists a variable named %s. To " +"rename variables with overlapping names, use a single RENAME subcommand such " +"as \"/RENAME (A=B)(B=C)(C=A)\", or equivalently, \"/RENAME (A B C=B C A)\"." +msgstr "" + +#: src/get.c:497 +msgid "`=' expected after variable list." +msgstr "" + +#: src/get.c:504 +#, c-format +msgid "" +"Number of variables on left side of `=' (%d) do not match number of " +"variables on right side (%d), in parenthesized group %d of RENAME subcommand." +msgstr "" + +#: src/get.c:522 +#, c-format +msgid "Duplicate variables name %s." +msgstr "" + +#: src/get.c:545 +msgid "" +"\n" +"Variables in dictionary:\n" +msgstr "" + +#: src/get.c:659 +msgid "The BY subcommand may be given once at most." +msgstr "" + +#: src/get.c:726 +msgid "The active file may not be specified more than once." +msgstr "" + +#: src/get.c:735 +msgid "Cannot specify the active file since no active file has been defined." +msgstr "" + +#: src/get.c:767 +msgid "" +"IN, FIRST, and LAST subcommands may not occur before the first FILE or TABLE." +msgstr "" + +#: src/get.c:799 +#, c-format +msgid "Multiple %s subcommands for a single FILE or TABLE." +msgstr "" + +#: src/get.c:809 +#, c-format +msgid "Duplicate variable name %s while creating %s variable." +msgstr "" + +#: src/get.c:823 +msgid "" +"RENAME, KEEP, and DROP subcommands may not occur before the first FILE or " +"TABLE." +msgstr "" + +#: src/get.c:847 +msgid "The BY subcommand is required when a TABLE subcommand is given." +msgstr "" + +#: src/get.c:868 +#, c-format +msgid "File %s lacks BY variable %s." +msgstr "" + +#: src/get.c:1386 +#, c-format +msgid "" +"Variable %s in file %s (%s) has different type or width from the same " +"variable in earlier file (%s)." +msgstr "" + +#: src/get.c:1438 +msgid "expecting COMM or TAPE" +msgstr "" + +#: src/get.c:1482 +msgid "IMPORT translation table from file to memory:\n" +msgstr "" + +#: src/inpt-pgm.c:81 +msgid "No matching INPUT PROGRAM command." +msgstr "" + +#: src/inpt-pgm.c:86 +msgid "" +"No data-input or transformation commands specified between INPUT PROGRAM and " +"END INPUT PROGRAM." +msgstr "" + +#: src/inpt-pgm.c:302 src/inpt-pgm.c:445 +msgid "" +"This command may only be executed between INPUT PROGRAM and END INPUT " +"PROGRAM." +msgstr "" + +#: src/inpt-pgm.c:361 +msgid "COLUMN subcommand multiply specified." +msgstr "" + +#: src/inpt-pgm.c:375 +msgid "expecting file handle name" +msgstr "" + +#: src/inpt-pgm.c:418 +msgid "" +"REREAD: Column numbers must be positive finite numbers. Column set to 1." +msgstr "" + +#: src/matrix-data.c:204 +msgid "VARIABLES subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:219 +msgid "VARNAME_ cannot be explicitly specified on VARIABLES." +msgstr "" + +#: src/matrix-data.c:285 +msgid "in FORMAT subcommand" +msgstr "" + +#: src/matrix-data.c:296 +msgid "SPLIT subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:303 +msgid "in SPLIT subcommand" +msgstr "" + +#: src/matrix-data.c:312 +msgid "Split variable may not be named ROWTYPE_ or VARNAME_." +msgstr "" + +#: src/matrix-data.c:348 +#, c-format +msgid "Split variable %s is already another type." +msgstr "" + +#: src/matrix-data.c:363 +msgid "FACTORS subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:378 +#, c-format +msgid "Factor variable %s is already another type." +msgstr "" + +#: src/matrix-data.c:393 +msgid "CELLS subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:399 src/matrix-data.c:418 +msgid "expecting positive integer" +msgstr "" + +#: src/matrix-data.c:412 +msgid "N subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:433 +msgid "CONTENTS subcommand multiply specified." +msgstr "" + +#: src/matrix-data.c:453 +msgid "Nested parentheses not allowed." +msgstr "" + +#: src/matrix-data.c:463 +msgid "Mismatched right parenthesis (`(')." +msgstr "" + +#: src/matrix-data.c:468 +msgid "Empty parentheses not allowed." +msgstr "" + +#: src/matrix-data.c:481 src/matrix-data.c:489 +msgid "in CONTENTS subcommand" +msgstr "" + +#: src/matrix-data.c:496 +#, c-format +msgid "Content multiply specified for %s." +msgstr "" + +#: src/matrix-data.c:513 +msgid "Missing right parenthesis." +msgstr "" + +#: src/matrix-data.c:533 +msgid "Missing VARIABLES subcommand." +msgstr "" + +#: src/matrix-data.c:539 +msgid "" +"CONTENTS subcommand not specified: assuming file contains only CORR matrix." +msgstr "" + +#: src/matrix-data.c:549 +msgid "" +"Missing CELLS subcommand. CELLS is required when ROWTYPE_ is not given in " +"the data and factors are present." +msgstr "" + +#: src/matrix-data.c:557 +msgid "Split file values must be present in the data when ROWTYPE_ is present." +msgstr "" + +#: src/matrix-data.c:613 +msgid "No continuous variables specified." +msgstr "" + +#: src/matrix-data.c:1024 +#, c-format +msgid "End of line expected %s while reading %s." +msgstr "" + +#: src/matrix-data.c:1210 +#, c-format +msgid "expecting value for %s %s" +msgstr "" + +#: src/matrix-data.c:1360 +#, c-format +msgid "Syntax error expecting SPLIT FILE value %s." +msgstr "" + +#: src/matrix-data.c:1369 +#, c-format +msgid "Expecting value %g for %s." +msgstr "" + +#: src/matrix-data.c:1408 src/matrix-data.c:1821 +#, c-format +msgid "Syntax error expecting factor value %s." +msgstr "" + +#: src/matrix-data.c:1417 +#, c-format +msgid "Syntax error expecting value %g for %s %s." +msgstr "" + +#: src/matrix-data.c:1624 +#, c-format +msgid "Syntax error %s expecting SPLIT FILE value." +msgstr "" + +#: src/matrix-data.c:1735 +#, c-format +msgid "" +"Expected %d lines of data for %s content; actually saw %d lines. No data " +"will be output for this content." +msgstr "" + +#: src/matrix-data.c:1766 +#, c-format +msgid "Multiply specified ROWTYPE_ %s." +msgstr "" + +#: src/matrix-data.c:1771 +#, c-format +msgid "Syntax error %s expecting ROWTYPE_ string." +msgstr "" + +#: src/matrix-data.c:1790 +#, c-format +msgid "Syntax error %s." +msgstr "" + +#: src/matrix-data.c:1936 +#, c-format +msgid "Duplicate specification for %s." +msgstr "" + +#: src/matrix-data.c:1948 +#, c-format +msgid "Too many rows of matrix data for %s." +msgstr "" + +#: src/matrix-data.c:1993 +#, c-format +msgid "Syntax error expecting value for %s %s." +msgstr "" + +#: src/pfm-read.c:107 +#, c-format +msgid "portable file %s corrupt at offset %ld: " +msgstr "" + +#: src/pfm-read.c:126 src/pfm-write.c:499 +#, c-format +msgid "%s: Closing portable file: %s." +msgstr "" + +#: src/lexer.c:948 src/pfm-read.c:150 src/repeat.c:227 +msgid "Unexpected end of file." +msgstr "" + +#: src/pfm-read.c:158 +msgid "Bad line end." +msgstr "" + +#: src/pfm-read.c:239 +#, c-format +msgid "Cannot read file %s as portable file: already opened for %s." +msgstr "" + +#: src/pfm-read.c:245 +#, c-format +msgid "%s: Opening portable-file handle %s for reading." +msgstr "" + +#: src/pfm-read.c:253 +#, c-format +msgid "" +"An error occurred while opening \"%s\" for reading as a portable file: %s." +msgstr "" + +#. F +#: src/pfm-read.c:287 +msgid "Data record expected." +msgstr "" + +#: src/pfm-read.c:289 +msgid "Read portable-file dictionary successfully." +msgstr "" + +#. Come here on unsuccessful completion. +#: src/pfm-read.c:298 +msgid "Error reading portable-file dictionary." +msgstr "" + +#. / +#: src/pfm-read.c:396 +msgid "Missing numeric terminator." +msgstr "" + +#: src/pfm-read.c:433 +msgid "Bad integer format." +msgstr "" + +#: src/pfm-read.c:463 +#, c-format +msgid "Bad string length %d." +msgstr "" + +#: src/pfm-read.c:562 +#, c-format +msgid "Bad date string length %d." +msgstr "" + +#. 0 +#. 9 +#: src/pfm-read.c:566 +msgid "Bad character in date." +msgstr "" + +#: src/pfm-read.c:586 +#, c-format +msgid "Bad time string length %d." +msgstr "" + +#. 0 +#. 9 +#: src/pfm-read.c:590 +msgid "Bad character in time." +msgstr "" + +#: src/pfm-read.c:640 +#, c-format +msgid "%s: Bad format specifier byte %d." +msgstr "" + +#: src/pfm-read.c:649 src/sfm-read.c:993 src/sfm-read.c:1003 +#, c-format +msgid "%s: Bad format specifier byte (%d)." +msgstr "" + +#: src/pfm-read.c:651 +#, c-format +msgid "%s variable %s has %s format specifier %s." +msgstr "" + +#: src/pfm-read.c:652 src/print.c:631 src/sfm-read.c:1007 +msgid "String" +msgstr "" + +#: src/pfm-read.c:652 src/print.c:631 src/sfm-read.c:1007 +msgid "Numeric" +msgstr "" + +#. 4 +#: src/pfm-read.c:690 +msgid "Expected variable count record." +msgstr "" + +#: src/pfm-read.c:694 +#, c-format +msgid "Invalid number of variables %d." +msgstr "" + +#: src/pfm-read.c:704 +#, c-format +msgid "Unexpected flag value %d." +msgstr "" + +#. 7 +#: src/pfm-read.c:728 +msgid "Expected variable record." +msgstr "" + +#: src/pfm-read.c:734 +#, c-format +msgid "Invalid variable width %d." +msgstr "" + +#: src/pfm-read.c:752 +#, c-format +msgid "position %d: Variable name has %u characters." +msgstr "" + +#. A +#. Z +#. @ +#: src/pfm-read.c:756 +#, c-format +msgid "position %d: Variable name begins with invalid character." +msgstr "" + +#: src/pfm-read.c:760 +#, c-format +msgid "position %d: Variable name begins with lowercase letter %c." +msgstr "" + +#: src/pfm-read.c:773 +#, c-format +msgid "position %d: Variable name character %d is lowercase letter %c." +msgstr "" + +#: src/pfm-read.c:783 +#, c-format +msgid "position %d: character `\\%03o' is not valid in a variable name." +msgstr "" + +#: src/pfm-read.c:794 +#, c-format +msgid "Duplicate variable name %s." +msgstr "" + +#: src/pfm-read.c:838 +#, c-format +msgid "Bad missing values for %s." +msgstr "" + +#: src/pfm-read.c:860 +#, c-format +msgid "Weighting variable %s not present in dictionary." +msgstr "" + +#: src/pfm-read.c:928 +#, c-format +msgid "Unknown variable %s while parsing value labels." +msgstr "" + +#: src/pfm-read.c:931 +#, c-format +msgid "" +"Cannot assign value labels to %s and %s, which have different variable types " +"or widths." +msgstr "" + +#: src/pfm-read.c:978 +#, c-format +msgid "Duplicate label for value %g for variable %s." +msgstr "" + +#: src/pfm-read.c:981 +#, c-format +msgid "Duplicate label for value `%.*s' for variable %s." +msgstr "" + +#: src/pfm-read.c:1053 +msgid "End of file midway through case." +msgstr "" + +#: src/pfm-read.c:1063 +msgid "reading as a portable file" +msgstr "" + +#: src/pfm-write.c:72 +#, c-format +msgid "Cannot write file %s as portable file: already opened for %s." +msgstr "" + +#: src/pfm-write.c:78 +#, c-format +msgid "%s: Opening portable-file handle %s for writing." +msgstr "" + +#: src/pfm-write.c:88 +#, c-format +msgid "" +"An error occurred while opening \"%s\" for writing as a portable file: %s." +msgstr "" + +#: src/pfm-write.c:124 +msgid "Wrote portable-file header successfully." +msgstr "" + +#: src/pfm-write.c:129 +msgid "Error writing portable-file header." +msgstr "" + +#: src/pfm-write.c:169 +#, c-format +msgid "%s: Writing portable file: %s." +msgstr "" + +#: src/pfm-write.c:508 +msgid "writing as a portable file" +msgstr "" + +#: src/sfm-read.c:188 +msgid "corrupt system file: " +msgstr "" + +#: src/sfm-read.c:204 src/sfm-write.c:744 +#, c-format +msgid "%s: Closing system file: %s." +msgstr "" + +#: src/sfm-read.c:277 +#, c-format +msgid "Cannot read file %s as system file: already opened for %s." +msgstr "" + +#: src/sfm-read.c:282 +#, c-format +msgid "%s: Opening system-file handle %s for reading." +msgstr "" + +#: src/sfm-read.c:290 +#, c-format +msgid "" +"An error occurred while opening \"%s\" for reading as a system file: %s." +msgstr "" + +#: src/sfm-read.c:324 +#, c-format +msgid "" +"%s: Weighting variable may not be a continuation of a long string variable." +msgstr "" + +#: src/sfm-read.c:327 +#, c-format +msgid "%s: Weighting variable may not be a string variable." +msgstr "" + +#: src/sfm-read.c:352 +#, c-format +msgid "" +"%s: Orphaned variable index record (type 4). Type 4 records must always " +"immediately follow type 3 records." +msgstr "" + +#: src/sfm-read.c:407 +#, c-format +msgid "%s: Unrecognized record type 7, subtype %d encountered in system file." +msgstr "" + +#: src/sfm-read.c:431 +#, c-format +msgid "%s: Unrecognized record type %d." +msgstr "" + +#. Come here on successful completion. +#: src/sfm-read.c:437 +msgid "Read system-file dictionary successfully." +msgstr "" + +#. Come here on unsuccessful completion. +#: src/sfm-read.c:447 +msgid "Error reading system-file header." +msgstr "" + +#: src/sfm-read.c:471 +#, c-format +msgid "" +"%s: Bad size (%d) or count (%d) field on record type 7, subtype 3.\tExpected " +"size %d, count 8." +msgstr "" + +#: src/sfm-read.c:485 +#, c-format +msgid "" +"%s: Floating-point representation in system file is not IEEE-754. PSPP " +"cannot convert between floating-point formats." +msgstr "" + +#: src/sfm-read.c:506 +#, c-format +msgid "" +"%s: File-indicated endianness (%s) does not match endianness intuited from " +"file header (%s)." +msgstr "" + +#: src/sfm-read.c:508 src/sfm-read.c:509 +msgid "big-endian" +msgstr "" + +#: src/sfm-read.c:508 src/sfm-read.c:509 +msgid "little-endian" +msgstr "" + +#: src/sfm-read.c:510 +msgid "unknown" +msgstr "" + +#: src/sfm-read.c:514 +#, c-format +msgid "%s: File-indicated character representation code (%s) is not ASCII." +msgstr "" + +#: src/sfm-read.c:516 +msgid "DEC Kanji" +msgstr "" + +#: src/data-out.c:145 src/sfm-read.c:516 src/sysfile-info.c:114 +msgid "Unknown" +msgstr "" + +#: src/sfm-read.c:535 +#, c-format +msgid "" +"%s: Bad size (%d) or count (%d) field on record type 7, subtype 4.\tExpected " +"size %d, count 8." +msgstr "" + +#: src/sfm-read.c:550 +#, c-format +msgid "" +"%s: File-indicated value is different from internal value for at least one " +"of the three system values. SYSMIS: indicated %g, expected %g; HIGHEST: %g, " +"%g; LOWEST: %g, %g." +msgstr "" + +#: src/sfm-read.c:594 +#, c-format +msgid "" +"%s: Bad magic. Proper system files begin with the four characters `$FL2'. " +"This file will not be read." +msgstr "" + +#: src/sfm-read.c:637 +#, c-format +msgid "" +"%s: File layout code has unexpected value %d. Value should be 2, in " +"big-endian or little-endian format." +msgstr "" + +#: src/sfm-read.c:653 +#, c-format +msgid "%s: Number of elements per case (%d) is not between 1 and %d." +msgstr "" + +#: src/sfm-read.c:660 +#, c-format +msgid "" +"%s: Index of weighting variable (%d) is not between 0 and number of elements " +"per case (%d)." +msgstr "" + +#: src/sfm-read.c:666 +#, c-format +msgid "%s: Number of cases in file (%ld) is not between -1 and %d." +msgstr "" + +#: src/sfm-read.c:671 +#, c-format +msgid "%s: Compression bias (%g) is not the usual value of 100." +msgstr "" + +#: src/sfm-read.c:767 +#, c-format +msgid "%s: position %d: Bad record type (%d); the expected value was 2." +msgstr "" + +#: src/sfm-read.c:776 +#, c-format +msgid "" +"%s: position %d: String variable does not have proper number of continuation " +"records." +msgstr "" + +#: src/sfm-read.c:784 +#, c-format +msgid "%s: position %d: Superfluous long string continuation record." +msgstr "" + +#: src/sfm-read.c:789 +#, c-format +msgid "%s: position %d: Bad variable type code %d." +msgstr "" + +#: src/sfm-read.c:792 +#, c-format +msgid "%s: position %d: Variable label indicator field is not 0 or 1." +msgstr "" + +#: src/sfm-read.c:796 +#, c-format +msgid "" +"%s: position %d: Missing value indicator field is not -3, -2, 0, 1, 2, or 3." +msgstr "" + +#: src/sfm-read.c:809 +#, c-format +msgid "%s: position %d: Variable name begins with invalid character." +msgstr "" + +#: src/sfm-read.c:812 +#, c-format +msgid "%s: position %d: Variable name begins with lowercase letter %c." +msgstr "" + +#: src/sfm-read.c:815 +#, c-format +msgid "" +"%s: position %d: Variable name begins with octothorpe (`#'). Scratch " +"variables should not appear in system files." +msgstr "" + +#: src/sfm-read.c:829 +#, c-format +msgid "%s: position %d: Variable name character %d is lowercase letter %c." +msgstr "" + +#: src/sfm-read.c:837 +#, c-format +msgid "" +"%s: position %d: character `\\%03o' (%c) is not valid in a variable name." +msgstr "" + +#: src/sfm-read.c:877 +#, c-format +msgid "%s: Variable %s indicates variable label of invalid length %d." +msgstr "" + +#: src/sfm-read.c:893 +#, c-format +msgid "%s: Long string variable %s may not have missing values." +msgstr "" + +#: src/sfm-read.c:917 +#, c-format +msgid "" +"%s: String variable %s may not have missing values specified as a range." +msgstr "" + +#: src/sfm-read.c:954 +#, c-format +msgid "%s: Long string continuation records omitted at end of dictionary." +msgstr "" + +#: src/sfm-read.c:957 +#, c-format +msgid "" +"%s: System file header indicates %d variable positions but %d were read from " +"file." +msgstr "" + +#: src/sfm-read.c:966 +#, c-format +msgid "%s: Duplicate variable name `%s' within system file." +msgstr "" + +#: src/sfm-read.c:1006 +#, c-format +msgid "%s: %s variable %s has %s format specifier %s." +msgstr "" + +#: src/sfm-read.c:1085 +#, c-format +msgid "" +"%s: Variable index record (type 4) does not immediately follow value label " +"record (type 3) as it ought." +msgstr "" + +#: src/sfm-read.c:1095 +#, c-format +msgid "" +"%s: Number of variables associated with a value label (%d) is not between 1 " +"and the number of variables (%d)." +msgstr "" + +#: src/sfm-read.c:1113 +#, c-format +msgid "" +"%s: Variable index associated with value label (%d) is not between 1 and the " +"number of values (%d)." +msgstr "" + +#: src/sfm-read.c:1120 +#, c-format +msgid "" +"%s: Variable index associated with value label (%d) refers to a continuation " +"of a string variable, not to an actual variable." +msgstr "" + +#: src/sfm-read.c:1124 +#, c-format +msgid "%s: Value labels are not allowed on long string variables (%s)." +msgstr "" + +#: src/sfm-read.c:1134 +#, c-format +msgid "" +"%s: Variables associated with value label are not all of identical type. " +"Variable %s has %s type, but variable %s has %s type." +msgstr "" + +#: src/sfm-read.c:1177 +#, c-format +msgid "%s: File contains duplicate label for value %g for variable %s." +msgstr "" + +#: src/sfm-read.c:1180 +#, c-format +msgid "%s: File contains duplicate label for value `%.*s' for variable %s." +msgstr "" + +#: src/sfm-read.c:1220 src/sfm-read.c:1498 +#, c-format +msgid "%s: Reading system file: %s." +msgstr "" + +#: src/sfm-read.c:1222 src/sfm-read.c:1403 src/sfm-read.c:1444 +#, c-format +msgid "%s: Unexpected end of file." +msgstr "" + +#: src/sfm-read.c:1239 +#, c-format +msgid "%s: System file contains multiple type 6 (document) records." +msgstr "" + +#: src/sfm-read.c:1245 +#, c-format +msgid "%s: Number of document lines (%ld) must be greater than 0." +msgstr "" + +#: src/sfm-read.c:1266 +msgid "dictionary:\n" +msgstr "" + +#. debug_printf (("(indices:%d,%d)", v->index, v->foo)); +#: src/sfm-read.c:1275 +msgid "num" +msgstr "" + +#: src/sfm-read.c:1276 +msgid "str" +msgstr "" + +#. debug_printf (("(get.fv:%d,%d)", v->get.fv, v->get.nv)); +#: src/sfm-read.c:1280 +msgid "left" +msgstr "" + +#: src/sfm-read.c:1280 +msgid "right" +msgstr "" + +#: src/sfm-read.c:1286 +msgid "none" +msgstr "" + +#: src/sfm-read.c:1290 +msgid "one" +msgstr "" + +#: src/sfm-read.c:1294 +msgid "two" +msgstr "" + +#: src/sfm-read.c:1298 +msgid "three" +msgstr "" + +#: src/descript.q:166 src/sfm-read.c:1302 +msgid "range" +msgstr "" + +#: src/sfm-read.c:1306 +msgid "low" +msgstr "" + +#: src/sfm-read.c:1310 +msgid "high" +msgstr "" + +#: src/sfm-read.c:1314 +msgid "range+1" +msgstr "" + +#: src/sfm-read.c:1318 +msgid "low+1" +msgstr "" + +#: src/sfm-read.c:1322 +msgid "high+1" +msgstr "" + +#: src/sfm-read.c:1356 +#, c-format +msgid "%s: Error reading file: %s." +msgstr "" + +#: src/sfm-read.c:1394 +#, c-format +msgid "%s: Compressed data is corrupted. Data ends partway through a case." +msgstr "" + +#: src/sfm-read.c:1500 +#, c-format +msgid "%s: Partial record at end of system file." +msgstr "" + +#: src/sfm-read.c:1538 +msgid "reading as a system file" +msgstr "" + +#: src/sfm-write.c:114 +#, c-format +msgid "Cannot write file %s as system file: already opened for %s." +msgstr "" + +#: src/sfm-write.c:119 +#, c-format +msgid "%s: Opening system-file handle %s for writing." +msgstr "" + +#: src/sfm-write.c:129 +#, c-format +msgid "" +"An error occurred while opening \"%s\" for writing as a system file: %s." +msgstr "" + +#: src/sfm-write.c:182 +msgid "Wrote system-file header successfully." +msgstr "" + +#: src/sfm-write.c:187 +msgid "Error writing system-file header." +msgstr "" + +#: src/sfm-write.c:608 +#, c-format +msgid "%s: Writing system file: %s." +msgstr "" + +#: src/sfm-write.c:754 +msgid "writing as a system file" +msgstr "" + +#: src/sysfile-info.c:96 +msgid "File:" +msgstr "" + +#: src/sysfile-info.c:98 +msgid "Label:" +msgstr "" + +#: src/sysfile-info.c:100 +msgid "No label." +msgstr "" + +#: src/sysfile-info.c:101 +msgid "Created:" +msgstr "" + +#: src/sysfile-info.c:104 +msgid "Endian:" +msgstr "" + +#: src/sysfile-info.c:106 +msgid "Big." +msgstr "" + +#: src/sysfile-info.c:107 +msgid "Little." +msgstr "" + +#: src/sysfile-info.c:108 +msgid "" +msgstr "" + +#: src/sysfile-info.c:109 +msgid "Variables:" +msgstr "" + +#: src/sysfile-info.c:112 +msgid "Cases:" +msgstr "" + +#: src/sysfile-info.c:115 +msgid "Type:" +msgstr "" + +#: src/sysfile-info.c:116 +msgid "System File." +msgstr "" + +#: src/sysfile-info.c:117 +msgid "Weight:" +msgstr "" + +#: src/sysfile-info.c:119 +msgid "Not weighted." +msgstr "" + +#: src/sysfile-info.c:120 +msgid "Mode:" +msgstr "" + +#: src/sysfile-info.c:122 +#, c-format +msgid "Compression %s." +msgstr "" + +#: src/sysfile-info.c:122 +msgid "on" +msgstr "" + +#: src/sysfile-info.c:122 +msgid "off" +msgstr "" + +#: src/sysfile-info.c:131 src/sysfile-info.c:376 +msgid "Description" +msgstr "" + +#: src/sysfile-info.c:132 src/sysfile-info.c:373 +msgid "Position" +msgstr "" + +#: src/sysfile-info.c:192 +msgid "The active file does not have a file label." +msgstr "" + +#: src/sysfile-info.c:195 +msgid "File label:" +msgstr "" + +#: src/sysfile-info.c:257 +msgid "No variables to display." +msgstr "" + +#: src/sysfile-info.c:282 +msgid "Macros not supported." +msgstr "" + +#: src/sysfile-info.c:290 +msgid "The active file dictionary does not contain any documents." +msgstr "" + +#: src/sysfile-info.c:298 +msgid "Documents in the active file:" +msgstr "" + +#: src/sysfile-info.c:378 src/sysfile-info.c:538 src/vfm.c:1135 +msgid "Label" +msgstr "" + +#: src/sysfile-info.c:450 +#, c-format +msgid "Format: %s" +msgstr "" + +#: src/sysfile-info.c:457 +#, c-format +msgid "Print Format: %s" +msgstr "" + +#: src/sysfile-info.c:460 +#, c-format +msgid "Write Format: %s" +msgstr "" + +#: src/sysfile-info.c:468 +msgid "Missing Values: " +msgstr "" + +#: src/crosstabs.q:1233 src/crosstabs.q:1260 src/crosstabs.q:1280 +#: src/crosstabs.q:1302 src/frequencies.q:895 src/frequencies.q:1012 +#: src/sysfile-info.c:537 src/vfm.c:1134 +msgid "Value" +msgstr "" + +#: src/sysfile-info.c:598 +msgid "No vectors defined." +msgstr "" + +#: src/sysfile-info.c:613 +msgid "Vector" +msgstr "" + +#: src/command.c:161 +#, c-format +msgid "%s not allowed inside FILE TYPE/END FILE TYPE." +msgstr "" + +#: src/command.c:165 +#, c-format +msgid "%s not allowed inside FILE TYPE GROUPED/END FILE TYPE." +msgstr "" + +#: src/command.c:168 +msgid "RECORD TYPE must be the first command inside a FILE TYPE structure." +msgstr "" + +#: src/command.c:213 +msgid "This line does not begin with a valid command name." +msgstr "" + +#: src/command.c:223 +#, c-format +msgid "%s is not yet implemented." +msgstr "" + +#: src/command.c:241 +#, c-format +msgid "" +"%s is not allowed (1) before a command to specify the input program, such as " +"DATA LIST, (2) between FILE TYPE and END FILE TYPE, (3) between INPUT " +"PROGRAM and END INPUT PROGRAM." +msgstr "" + +#: src/command.c:245 +#, c-format +msgid "%s is not allowed within an input program." +msgstr "" + +#: src/command.c:246 src/command.c:247 +#, c-format +msgid "%s is only allowed within an input program." +msgstr "" + +#: src/command.c:256 +#, c-format +msgid "%s command beginning\n" +msgstr "" + +#: src/command.c:292 +#, c-format +msgid "" +"%s command completed\n" +"\n" +msgstr "" + +#: src/command.c:307 +msgid "The identifier(s) specified do not form a valid command name:" +msgstr "" + +#: src/command.c:310 +msgid "The identifier(s) specified do not form a complete command name:" +msgstr "" + +#: src/command.c:434 +msgid "" +"This command is not accepted in a syntax file. Instead, use FINISH to " +"terminate a syntax file." +msgstr "" + +#: src/command.c:452 +msgid "" +"This command is not executed in interactive mode. Instead, PSPP drops down " +"to the command prompt. Use EXIT if you really want to quit." +msgstr "" + +#: src/command.c:543 +msgid "The sentinel may not be the empty string." +msgstr "" + +#: src/command.c:601 src/command.c:732 +msgid "This command not allowed when the SAFER option is set." +msgstr "" + +#: src/command.c:614 +#, c-format +msgid "Error removing `%s': %s." +msgstr "" + +#: src/command.c:664 +#, c-format +msgid "Couldn't fork: %s." +msgstr "" + +#: src/command.c:705 +#, c-format +msgid "Error executing command: %s." +msgstr "" + +#: src/command.c:755 +msgid "No operating system support for this command." +msgstr "" + +#: src/command.c:784 +msgid "This command is not valid in a syntax file." +msgstr "" + +#: src/getline.c:160 +#, c-format +msgid "Can't find `%s' in include file search path." +msgstr "" + +#: src/getline.c:315 +#, c-format +msgid "%s: Opening as syntax file." +msgstr "" + +#: src/getline.c:320 +#, c-format +msgid "Opening `%s': %s." +msgstr "" + +#: src/getline.c:329 src/html.c:334 src/postscript.c:1480 +#, c-format +msgid "Reading `%s': %s." +msgstr "" + +#: src/getline.c:387 +#, c-format +msgid "Closing `%s': %s." +msgstr "" + +#: src/lexer.c:216 +#, c-format +msgid "%s does not form a valid number." +msgstr "" + +#: src/lexer.c:334 +#, c-format +msgid "Bad character in input: `%c'." +msgstr "" + +#: src/lexer.c:336 +#, c-format +msgid "Bad character in input: `\\%o'." +msgstr "" + +#: src/lexer.c:357 +msgid "Syntax error at end of file." +msgstr "" + +#: src/lexer.c:367 +#, c-format +msgid "Syntax error %s at `%s'." +msgstr "" + +#: src/lexer.c:370 +#, c-format +msgid "Syntax error at `%s'." +msgstr "" + +#: src/lexer.c:473 +#, c-format +msgid "expecting `%s'" +msgstr "" + +#: src/lexer.c:490 +#, c-format +msgid "expecting %s" +msgstr "" + +#: src/lexer.c:504 +msgid "expecting string" +msgstr "" + +#: src/lexer.c:518 +msgid "expecting integer" +msgstr "" + +#: src/lexer.c:532 +msgid "expecting number" +msgstr "" + +#: src/lexer.c:546 +msgid "expecting identifier" +msgstr "" + +#: src/lexer.c:682 +msgid "The rest of this command has been discarded." +msgstr "" + +#: src/lexer.c:822 src/print.c:1193 +msgid "" +msgstr "" + +#: src/lexer.c:974 +msgid "binary" +msgstr "" + +#: src/lexer.c:974 +msgid "octal" +msgstr "" + +#: src/lexer.c:974 +msgid "hex" +msgstr "" + +#: src/lexer.c:988 +#, c-format +msgid "String of %s digits has %d characters, which is not a multiple of %d." +msgstr "" + +#: src/lexer.c:1017 +#, c-format +msgid "`%c' is not a valid %s digit." +msgstr "" + +#: src/lexer.c:1048 +msgid "Unterminated string constant." +msgstr "" + +#: src/lexer.c:1120 +#, c-format +msgid "String exceeds 255 characters in length (%d characters)." +msgstr "" + +#: src/lexer.c:1135 +msgid "" +"Sorry, literal strings may not contain null characters. Replacing with " +"spaces." +msgstr "" + +#: src/cmdline.c:111 +msgid "-f not yet implemented\n" +msgstr "" + +#: src/cmdline.c:129 +msgid "-n not yet implemented\n" +msgstr "" + +#: src/cmdline.c:140 +msgid "-p not yet implemented\n" +msgstr "" + +#: src/cmdline.c:153 +msgid "" +"\n" +"Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.\n" +"This is free software; see the source for copying conditions. There is NO\n" +"WARRANTY; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n" +"\n" +"Written by Ben Pfaff ." +msgstr "" + +#: src/cmdline.c:213 +#, c-format +msgid "" +"PSPP, a program for statistical analysis of sample data.\n" +"\n" +"Usage: %s [OPTION]... FILE...\n" +"\n" +"If a long option shows an argument as mandatory, then it is mandatory\n" +"for the equivalent short option also. Similarly for optional arguments.\n" +"\n" +"Configuration:\n" +" -B, --config-dir=DIR set configuration directory to DIR\n" +" -o, --device=DEVICE select output driver DEVICE and disable " +"defaults\n" +" -d, --define=VAR[=VALUE] set environment variable VAR to VALUE, or empty\n" +" -u, --undef=VAR undefine environment variable VAR\n" +"\n" +"Input and output:\n" +" -f, --out-file=FILE send output to FILE (overwritten)\n" +" -p, --pipe read script from stdin, send output to stdout\n" +" -I-, --no-include clear include path\n" +" -I, --include=DIR append DIR to include path\n" +" -c, --command=COMMAND execute COMMAND before .pspp/rc at startup\n" +"\n" +"Language modifiers:\n" +" -i, --interactive interpret scripts in interactive mode\n" +" -n, --edit just check syntax; don't actually run the code\n" +" -r, --no-statrc disable execution of .pspp/rc at startup\n" +" -s, --safer don't allow some unsafe operations\n" +"\n" +"Informative output:\n" +" -h, --help print this help, then exit\n" +" -l, --list print a list of known driver classes, then exit\n" +" -V, --version show PSPP version, then exit\n" +" -v, --verbose increments verbosity level\n" +"\n" +"Non-option arguments:\n" +" FILE1 FILE2 run FILE1, clear the dictionary, run FILE2\n" +" FILE1 + FILE2 run FILE1 then FILE2 without clearing " +"dictionary\n" +" KEY=VALUE overrides macros in output initialization file\n" +"\n" +msgstr "" + +#: src/cmdline.c:246 +msgid "" +"\n" +"Report bugs to .\n" +msgstr "" + +#: src/error.c:130 +msgid "Terminating NOW due to a fatal error!" +msgstr "" + +#: src/error.c:207 +msgid "Terminating execution of syntax file due to error." +msgstr "" + +#: src/error.c:209 +#, c-format +msgid "Errors (%d) exceeds limit (%d)." +msgstr "" + +#: src/error.c:212 +#, c-format +msgid "Warnings (%d) exceed limit (%d)." +msgstr "" + +#: src/error.c:279 +msgid "fatal" +msgstr "" + +#. SE +#: src/error.c:282 src/error.c:289 src/error.c:292 +msgid "warning" +msgstr "" + +#. SW +#: src/error.c:283 src/error.c:293 +msgid "note" +msgstr "" + +#. SM +#: src/error.c:285 src/error.c:286 +msgid "installation error" +msgstr "" + +#: src/error.c:509 +msgid "" +"\n" +"\t*********************\n" +"\t* INDUCING SEGFAULT *\n" +"\t*********************\n" +msgstr "" + +#: src/glob.c:183 +msgid "" +"Your machine does not appear to be either big- or little-endian. At the " +"moment, PSPP only supports machines of these standard endiannesses. If you " +"want to hack in others, contact the author." +msgstr "" + +#: src/glob.c:267 +msgid "data> " +msgstr "" + +#: src/glob.c:328 +msgid "Specify a terminal type with `setenv TERM '." +msgstr "" + +#: src/glob.c:339 +msgid "Could not access the termcap data base." +msgstr "" + +#: src/glob.c:341 +#, c-format +msgid "Terminal type `%s' is not defined." +msgstr "" + +#: src/glob.c:342 +msgid "Assuming screen of size 79x25." +msgstr "" + +#: src/glob.c:377 +msgid "Jan" +msgstr "" + +#: src/glob.c:377 +msgid "Feb" +msgstr "" + +#: src/glob.c:377 +msgid "Mar" +msgstr "" + +#: src/glob.c:377 +msgid "Apr" +msgstr "" + +#: src/glob.c:377 +msgid "May" +msgstr "" + +#: src/glob.c:377 +msgid "Jun" +msgstr "" + +#: src/glob.c:378 +msgid "Jul" +msgstr "" + +#: src/glob.c:378 +msgid "Aug" +msgstr "" + +#: src/glob.c:378 +msgid "Sep" +msgstr "" + +#: src/glob.c:378 +msgid "Oct" +msgstr "" + +#: src/glob.c:378 +msgid "Nov" +msgstr "" + +#: src/glob.c:378 +msgid "Dec" +msgstr "" + +#: src/main.c:65 +msgid "Error initializing output drivers." +msgstr "" + +#: src/main.c:123 +msgid "This command not executed." +msgstr "" + +#: src/main.c:127 +msgid "" +"Skipping the rest of this command. Part of this command may have been " +"executed." +msgstr "" + +#: src/main.c:132 +msgid "" +"Skipping the rest of this command. This command was fully executed up to " +"this point." +msgstr "" + +#: src/main.c:137 +msgid "" +"Trailing garbage was encountered following this command. The command was " +"fully executed to this point." +msgstr "" + +#: src/ascii.c:216 +#, c-format +msgid "ASCII driver initializing as `%s'..." +msgstr "" + +#: src/ascii.c:273 +#, c-format +msgid "" +"ascii driver: Area of page excluding margins and headers must be at least 59 " +"characters wide by 15 lines long. Page as configured is only %d characters " +"by %d lines." +msgstr "" + +#: src/ascii.c:378 src/html.c:102 src/postscript.c:474 +#, c-format +msgid "%s: Initialization complete." +msgstr "" + +#: src/ascii.c:389 src/html.c:114 src/postscript.c:487 +#, c-format +msgid "%s: Beginning closing..." +msgstr "" + +#: src/ascii.c:399 src/html.c:119 src/postscript.c:506 +#, c-format +msgid "%s: Finished closing." +msgstr "" + +#: src/ascii.c:460 +#, c-format +msgid "" +"Bad index value for `box' key: syntax is box[INDEX], 0 <= INDEX < %d " +"decimal, with INDEX expressed in base 4." +msgstr "" + +#: src/ascii.c:466 +#, c-format +msgid "Duplicate value for key `%s'." +msgstr "" + +#: src/ascii.c:476 +#, c-format +msgid "Unknown configuration parameter `%s' for ascii device driver." +msgstr "" + +#: src/ascii.c:489 +#, c-format +msgid "" +"Unknown character set `%s'. Valid character sets are `ascii' and `latin1'." +msgstr "" + +#: src/ascii.c:498 +#, c-format +msgid "" +"Unknown overstrike style `%s'. Valid overstrike styles are `single' and " +"`line'." +msgstr "" + +#: src/ascii.c:507 +#, c-format +msgid "" +"Unknown carriage return style `%s'. Valid carriage return styles are `cr' " +"and `bs'." +msgstr "" + +#: src/ascii.c:519 src/postscript.c:695 +#, c-format +msgid "Positive integer required as value for `%s'." +msgstr "" + +#: src/ascii.c:550 +#, c-format +msgid "Zero or positive integer required as value for `%s'." +msgstr "" + +#: src/ascii.c:620 src/postscript.c:654 +#, c-format +msgid "Boolean value expected for %s." +msgstr "" + +#: src/ascii.c:649 src/ascii.c:664 src/ascii.c:681 +#, c-format +msgid "ASCII output driver: %s: %s" +msgstr "" + +#: src/ascii.c:750 +#, c-format +msgid "ascii_line_horz: bad hline (%d,%d),%d out of (%d,%d)\n" +msgstr "" + +#: src/ascii.c:784 +#, c-format +msgid "ascii_line_vert: bad vline %d,(%d,%d) out of (%d,%d)\n" +msgstr "" + +#: src/ascii.c:814 +#, c-format +msgid "ascii_line_intersection: bad intsct (%d,%d) out of (%d,%d)\n" +msgstr "" + +#: src/ascii.c:976 +#, c-format +msgid "%s: horiz=%d, vert=%d\n" +msgstr "" + +#: src/ascii.c:1148 +#, c-format +msgid "Writing `%s': %s" +msgstr "" + +#: src/ascii.c:1542 src/postscript.c:2116 +#, c-format +msgid "%s - Page %d" +msgstr "" + +#: src/data-out.c:253 +msgid "" +"The N output format cannot be used to output a negative number or the " +"system-missing value." +msgstr "" + +#: src/data-out.c:363 +msgid "" +"Quality of zoned decimal (Z) output format code is suspect. Check your " +"results, report bugs to author." +msgstr "" + +#: src/data-out.c:370 +msgid "The system-missing value cannot be output as a zoned decimal number." +msgstr "" + +#: src/data-out.c:383 +#, c-format +msgid "Number %g too big to fit in field with format Z%d.%d." +msgstr "" + +#: src/data-out.c:777 +#, c-format +msgid "Time value %g too large in magnitude to convert to alphanumeric time." +msgstr "" + +#: src/data-out.c:830 +#, c-format +msgid "Weekday index %d does not lie between 1 and 7." +msgstr "" + +#: src/data-out.c:851 +#, c-format +msgid "Month index %d does not lie between 1 and 12." +msgstr "" + +#: src/data-out.c:963 +#, c-format +msgid "" +"Year %d cannot be represented in four digits for output formatting purposes." +msgstr "" + +#: src/groff-font.c:107 +#, c-format +msgid "%s: Opening Groff font file..." +msgstr "" + +#: src/groff-font.c:162 +msgid "Missing font name." +msgstr "" + +#: src/groff-font.c:172 +msgid "Missing encoding filename." +msgstr "" + +#: src/groff-font.c:185 +msgid "Bad spacewidth value." +msgstr "" + +#: src/groff-font.c:197 +msgid "Bad slant value." +msgstr "" + +#: src/groff-font.c:222 +#, c-format +msgid "Unknown ligature `%s'." +msgstr "" + +#: src/groff-font.c:257 +msgid "Unexpected end of line reading character set." +msgstr "" + +#: src/groff-font.c:265 +msgid "Can't use ditto mark for first character." +msgstr "" + +#: src/groff-font.c:270 +msgid "Can't ditto into an unnamed character." +msgstr "" + +#: src/groff-font.c:287 +#, c-format +msgid "Missing metrics for character `%s'." +msgstr "" + +#: src/groff-font.c:296 +#, c-format +msgid "Missing type for character `%s'." +msgstr "" + +#: src/groff-font.c:305 +#, c-format +msgid "Missing code for character `%s'." +msgstr "" + +#: src/groff-font.c:324 +msgid "Malformed kernpair." +msgstr "" + +#: src/groff-font.c:331 +msgid "Unexpected end of line reading kernpairs." +msgstr "" + +#: src/groff-font.c:337 +msgid "Bad kern value." +msgstr "" + +#: src/groff-font.c:369 +#, c-format +msgid "Font read successfully with internal name %s." +msgstr "" + +#: src/groff-font.c:389 +msgid "Error reading font." +msgstr "" + +#: src/groff-font.c:400 +msgid "installation error: Groff font error: " +msgstr "" + +#: src/groff-font.c:425 +#, c-format +msgid "Bad character \\%3o." +msgstr "" + +#: src/groff-font.c:665 +#, c-format +msgid "Groff font error: Cannot find \"%s\"." +msgstr "" + +#: src/groff-font.c:730 +#, c-format +msgid "%s: Opening Groff description file..." +msgstr "" + +#: src/groff-font.c:746 +msgid "Multiple `sizes' declarations." +msgstr "" + +#: src/groff-font.c:763 +msgid "Unexpected end of file. Missing 0 terminator to `sizes' command?" +msgstr "" + +#: src/groff-font.c:775 src/groff-font.c:782 src/groff-font.c:795 +msgid "Bad argument to `sizes'." +msgstr "" + +#: src/groff-font.c:787 +msgid "Bad range in argument to `sizes'." +msgstr "" + +#: src/groff-font.c:816 +msgid "Family name expected." +msgstr "" + +#: src/groff-font.c:821 +msgid "This command already specified." +msgstr "" + +#: src/groff-font.c:841 +#, c-format +msgid "%s: Device characteristic already defined." +msgstr "" + +#: src/groff-font.c:847 +#, c-format +msgid "%s: Invalid numeric format." +msgstr "" + +#: src/groff-font.c:877 +msgid "Missing `res', `unitwidth', and/or `sizes' line(s)." +msgstr "" + +#: src/groff-font.c:903 +msgid "Description file read successfully." +msgstr "" + +#: src/groff-font.c:935 +msgid "Error reading description file." +msgstr "" + +#: src/groff-font.c:991 +msgid "<>" +msgstr "" + +#: src/html.c:66 +#, c-format +msgid "HTML driver initializing as `%s'..." +msgstr "" + +#: src/html.c:154 +#, c-format +msgid "Unknown configuration parameter `%s' for HTML device driver." +msgstr "" + +#: src/html.c:240 +msgid "" +"Cannot find HTML prologue. The use of `-vv' on the command line is " +"suggested as a debugging aid." +msgstr "" + +#: src/html.c:245 +#, c-format +msgid "%s: %s: Opening HTML prologue..." +msgstr "" + +#: src/html.c:272 src/html.c:283 src/postscript.c:1372 src/postscript.c:1383 +msgid "nobody" +msgstr "" + +#: src/html.c:279 src/html.c:284 src/postscript.c:1379 src/postscript.c:1384 +msgid "nowhere" +msgstr "" + +#: src/html.c:343 +#, c-format +msgid "%s: HTML prologue read successfully." +msgstr "" + +#: src/html.c:347 +#, c-format +msgid "%s: Error reading HTML prologue." +msgstr "" + +#: src/html.c:375 +#, c-format +msgid "HTML output driver: %s: %s" +msgstr "" + +#: src/html.c:406 src/list.q:277 +#, c-format +msgid "Cannot open first page on HTML device %s." +msgstr "" + +#: src/output.c:162 +#, c-format +msgid "Unknown output driver `%s'." +msgstr "" + +#: src/output.c:164 +#, c-format +msgid "Output driver `%s' referenced but never defined." +msgstr "" + +#: src/output.c:292 +msgid "Cannot find output initialization file. Use `-vv' to view search path." +msgstr "" + +#: src/output.c:297 +#, c-format +msgid "%s: Opening device description file..." +msgstr "" + +#: src/output.c:301 src/output.c:1161 src/postscript.c:1114 +#, c-format +msgid "Opening %s: %s." +msgstr "" + +#: src/output.c:313 src/output.c:1173 src/postscript.c:1131 +#, c-format +msgid "Reading %s: %s." +msgstr "" + +#: src/output.c:335 src/output.c:487 +msgid "Syntax error." +msgstr "" + +#: src/output.c:345 src/postscript.c:1142 +#, c-format +msgid "Closing %s: %s." +msgstr "" + +#: src/output.c:350 +msgid "No output drivers are active." +msgstr "" + +#: src/output.c:353 +msgid "Device definition file read successfully." +msgstr "" + +#: src/output.c:355 +msgid "Error reading device definition file." +msgstr "" + +#: src/output.c:459 +msgid "" +"Driver classes:\n" +"\t" +msgstr "" + +#: src/output.c:588 +msgid "Syntax error in string constant." +msgstr "" + +#: src/output.c:619 +msgid "Syntax error in options." +msgstr "" + +#: src/output.c:629 +msgid "Syntax error in options (`=' expected)." +msgstr "" + +#: src/output.c:636 +msgid "Syntax error in options (value expected after `=')." +msgstr "" + +#: src/output.c:708 +msgid "Driver name expected." +msgstr "" + +#: src/output.c:729 +msgid "Class name expected." +msgstr "" + +#: src/output.c:738 +#, c-format +msgid "Unknown output driver class `%s'." +msgstr "" + +#: src/output.c:745 +#, c-format +msgid "Can't initialize output driver class `%s'." +msgstr "" + +#: src/output.c:752 +#, c-format +msgid "Can't initialize output driver `%s' of class `%s'." +msgstr "" + +#: src/output.c:774 +#, c-format +msgid "Unknown device type `%s'." +msgstr "" + +#: src/output.c:786 +#, c-format +msgid "Can't complete initialization of output driver `%s' of class `%s'." +msgstr "" + +#: src/output.c:833 +#, c-format +msgid "Can't deinitialize output driver class `%s'." +msgstr "" + +#: src/output.c:906 +#, c-format +msgid "Trying to find keyword `%s'...\n" +msgstr "" + +#: src/output.c:1023 +#, c-format +msgid "Unit \"%s\" is unknown in dimension \"%s\"." +msgstr "" + +#: src/output.c:1038 +#, c-format +msgid "Bad dimension \"%s\"." +msgstr "" + +#: src/output.c:1064 +#, c-format +msgid "`x' expected in paper size `%s'." +msgstr "" + +#: src/output.c:1074 +#, c-format +msgid "Trailing garbage `%s' on paper size `%s'." +msgstr "" + +#: src/output.c:1123 +msgid "Paper size name must not be empty." +msgstr "" + +#: src/output.c:1153 +msgid "Cannot find `papersize' configuration file." +msgstr "" + +#: src/output.c:1157 +#, c-format +msgid "%s: Opening paper size definition file..." +msgstr "" + +#: src/output.c:1200 +msgid "Syntax error in paper size definition." +msgstr "" + +#: src/output.c:1229 +msgid "Paper size definition file read successfully." +msgstr "" + +#: src/output.c:1231 +msgid "Error reading paper size definition file." +msgstr "" + +#: src/output.c:1300 +#, c-format +msgid "Error closing page on %s device of %s class." +msgstr "" + +#: src/output.c:1304 +#, c-format +msgid "Error opening page on %s device of %s class." +msgstr "" + +#: src/postscript.c:339 +#, c-format +msgid "PostScript driver initializing as `%s'..." +msgstr "" + +#: src/postscript.c:463 +#, c-format +msgid "" +"PostScript driver: The defined page is not long enough to hold margins and " +"headers, plus least 15 lines of the default fonts. In fact, there's only " +"room for %d lines of each font at the default size of %d.%03d points." +msgstr "" + +#: src/postscript.c:592 +#, c-format +msgid "Unknown configuration parameter `%s' for PostScript device driver." +msgstr "" + +#: src/postscript.c:608 +#, c-format +msgid "" +"Unknown orientation `%s'. Valid orientations are `portrait' and `landscape'." +msgstr "" + +#: src/postscript.c:620 +msgid "" +"Unknown value for `data'. Valid values are `clean7bit', `clean8bit', and " +"`binary'." +msgstr "" + +#: src/postscript.c:629 +msgid "Unknown value for `line-ends'. Valid values are `lf' and `crlf'." +msgstr "" + +#: src/postscript.c:638 +msgid "Unknown value for `line-style'. Valid values are `thick' and `double'." +msgstr "" + +#: src/postscript.c:700 +#, c-format +msgid "" +"Default font size must be at least 1 point (value of 1000 for key `%s')." +msgstr "" + +#: src/postscript.c:732 +#, c-format +msgid "Value for `%s' must be a dimension of positive length (i.e., `1in')." +msgstr "" + +#: src/postscript.c:795 +#, c-format +msgid "Nonnegative integer required as value for `%s'." +msgstr "" + +#: src/postscript.c:925 +#, c-format +msgid "%s: %s: Opening PostScript font encoding..." +msgstr "" + +#: src/postscript.c:931 +#, c-format +msgid "" +"PostScript driver: Cannot open encoding file `%s': %s. Substituting " +"ISOLatin1Encoding for missing encoding." +msgstr "" + +#: src/postscript.c:970 +msgid "PostScript driver: Invalid numeric format." +msgstr "" + +#: src/postscript.c:975 +#, c-format +msgid "" +"PostScript driver: Codes must be between 0 and 255. (%d is not allowed.)" +msgstr "" + +#: src/postscript.c:1011 +#, c-format +msgid "PostScript driver: Error closing encoding file `%s'." +msgstr "" + +#: src/postscript.c:1014 +#, c-format +msgid "%s: PostScript font encoding read successfully." +msgstr "" + +#: src/postscript.c:1109 +#, c-format +msgid "%s: %s: Opening PostScript encoding list file." +msgstr "" + +#: src/postscript.c:1144 +#, c-format +msgid "%s: PostScript encoding list file read successfully." +msgstr "" + +#: src/postscript.c:1158 +msgid "<>" +msgstr "" + +#: src/postscript.c:1316 +msgid "" +"Cannot find PostScript prologue. The use of `-vv' on the command line is " +"suggested as a debugging aid." +msgstr "" + +#: src/postscript.c:1321 +#, c-format +msgid "%s: %s: Opening PostScript prologue..." +msgstr "" + +#: src/postscript.c:1493 +#, c-format +msgid "%s: PostScript prologue read successfully." +msgstr "" + +#: src/postscript.c:1497 +#, c-format +msgid "%s: Error reading PostScript prologue." +msgstr "" + +#: src/postscript.c:1667 +#, c-format +msgid "PostScript output driver: %s: %s" +msgstr "" + +#: src/postscript.c:2355 +#, c-format +msgid "PostScript driver: Cannot find encoding `%s' for PostScript font `%s'." +msgstr "" + +#: src/tab.c:276 +#, c-format +msgid "bad vline: x=%d+%d=%d y=(%d+%d=%d,%d+%d=%d) in table size (%d,%d)\n" +msgstr "" + +#: src/tab.c:312 +#, c-format +msgid "bad hline: x=(%d+%d=%d,%d+%d=%d) y=%d+%d=%d in table size (%d,%d)\n" +msgstr "" + +#: src/tab.c:352 +#, c-format +msgid "" +"bad box: (%d+%d=%d,%d+%d=%d)-(%d+%d=%d,%d+%d=%d) in table size (%d,%d)\n" +msgstr "" + +#: src/do-if.c:121 +msgid "There is no DO IF to match with this ELSE IF." +msgstr "" + +#: src/do-if.c:126 +msgid "The ELSE command must follow all ELSE IF commands in a DO IF structure." +msgstr "" + +#: src/do-if.c:149 +msgid "End of command expected." +msgstr "" + +#: src/do-if.c:167 +msgid "There is no DO IF to match with this ELSE." +msgstr "" + +#: src/do-if.c:173 +msgid "" +"There may be at most one ELSE clause in each DO IF structure. It must be " +"the last clause." +msgstr "" + +#: src/do-if.c:210 +msgid "There is no DO IF to match with this END IF." +msgstr "" + +#: src/do-if.c:296 +#, c-format +msgid "DO IF %d: true\n" +msgstr "" + +#: src/do-if.c:301 +#, c-format +msgid "DO IF %d: false\n" +msgstr "" + +#: src/do-if.c:306 +#, c-format +msgid "DO IF %d: missing\n" +msgstr "" + +#: src/crosstabs.q:273 +msgid "" +"Missing mode REPORT not allowed in general mode. Assuming MISSING=TABLE." +msgstr "" + +#: src/crosstabs.q:283 +msgid "Write mode ALL not allowed in general mode. Assuming WRITE=CELLS." +msgstr "" + +#: src/crosstabs.q:367 +msgid "expecting BY" +msgstr "" + +#: src/crosstabs.q:440 +msgid "VARIABLES must be specified before TABLES." +msgstr "" + +#: src/crosstabs.q:477 +#, c-format +msgid "Maximum value (%ld) less than minimum value (%ld)." +msgstr "" + +#: src/crosstabs.q:937 +msgid "Summary." +msgstr "" + +#: src/crosstabs.q:939 +msgid "Cases" +msgstr "" + +#: src/crosstabs.q:940 src/frequencies.q:893 +msgid "Valid" +msgstr "" + +#: src/crosstabs.q:941 src/frequencies.q:960 +msgid "Missing" +msgstr "" + +#: src/crosstabs.q:942 src/crosstabs.q:1143 src/crosstabs.q:1886 +#: src/frequencies.q:969 +msgid "Total" +msgstr "" + +#: src/crosstabs.q:952 +msgid "N" +msgstr "" + +#: src/crosstabs.q:953 src/frequencies.q:897 src/frequencies.q:898 +#: src/frequencies.q:899 +msgid "Percent" +msgstr "" + +#: src/crosstabs.q:1192 +msgid "count" +msgstr "" + +#: src/crosstabs.q:1193 +#, c-format +msgid "row %" +msgstr "" + +#: src/crosstabs.q:1194 +#, c-format +msgid "column %" +msgstr "" + +#: src/crosstabs.q:1195 +#, c-format +msgid "total %" +msgstr "" + +#: src/crosstabs.q:1196 +msgid "expected" +msgstr "" + +#: src/crosstabs.q:1197 +msgid "residual" +msgstr "" + +#: src/crosstabs.q:1198 +msgid "std. resid." +msgstr "" + +#: src/crosstabs.q:1199 +msgid "adj. resid." +msgstr "" + +#: src/crosstabs.q:1232 src/crosstabs.q:1259 src/crosstabs.q:1279 +#: src/crosstabs.q:1300 +msgid "Statistic" +msgstr "" + +#: src/crosstabs.q:1234 +msgid "df" +msgstr "" + +#: src/crosstabs.q:1236 +msgid "Asymp. Sig. (2-sided)" +msgstr "" + +#: src/crosstabs.q:1238 +msgid "Exact. Sig. (2-sided)" +msgstr "" + +#: src/crosstabs.q:1240 +msgid "Exact. Sig. (1-sided)" +msgstr "" + +#: src/crosstabs.q:1258 src/crosstabs.q:1299 +msgid "Category" +msgstr "" + +#: src/crosstabs.q:1261 src/crosstabs.q:1303 +msgid "Asymp. Std. Error" +msgstr "" + +#: src/crosstabs.q:1262 src/crosstabs.q:1304 +msgid "Approx. T" +msgstr "" + +#: src/crosstabs.q:1263 src/crosstabs.q:1305 +msgid "Approx. Sig." +msgstr "" + +#: src/crosstabs.q:1278 +msgid " 95%% Confidence Interval" +msgstr "" + +#: src/crosstabs.q:1281 +msgid "Lower" +msgstr "" + +#: src/crosstabs.q:1282 +msgid "Upper" +msgstr "" + +#: src/crosstabs.q:1301 +msgid "Type" +msgstr "" + +#: src/crosstabs.q:2063 +msgid "Pearson Chi-Square" +msgstr "" + +#: src/crosstabs.q:2064 +msgid "Likelihood Ratio" +msgstr "" + +#: src/crosstabs.q:2065 +msgid "Fisher's Exact Test" +msgstr "" + +#: src/crosstabs.q:2066 +msgid "Continuity Correction" +msgstr "" + +#: src/crosstabs.q:2067 +msgid "Linear-by-Linear Association" +msgstr "" + +#: src/crosstabs.q:2104 src/crosstabs.q:2174 src/crosstabs.q:2233 +msgid "N of Valid Cases" +msgstr "" + +#: src/crosstabs.q:2120 src/crosstabs.q:2249 +msgid "Nominal by Nominal" +msgstr "" + +#: src/crosstabs.q:2121 src/crosstabs.q:2250 +msgid "Ordinal by Ordinal" +msgstr "" + +#: src/crosstabs.q:2122 +msgid "Interval by Interval" +msgstr "" + +#: src/crosstabs.q:2123 +msgid "Measure of Agreement" +msgstr "" + +#: src/crosstabs.q:2128 +msgid "Phi" +msgstr "" + +#: src/crosstabs.q:2129 +msgid "Cramer's V" +msgstr "" + +#: src/crosstabs.q:2130 +msgid "Contingency Coefficient" +msgstr "" + +#: src/crosstabs.q:2131 +msgid "Kendall's tau-b" +msgstr "" + +#: src/crosstabs.q:2132 +msgid "Kendall's tau-c" +msgstr "" + +#: src/crosstabs.q:2133 +msgid "Gamma" +msgstr "" + +#: src/crosstabs.q:2134 +msgid "Spearman Correlation" +msgstr "" + +#: src/crosstabs.q:2135 +msgid "Pearson's R" +msgstr "" + +#: src/crosstabs.q:2136 +msgid "Kappa" +msgstr "" + +#: src/crosstabs.q:2206 +#, c-format +msgid "Odds Ratio for %s (%g / %g)" +msgstr "" + +#: src/crosstabs.q:2209 +#, c-format +msgid "Odds Ratio for %s (%.*s / %.*s)" +msgstr "" + +#: src/crosstabs.q:2217 +#, c-format +msgid "For cohort %s = %g" +msgstr "" + +#: src/crosstabs.q:2220 +#, c-format +msgid "For cohort %s = %.*s" +msgstr "" + +#: src/crosstabs.q:2251 +msgid "Nominal by Interval" +msgstr "" + +#: src/crosstabs.q:2256 +msgid "Lambda" +msgstr "" + +#: src/crosstabs.q:2257 +msgid "Goodman and Kruskal tau" +msgstr "" + +#: src/crosstabs.q:2258 +msgid "Uncertainty Coefficient" +msgstr "" + +#: src/crosstabs.q:2259 +msgid "Somers' d" +msgstr "" + +#: src/crosstabs.q:2260 +msgid "Eta" +msgstr "" + +#: src/crosstabs.q:2265 +msgid "Symmetric" +msgstr "" + +#: src/crosstabs.q:2266 src/crosstabs.q:2267 +#, c-format +msgid "%s Dependent" +msgstr "" + +#: src/descript.q:151 src/frequencies.q:95 +msgid "Mean" +msgstr "" + +#: src/descript.q:151 +msgid "mean" +msgstr "" + +#: src/descript.q:152 src/frequencies.q:96 +msgid "S.E. Mean" +msgstr "" + +#: src/descript.q:152 +msgid "S E Mean" +msgstr "" + +#: src/descript.q:152 +msgid "SE" +msgstr "" + +#: src/descript.q:153 +msgid "standard error of mean" +msgstr "" + +#: src/descript.q:154 src/frequencies.q:99 +msgid "Std Dev" +msgstr "" + +#: src/descript.q:154 +msgid "SD" +msgstr "" + +#: src/descript.q:155 +msgid "standard deviation" +msgstr "" + +#: src/descript.q:156 src/frequencies.q:100 +msgid "Variance" +msgstr "" + +#: src/descript.q:157 +msgid "Var" +msgstr "" + +#: src/descript.q:157 +msgid "variance" +msgstr "" + +#: src/descript.q:158 src/frequencies.q:101 +msgid "Kurtosis" +msgstr "" + +#: src/descript.q:159 +msgid "Kurt" +msgstr "" + +#: src/descript.q:159 +msgid "kurtosis" +msgstr "" + +#: src/descript.q:160 src/frequencies.q:102 +msgid "S.E. Kurt" +msgstr "" + +#: src/descript.q:160 +msgid "S E Kurt" +msgstr "" + +#: src/descript.q:160 +msgid "SEKurt" +msgstr "" + +#: src/descript.q:161 +msgid "standard error of kurtosis" +msgstr "" + +#: src/descript.q:162 src/frequencies.q:103 +msgid "Skewness" +msgstr "" + +#: src/descript.q:162 +msgid "Skew" +msgstr "" + +#: src/descript.q:163 +msgid "skewness" +msgstr "" + +#: src/descript.q:164 src/frequencies.q:104 +msgid "S.E. Skew" +msgstr "" + +#: src/descript.q:164 +msgid "S E Skew" +msgstr "" + +#: src/descript.q:164 +msgid "SESkew" +msgstr "" + +#: src/descript.q:165 +msgid "standard error of skewness" +msgstr "" + +#: src/descript.q:166 src/frequencies.q:105 +msgid "Range" +msgstr "" + +#: src/descript.q:166 +msgid "Rng" +msgstr "" + +#: src/descript.q:167 src/frequencies.q:106 +msgid "Minimum" +msgstr "" + +#: src/descript.q:167 +msgid "Min" +msgstr "" + +#: src/descript.q:168 +msgid "minimum" +msgstr "" + +#: src/descript.q:169 src/frequencies.q:107 +msgid "Maximum" +msgstr "" + +#: src/descript.q:169 +msgid "Max" +msgstr "" + +#: src/descript.q:170 +msgid "maximum" +msgstr "" + +#: src/descript.q:171 src/frequencies.q:108 +msgid "Sum" +msgstr "" + +#: src/descript.q:171 +msgid "sum" +msgstr "" + +#: src/descript.q:212 src/list.q:161 +msgid "No variables specified." +msgstr "" + +#: src/descript.q:218 +msgid "OPTIONS may not be used with SAVE, FORMAT, or MISSING." +msgstr "" + +#: src/descript.q:280 +#, c-format +msgid "It's not possible to sort on `%s' without displaying `%s'." +msgstr "" + +#: src/descript.q:295 +msgid "" +"At least one case in the data file had a weight value that was " +"system-missing, zero, or negative. These case(s) were ignored." +msgstr "" + +#: src/descript.q:336 +msgid "" +"Names for z-score variables must be given for individual variables, not for " +"groups of variables." +msgstr "" + +#: src/descript.q:344 +msgid "Name for z-score variable expected." +msgstr "" + +#: src/descript.q:349 +#, c-format +msgid "" +"Z-score variable name `%s' is a duplicate variable name with a current " +"variable." +msgstr "" + +#: src/descript.q:358 +#, c-format +msgid "Z-score variable name `%s' is used multiple times." +msgstr "" + +#: src/descript.q:366 +msgid "`)' expected after z-score variable name." +msgstr "" + +#: src/descript.q:426 +msgid "" +"Ran out of generic names for Z-score variables. There are only 126 generic " +"names: ZSC001-ZSC0999, STDZ01-STDZ09, ZZZZ01-ZZZZ09, ZQZQ01-ZQZQ09." +msgstr "" + +#: src/descript.q:455 +msgid "Mapping of variables to corresponding Z-scores." +msgstr "" + +#: src/descript.q:460 +msgid "Source" +msgstr "" + +#: src/descript.q:461 +msgid "Target" +msgstr "" + +#: src/descript.q:548 src/descript.q:554 +msgid "Z-score of " +msgstr "" + +#: src/descript.q:803 +msgid "Valid N" +msgstr "" + +#: src/descript.q:804 +msgid "Missing N" +msgstr "" + +#: src/descript.q:831 +#, c-format +msgid "Valid cases = %g; cases with missing value(s) = %g." +msgstr "" + +#: src/frequencies.q:97 +msgid "Median" +msgstr "" + +#: src/frequencies.q:98 +msgid "Mode" +msgstr "" + +#: src/frequencies.q:271 +msgid "" +"At most one of BARCHART, HISTOGRAM, or HBAR should be given. HBAR will be " +"assumed. Argument values will be given precedence increasing along the " +"order given." +msgstr "" + +#: src/frequencies.q:352 +#, c-format +msgid "" +"MAX must be greater than or equal to MIN, if both are specified. However, " +"MIN was specified as %g and MAX as %g. MIN and MAX will be ignored." +msgstr "" + +#: src/frequencies.q:602 +msgid "" +"Upper limit of integer mode value range must be greater than lower limit." +msgstr "" + +#: src/frequencies.q:614 +#, c-format +msgid "Variable %s specified multiple times on VARIABLES subcommand." +msgstr "" + +#: src/frequencies.q:627 +#, c-format +msgid "Integer mode specified, but %s is not a numeric variable." +msgstr "" + +#: src/frequencies.q:687 +msgid "`)' expected after GROUPED interval list." +msgstr "" + +#: src/frequencies.q:697 +#, c-format +msgid "Variables %s specified on GROUPED but not on VARIABLES." +msgstr "" + +#: src/frequencies.q:700 +#, c-format +msgid "Variables %s specified multiple times on GROUPED subcommand." +msgstr "" + +#: src/frequencies.q:751 +msgid "Percentile list expected after PERCENTILES." +msgstr "" + +#: src/frequencies.q:759 +msgid "Percentiles must be greater than 0 and less than 100." +msgstr "" + +#: src/frequencies.q:894 src/frequencies.q:984 src/frequencies.q:985 +#: src/frequencies.q:1015 +msgid "Cum" +msgstr "" + +#: src/frequencies.q:896 src/frequencies.q:1420 +msgid "Frequency" +msgstr "" + +#: src/frequencies.q:915 +msgid "Value Label" +msgstr "" + +#: src/frequencies.q:1013 +msgid "Freq" +msgstr "" + +#: src/frequencies.q:1014 src/frequencies.q:1016 +msgid "Pct" +msgstr "" + +#: src/frequencies.q:1132 +#, c-format +msgid "No valid data for variable %s; statistics not displayed." +msgstr "" + +#: src/frequencies.q:1226 +#, c-format +msgid "only %g case%s for variable %s, statistics not computed" +msgstr "" + +#: src/frequencies.q:1261 +#, c-format +msgid "" +"The variable %s has %d modes. The lowest of these is the one given in the " +"table." +msgstr "" + +#. Draw axis labels. +#. 18-point text +#: src/frequencies.q:1420 +msgid "Percentage" +msgstr "" + +#: src/frequencies.q:1443 +msgid "low-res graphs not implemented" +msgstr "" + +#: src/frequencies.q:1577 +#, c-format +msgid "" +"Could not make histogram for %s for specified minimum %g and maximum %g; " +"please discard graph." +msgstr "" + +#: src/frequencies.q:1716 +msgid "Percentile Value Percentile Value Percentile Value" +msgstr "" + +#: src/frequencies.q:1733 +msgid "this form of percentiles not supported" +msgstr "" + +#: src/frequencies.q:1797 +#, c-format +msgid "Difference between %g and %g is too small for grouping interval %g." +msgstr "" + +#: src/list.q:169 +#, c-format +msgid "" +"The first case (%ld) specified precedes the last case (%ld) specified. The " +"values will be swapped." +msgstr "" + +#: src/list.q:177 +#, c-format +msgid "" +"The first case (%ld) to list is less than 1. The value is being reset to 1." +msgstr "" + +#: src/list.q:183 +#, c-format +msgid "" +"The last case (%ld) to list is less than 1. The value is being reset to 1." +msgstr "" + +#: src/list.q:189 +#, c-format +msgid "The step value %ld is less than 1. The value is being reset to 1." +msgstr "" + +#: src/list.q:217 +msgid "`/FORMAT WEIGHT' specified, but weighting is not on." +msgstr "" + +#: src/list.q:455 +msgid "Line" +msgstr "" + +#: src/means.q:108 +msgid "Missing required subcommand TABLES." +msgstr "" + +#: src/means.q:155 +msgid "TABLES or CROSSBREAK subcommand may not appear more than once." +msgstr "" + +#: src/means.q:202 +#, c-format +msgid "" +"Variable %s specified on TABLES or CROSSBREAK, but not specified on " +"VARIABLES." +msgstr "" + +#: src/means.q:216 +#, c-format +msgid "LOWEST and HIGHEST may not be used for independent variables (%s)." +msgstr "" + +#: src/means.q:224 +#, c-format +msgid "" +"Independent variables (%s) may not have noninteger endpoints in their ranges." +msgstr "" + +#: src/means.q:245 +#, c-format +msgid "Variable %s is multiply specified on TABLES or CROSSBREAK." +msgstr "" + +#: src/means.q:271 +msgid "VARIABLES must precede TABLES." +msgstr "" + +#: src/means.q:328 +#, c-format +msgid "Upper value (%g) is less than lower value (%g) on VARIABLES subcommand." +msgstr "" + +#: src/t-test.q:470 +msgid "expecting variable name in GROUPS subcommand" +msgstr "" + +#: src/t-test.q:475 +#, c-format +msgid "Long string variable %s is not valid here." +msgstr "" + +#: src/t-test.q:491 +msgid "" +"When applying GROUPS to a string variable, at least one value must be " +"specified." +msgstr "" + +#: src/t-test.q:581 +#, c-format +msgid "" +"PAIRED was specified but the number of variables preceding WITH (%d) did not " +"match the number following (%d)." +msgstr "" + +#: src/t-test.q:597 +msgid "At least two variables must be specified on PAIRS." +msgstr "" + +#: src/count.c:189 +msgid "Destination cannot be a string variable." +msgstr "" + +#: src/count.c:299 +#, c-format +msgid "" +"%g THRU %g is not a valid range. The number following THRU must be at least " +"as big as the number preceding THRU." +msgstr "" + +#: src/vars-atr.c:61 +msgid "Vartree:\n" +msgstr "" + +#: src/vars-atr.c:313 +#, c-format +msgid "clearing variable %d:%s %s\n" +msgstr "" + +#: src/vars-atr.c:314 +msgid "in default dictionary" +msgstr "" + +#: src/vars-atr.c:315 +msgid "in auxiliary dictionary" +msgstr "" + +#: src/vars-prs.c:113 +#, c-format +msgid "%s is not declared as a variable." +msgstr "" + +#: src/vars-prs.c:131 +#, c-format +msgid "%s is not a variable name." +msgstr "" + +#: src/vars-prs.c:230 +#, c-format +msgid "%s TO %s is not valid syntax since %s precedes %s in the dictionary." +msgstr "" + +#: src/vars-prs.c:239 +#, c-format +msgid "" +"When using the TO keyword to specify several variables, both variables must " +"be from the same variable dictionaries, of either ordinary, scratch, or " +"system variables. %s and %s are from different dictionaries." +msgstr "" + +#: src/vars-prs.c:256 +#, c-format +msgid "Scratch variables (such as %s) are not allowed here." +msgstr "" + +#: src/vars-prs.c:279 +#, c-format +msgid "" +"%s is not a numeric variable. It will not be included in the variable list." +msgstr "" + +#: src/vars-prs.c:285 +#, c-format +msgid "" +"%s is not a string variable. It will not be included in the variable list." +msgstr "" + +#: src/vars-prs.c:291 +#, c-format +msgid "" +"%s and %s are not the same type. All variables in this variable list must " +"be of the same type. %s will be omitted from list." +msgstr "" + +#: src/vars-prs.c:299 +#, c-format +msgid "Variable %s appears twice in variable list." +msgstr "" + +#: src/vars-prs.c:370 +msgid "incorrect use of TO convention" +msgstr "" + +#: src/vars-prs.c:410 +msgid "Scratch variables not allowed here." +msgstr "" + +#: src/vars-prs.c:432 +msgid "Prefixes don't match in use of TO convention." +msgstr "" + +#: src/vars-prs.c:437 +msgid "Bad bounds in use of TO convention." +msgstr "" + +#: src/vfm.c:311 +#, c-format +msgid "" +"Workspace overflow predicted. Max workspace is currently set to %d KB (%d " +"cases at %d bytes each). Paging active file to disk." +msgstr "" + +#: src/vfm.c:374 +msgid "!ERROR!" +msgstr "" + +#: src/vfm.c:395 +msgid "" +msgstr "" + +#: src/vfm.c:655 +#, c-format +msgid "" +"An error occurred attempting to create a temporary file for use as the " +"active file: %s." +msgstr "" + +#: src/vfm.c:673 +#, c-format +msgid "" +"An error occurred while attempting to read from a temporary file created for " +"the active file: %s." +msgstr "" + +#: src/vfm.c:701 +#, c-format +msgid "" +"An error occurred while attempting to write to a temporary file used as the " +"active file: %s." +msgstr "" + +#: src/vfm.c:715 +#, c-format +msgid "" +"An error occurred while attempting to rewind a temporary file used as the " +"active file: %s." +msgstr "" + +#: src/vfm.c:830 +msgid "Virtual memory exhausted. Paging active file to disk." +msgstr "" + +#: src/vfm.c:833 +#, c-format +msgid "" +"Workspace limit of %d KB (%d cases at %d bytes each) overflowed. Paging " +"active file to disk." +msgstr "" + +#: src/vfm.c:857 src/vfm.c:894 +#, c-format +msgid "" +"An error occurred while attempting to write to a temporary file created as " +"the active file, while paging to disk: %s." +msgstr "" + +#: src/vfm.c:1008 +msgid "transform: " +msgstr "" + +#: src/autorecode.c:135 +#, c-format +msgid "Target variable %s duplicates existing variable %s." +msgstr "" + +#: src/autorecode.c:142 +#, c-format +msgid "Duplicate variable name %s among target variables." +msgstr "" + +#: src/compute.c:140 src/compute.c:186 src/compute.c:292 src/compute.c:329 +#, c-format +msgid "" +"When executing COMPUTE: SYSMIS is not a valid value as an index into vector " +"%s." +msgstr "" + +#: src/compute.c:143 src/compute.c:189 src/compute.c:295 src/compute.c:332 +#, c-format +msgid "" +"When executing COMPUTE: %g is not a valid value as an index into vector %s." +msgstr "" + +#: src/compute.c:422 +#, c-format +msgid "There is no vector named %s." +msgstr "" + +#: src/compute.c:471 +msgid "Extra characters after expression." +msgstr "" + +#: src/flip.c:160 +#, c-format +msgid "Could not create acceptable variant for variable %s." +msgstr "" + +#: src/flip.c:176 +msgid "Cannot create more than 99999 variable names." +msgstr "" + +#: src/flip.c:290 +#, c-format +msgid "Error reading FLIP source file: %s." +msgstr "" + +#: src/flip.c:366 +msgid "Could not create temporary file for FLIP." +msgstr "" + +#: src/flip.c:376 src/flip.c:395 +#, c-format +msgid "Error writing FLIP file: %s." +msgstr "" + +#: src/flip.c:431 +msgid "Error creating FLIP source file." +msgstr "" + +#: src/flip.c:434 +#, c-format +msgid "Error rewinding FLIP file: %s." +msgstr "" + +#: src/flip.c:443 +#, c-format +msgid "Error reading FLIP file: %s." +msgstr "" + +#: src/flip.c:455 +#, c-format +msgid "Error seeking FLIP source file: %s." +msgstr "" + +#: src/flip.c:460 +#, c-format +msgid "Error writing FLIP source file: %s." +msgstr "" + +#: src/flip.c:468 +#, c-format +msgid "Error rewind FLIP source file: %s." +msgstr "" + +#: src/print.c:209 +msgid "expecting a valid subcommand" +msgstr "" + +#: src/print.c:389 src/print.c:406 +#, c-format +msgid "%g is not a valid column location." +msgstr "" + +#: src/print.c:400 +#, c-format +msgid "Column location expected following `%d-'." +msgstr "" + +#: src/print.c:411 +#, c-format +msgid "" +"%d-%ld is not a valid column range. The second column must be greater than " +"or equal to the first." +msgstr "" + +#: src/print.c:517 +#, c-format +msgid "" +"%s is not of the same type as %s. To specify variables of different types " +"in the same variable list, use a FORTRAN-like format specifier." +msgstr "" + +#: src/print.c:547 +msgid "" +"The ending column for a field must not be less than the starting column." +msgstr "" + +#: src/print.c:630 +#, c-format +msgid "%s variables cannot be displayed with format %s." +msgstr "" + +#: src/print.c:717 +#, c-format +msgid "Display format %s may not be used with a %s variable." +msgstr "" + +#: src/print.c:867 +#, c-format +msgid "Writing %3d records to file %s." +msgstr "" + +#: src/print.c:868 +#, c-format +msgid "Writing %3d records to the listing file." +msgstr "" + +#: src/print.c:1082 +msgid "A file name or handle was expected in the OUTFILE subcommand." +msgstr "" + +#: src/print.c:1134 +#, c-format +msgid "" +"The expression on PRINT SPACE evaluated to %d. It's not possible to PRINT " +"SPACE a negative number of lines." +msgstr "" + +#: src/recode.c:290 +#, c-format +msgid "" +"%d variable(s) cannot be recoded into %d variable(s). Specify the same " +"number of variables as input and output variables." +msgstr "" + +#: src/recode.c:304 +#, c-format +msgid "" +"There is no string variable named %s. (All string variables specified on " +"INTO must already exist. Use the STRING command to create a string " +"variable.)" +msgstr "" + +#: src/recode.c:313 +#, c-format +msgid "" +"Type mismatch between input and output variables. Output variable %s is not " +"a string variable, but all the input variables are string variables." +msgstr "" + +#: src/recode.c:332 +#, c-format +msgid "Type mismatch after INTO: %s is not a numeric variable." +msgstr "" + +#: src/recode.c:362 +msgid "" +"INTO must be used when the input values are numeric and output values are " +"string." +msgstr "" + +#: src/recode.c:370 +msgid "" +"INTO must be used when the input values are string and output values are " +"numeric." +msgstr "" + +#: src/recode.c:507 +msgid "" +"Inconsistent output types. The output values must be all numeric or all " +"string." +msgstr "" + +#: src/recode.c:558 +msgid "following LO THRU" +msgstr "" + +#: src/recode.c:574 src/recode.c:603 +msgid "in source value" +msgstr "" + +#: src/recode.c:616 +msgid "" +"Keyword CONVERT may only be used with string input values and numeric output " +"values." +msgstr "" + +#: src/recode.c:872 +msgid "!!END!!" +msgstr "" + +#: src/recode.c:893 src/recode.c:909 +msgid "!!ERROR!!" +msgstr "" + +#: src/sel-if.c:102 +msgid "The filter variable must be numeric." +msgstr "" + +#: src/sel-if.c:108 +msgid "The filter variable may not be scratch." +msgstr "" + +#: src/sel-if.c:142 +msgid "Only last instance of this command is in effect." +msgstr "" + +#: src/sort.c:131 +msgid "`A' or `D' expected inside parentheses." +msgstr "" + +#: src/sort.c:137 +msgid "`)' expected." +msgstr "" + +#: src/sort.c:462 +#, c-format +msgid "%s: Cannot create temporary directory: %s." +msgstr "" + +#: src/sort.c:486 +#, c-format +msgid "%s: Error removing directory for temporary files: %s." +msgstr "" + +#: src/sort.c:530 +#, c-format +msgid "" +"Out of memory. Could not allocate room for minimum of %d cases of %d bytes " +"each. (PSPP workspace is currently restricted to a maximum of %d KB.)" +msgstr "" + +#: src/sort.c:542 +#, c-format +msgid "allocated %d cases == %d bytes\n" +msgstr "" + +#: src/sort.c:580 +#, c-format +msgid "%s: Error writing temporary file: %s." +msgstr "" + +#: src/sort.c:592 +#, c-format +msgid "SORT: Closing handle %d." +msgstr "" + +#: src/sort.c:598 src/sort.c:822 +#, c-format +msgid "%s: Error closing temporary file: %s." +msgstr "" + +#: src/sort.c:620 src/sort.c:636 +#, c-format +msgid "SORT: %s: Opening for writing as run %d." +msgstr "" + +#: src/sort.c:642 +#, c-format +msgid "%s: Error opening temporary file for reading: %s." +msgstr "" + +#: src/sort.c:668 src/sort.c:684 +#, c-format +msgid "%s: Error creating temporary file: %s." +msgstr "" + +#: src/sort.c:826 src/sort.c:987 src/sort.c:1037 src/sort.c:1207 +#: src/sort.c:1214 +#, c-format +msgid "%s: Error removing temporary file: %s." +msgstr "" + +#. Find the shortest runs; put them in runs[] in reverse order +#. of length, to force dummy runs of length 0 to the end of the +#. list. +#: src/sort.c:969 +msgid "merging runs" +msgstr "" + +#: src/sort.c:977 +#, c-format +msgid " into run %d(%d)\n" +msgstr "" + +#: src/sort.c:996 +msgid "Out of memory expanding Huffman priority queue." +msgstr "" + +#: src/sort.c:1048 +#, c-format +msgid "%s: Error creating temporary file for merge: %s." +msgstr "" + +#: src/sort.c:1076 src/sort.c:1134 +#, c-format +msgid "%s: Error reading temporary file in merge: %s." +msgstr "" + +#: src/sort.c:1079 src/sort.c:1138 +#, c-format +msgid "%s: Unexpected end of temporary file in merge." +msgstr "" + +#: src/sort.c:1104 +#, c-format +msgid "%s: Error writing temporary file in merge: %s." +msgstr "" + +#: src/sort.c:1154 src/sort.c:1187 +#, c-format +msgid "%s: Error closing temporary file in merge: %s." +msgstr "" + +#: src/sort.c:1159 +#, c-format +msgid "%s: Error removing temporary file in merge: %s." +msgstr "" + +#: src/sort.c:1258 +#, c-format +msgid "%s: Cannot open sort result file: %s." +msgstr "" + +#: src/sort.c:1269 +#, c-format +msgid "%s: Error reading sort result file: %s." +msgstr "" + +#: src/sort.c:1272 +#, c-format +msgid "%s: Unexpected end of sort result file: %s." +msgstr "" + +#: src/sort.c:1283 +#, c-format +msgid "%s: Error closing sort result file: %s." +msgstr "" + +#: src/sort.c:1287 +#, c-format +msgid "%s: Error removing sort result file: %s." +msgstr "" + +#: src/include.c:51 +msgid "Unrecognized filename format." +msgstr "" + +#: src/loop.c:203 +msgid "The index variable may not be a string variable." +msgstr "" + +#: src/loop.c:323 +msgid "There is no LOOP command that corresponds to this END LOOP." +msgstr "" + +#: src/loop.c:524 +msgid "" +"This command may only appear enclosed in a LOOP/END LOOP control structure." +msgstr "" + +#: src/loop.c:530 +msgid "BREAK not enclosed in DO IF structure." +msgstr "" + +#: src/loop.c:607 +#, c-format +msgid "%s without %s." +msgstr "" + +#: src/repeat.c:160 +#, c-format +msgid "Identifier %s is given twice." +msgstr "" + +#: src/repeat.c:203 +#, c-format +msgid "" +"There must be the same number of substitutions for each dummy variable " +"specified. Since there were %d substitutions for %s, there must be %d for " +"%s as well, but %d were specified." +msgstr "" + +#: src/repeat.c:312 +msgid "No commands in scope." +msgstr "" + +#: src/mis-val.c:332 src/repeat.c:485 +msgid "String expected." +msgstr "" + +#: src/repeat.c:512 +msgid "No matching DO REPEAT." +msgstr "" + +#: src/mis-val.c:83 +msgid "`)' expected after value specification." +msgstr "" + +#: src/mis-val.c:117 +#, c-format +msgid "`(' expected after variable name%s." +msgstr "" + +#: src/mis-val.c:129 +msgid "Long string value specified." +msgstr "" + +#: src/mis-val.c:134 +msgid "Short strings must be of equal width." +msgstr "" + +#: src/mis-val.c:191 +#, c-format +msgid "Range %g THRU %g is not valid because %g is greater than %g." +msgstr "" + +#: src/mis-val.c:222 +msgid "Number or range expected." +msgstr "" + +#: src/mis-val.c:255 +msgid "At most one range can exist in the missing values for any one variable." +msgstr "" + +#: src/mis-val.c:261 +msgid "At most one individual value can be missing along with one range." +msgstr "" + +#: src/mis-val.c:323 +msgid "String is not of proper length." +msgstr "" + +#: src/mis-val.c:372 +msgid "Missing value:" +msgstr "" + +#: src/mis-val.c:377 +msgid "(long string variable)" +msgstr "" + +#: src/mis-val.c:382 +msgid "(no missing values)\n" +msgstr "" + +#: src/mis-val.c:405 +#, c-format +msgid "(!!!INTERNAL ERROR--%d!!!)\n" +msgstr "" + +#: src/modify-vars.c:109 +msgid "REORDER subcommand may be given at most once." +msgstr "" + +#: src/modify-vars.c:131 +msgid "Cannot specify ALL after specifying a set of variables." +msgstr "" + +#: src/modify-vars.c:141 +msgid "`(' expected on REORDER subcommand." +msgstr "" + +#: src/modify-vars.c:153 +msgid "`)' expected following variable names on REORDER subcommand." +msgstr "" + +#: src/modify-vars.c:185 +msgid "RENAME subcommand may be given at most once." +msgstr "" + +#: src/modify-vars.c:198 +msgid "`(' expected on RENAME subcommand." +msgstr "" + +#: src/modify-vars.c:206 +msgid "" +"`=' expected between lists of new and old variable names on RENAME " +"subcommand." +msgstr "" + +#: src/modify-vars.c:216 src/rename-vars.c:74 +#, c-format +msgid "" +"Differing number of variables in old name list (%d) and in new name list " +"(%d)." +msgstr "" + +#: src/modify-vars.c:227 +msgid "`)' expected after variable lists on RENAME subcommand." +msgstr "" + +#: src/modify-vars.c:243 +msgid "" +"KEEP subcommand may be given at most once. It may notbe given in " +"conjunction with the DROP subcommand." +msgstr "" + +#: src/modify-vars.c:281 +msgid "" +"DROP subcommand may be given at most once. It may notbe given in " +"conjunction with the KEEP subcommand." +msgstr "" + +#: src/modify-vars.c:307 +#, c-format +msgid "Unrecognized subcommand name `%s'." +msgstr "" + +#: src/modify-vars.c:309 +msgid "Subcommand name expected." +msgstr "" + +#: src/modify-vars.c:317 +msgid "`/' or `.' expected." +msgstr "" + +#: src/modify-vars.c:471 src/rename-vars.c:124 +#, c-format +msgid "Duplicate variable name `%s' after renaming." +msgstr "" + +#: src/numeric.c:61 +#, c-format +msgid "Format type %s may not be used with a numeric variable." +msgstr "" + +#: src/numeric.c:81 src/numeric.c:164 src/vector.c:167 +#, c-format +msgid "There is already a variable named %s." +msgstr "" + +#: src/numeric.c:135 +#, c-format +msgid "Format type %s may not be used with a string variable." +msgstr "" + +#: src/rename-vars.c:59 +msgid "`(' expected." +msgstr "" + +#: src/rename-vars.c:67 +msgid "`=' expected between lists of new and old variable names." +msgstr "" + +#: src/rename-vars.c:85 +msgid "`)' expected after variable names." +msgstr "" + +#: src/sample.c:72 +msgid "The sampling factor must be between 0 and 1 exclusive." +msgstr "" + +#: src/sample.c:92 +#, c-format +msgid "Cannot sample %d observations from a population of %d." +msgstr "" + +#: src/set.q:216 +msgid "BLOCK is obsolete." +msgstr "" + +#: src/set.q:219 +msgid "BOXSTRING is obsolete." +msgstr "" + +#: src/set.q:223 +msgid "Active file compression is not yet implemented (and probably won't be)." +msgstr "" + +#: src/set.q:232 +msgid "CPI must be greater than 0." +msgstr "" + +#: src/set.q:237 +msgid "HISTOGRAM is obsolete." +msgstr "" + +#: src/set.q:241 +msgid "LPI must be greater than 0." +msgstr "" + +#: src/set.q:248 +msgid "" +"CASE is not implemented and probably won't be. If you care, complain about " +"it." +msgstr "" + +#: src/set.q:278 +#, c-format +msgid "Value for MITERATE (%ld) must be greater than 0." +msgstr "" + +#: src/set.q:286 +#, c-format +msgid "Value for MNEST (%ld) must be greater than 0." +msgstr "" + +#: src/set.q:294 +msgid "MXERRS must be at least 1." +msgstr "" + +#: src/set.q:301 +msgid "MXLOOPS must be at least 1." +msgstr "" + +#: src/set.q:306 +msgid "MXMEMORY is obsolete." +msgstr "" + +#: src/set.q:312 +msgid "SCRIPTTAB is obsolete." +msgstr "" + +#: src/set.q:314 +msgid "TBFONTS not implemented." +msgstr "" + +#: src/set.q:316 +msgid "TB1 not implemented." +msgstr "" + +#: src/set.q:320 +msgid "WORKSPACE is obsolete." +msgstr "" + +#: src/set.q:327 +msgid "AUTOMENU is obsolete." +msgstr "" + +#: src/set.q:329 +msgid "BEEP is obsolete." +msgstr "" + +#: src/set.q:348 +msgid "EJECT is obsolete." +msgstr "" + +#: src/set.q:352 +msgid "HELPWINDOWS is obsolete." +msgstr "" + +#: src/set.q:356 +msgid "MENUS is obsolete." +msgstr "" + +#: src/set.q:370 +msgid "PTRANSLATE is obsolete." +msgstr "" + +#: src/set.q:376 +msgid "XSORT is obsolete." +msgstr "" + +#: src/set.q:390 +#, c-format +msgid "" +"CC%c: Length of custom currency string `%s' (%d) exceeds maximum length of " +"16." +msgstr "" + +#: src/set.q:412 +#, c-format +msgid "" +"CC%c: Custom currency string `%s' does not contain exactly three periods or " +"commas (not both)." +msgstr "" + +#: src/set.q:555 +msgid "LENGTH must be at least 1." +msgstr "" + +#: src/set.q:592 +msgid "Missing identifier in RESULTS subcommand." +msgstr "" + +#: src/set.q:603 +msgid "Unrecognized identifier in RESULTS subcommand." +msgstr "" + +#: src/set.q:639 +msgid "WIDTH must be at least 1." +msgstr "" + +#: src/set.q:662 +#, c-format +msgid "" +"FORMAT requires numeric output format as an argument. Specified format %s " +"is of type string." +msgstr "" + +#: src/set.q:706 +msgid "Text color must be in range 0-15." +msgstr "" + +#: src/set.q:719 +msgid "Background color must be in range 0-7." +msgstr "" + +#: src/set.q:730 +msgid "Border color must be in range 0-7." +msgstr "" + +#: src/set.q:774 +msgid "RCOLOR is obsolete." +msgstr "" + +#: src/set.q:786 +msgid "Lower window color must be between 0 and 6." +msgstr "" + +#: src/set.q:800 +msgid "Upper window color must be between 0 and 6." +msgstr "" + +#: src/set.q:812 +msgid "Frame color must be between 0 and 6." +msgstr "" + +#: src/set.q:845 +msgid "VIEWLENGTH not implemented." +msgstr "" + +#: src/set.q:855 +msgid "WORKDEV is obsolete." +msgstr "" + +#: src/set.q:864 +msgid "Drive letter expected in WORKDEV subcommand." +msgstr "" + +#: src/temporary.c:65 +msgid "This command is not valid inside DO IF or LOOP." +msgstr "" + +#: src/temporary.c:72 +msgid "" +"This command may only appear once between procedures and procedure-like " +"commands." +msgstr "" + +#: src/title.c:57 +#, c-format +msgid "%s before: %s\n" +msgstr "" + +#: src/title.c:57 +msgid "" +msgstr "" + +#: src/title.c:69 +#, c-format +msgid "%s: `.' expected after string." +msgstr "" + +#: src/title.c:84 +#, c-format +msgid "%s after: %s\n" +msgstr "" + +#: src/title.c:134 +#, c-format +msgid "Document entered %s %02d:%02d:%02d by %s (%s):" +msgstr "" + +#: src/val-labs.c:139 +#, c-format +msgid "" +"It is not possible to assign value labels to long string variables such as " +"%s." +msgstr "" + +#: src/val-labs.c:186 +msgid "String expected for value." +msgstr "" + +#: src/val-labs.c:195 +msgid "Number expected for value." +msgstr "" + +#: src/val-labs.c:199 +#, c-format +msgid "Value label `%g' is not integer." +msgstr "" + +#: src/val-labs.c:209 +msgid "Truncating value label to 60 characters." +msgstr "" + +#: src/val-labs.c:242 +msgid "Value labels:" +msgstr "" + +#: src/val-labs.c:259 +msgid " (no value labels)\n" +msgstr "" + +#: src/var-labs.c:55 +msgid "String expected for variable label." +msgstr "" + +#: src/var-labs.c:61 +msgid "Truncating variable label to 120 characters." +msgstr "" + +#: src/var-labs.c:89 +msgid "Variable labels:\n" +msgstr "" + +#: src/var-labs.c:96 +msgid "(no variable label)" +msgstr "" + +#: src/vector.c:80 +#, c-format +msgid "Vector name %s is given twice." +msgstr "" + +#: src/vector.c:86 +#, c-format +msgid "There is already a vector with name %s." +msgstr "" + +#. There's more than one vector name. +#: src/vector.c:105 +msgid "" +"A slash must be used to separate each vector specification when using the " +"long form. Commands such as VECTOR A,B=Q1 TO Q20 are not supported." +msgstr "" + +#: src/vector.c:139 +msgid "Vectors must have at least one element." +msgstr "" + +#: src/vector.c:153 +#, c-format +msgid "%s%d is too long for a variable name." +msgstr "" + +#: src/vector.c:195 +msgid "" +"The syntax for this command does not match the expected syntax for either " +"the long form or the short form of VECTOR." +msgstr "" + +#: src/weight.c:61 +msgid "The weighting variable must be numeric." +msgstr "" + +#: src/weight.c:66 +msgid "The weighting variable may not be scratch." +msgstr "" + +#: src/weight.c:106 +msgid "bad weighting variable, canceling\n" +msgstr "" diff --git a/pref.h.orig b/pref.h.orig new file mode 100644 index 00000000..15770947 --- /dev/null +++ b/pref.h.orig @@ -0,0 +1,268 @@ +/* Let's tell EMACS what language this is: -*- C -*- */ + +/* Used by separable libraries to enable PSPP-specific features. */ +#define PSPP 1 + +/* + * + * Debugging + * + */ + +/* Define to get lots of info printed by procedures. */ +/*#define DEBUGGING 1*/ + +#if DEBUGGING +#define GLOBAL_DEBUGGING 1 +#endif + +/* Define these if DEBUGGING is off and you want to make certain + additional optimizations. */ +#if !DEBUGGING +/* #define PRODUCTION 1 */ /* disable extra function calls */ +/* #define NDEBUG 1 */ /* disable assert() sanity checks */ +#endif + +/* Compilers. */ + +/* Fix Windows lossage. */ +#ifdef __WIN32__ +#undef __WIN32__ +#define __WIN32__ 1 +#undef __MSDOS__ +#define __MSDOS__ 1 +#endif + +/* Fix DJGPP lossage. */ +#if __DJGPP__ +#undef unix +#undef __unix__ +#endif + +/* Fix Cygnus Windows lossage. */ +#if defined (__CYGWIN32__) +#define unix 1 +#endif + +/* Ensure that unix and __unix__ are equivalent. */ +#if defined (unix) || defined (__unix__) || defined (__unix) +#undef unix +#define unix 1 + +#undef __unix__ +#define __unix__ 1 + +#undef __unix +#define __unix 1 +#endif + +/* Make sure to use the proper keywords. */ +#if __GNUC__ > 1 && !defined (inline) +#define inline __inline__ +#endif + +/* GNU C allows the programmer to declare that certain functions take + printf-like arguments, never return, etc. Conditionalize these + declarations on whether gcc is in use. */ +#if __GNUC__ > 1 +#define __attribute__(X) __attribute__ (X) +#else +#define __attribute__(X) +#endif + +/* GNU C allows unused variables and parameters to be declared as + such. */ +#if __GNUC__ >= 2 +#define unused __attribute__ ((__unused__)) +#else +#define unused +#endif + +/* CPUs. */ + +/* Check that the floating-point representation is one that we + understand. */ +#if FPREP==FPREP_IEEE754 + +#if SIZEOF_DOUBLE == 8 +#define second_lowest_flt64 second_lowest_value +#else +#error Must define second_lowest_flt64 for your architecture. +#endif + +/* This trick borrowed from gcc-lib/.../include/float.h. */ +#if __GNUC__ && (ENDIAN==BIG || ENDIAN==LITTLE) +#ifndef __DBL_UNION__ +#define __DBL_UNION__ +union blp_convert_double { + unsigned char convert_double_i[8]; + double convert_double_d; +}; +#endif /* !defined __DBL_UNION__ */ +#if ENDIAN==LITTLE +#define SECOND_LOWEST_VALUE \ + (__extension__ ((union blp_convert_double) \ + {{0xfe,0xff,0xff,0xff, 0xff,0xff,0xef,0xff}}) \ + .convert_double_d) +#elif ENDIAN==BIG +#define SECOND_LOWEST_VALUE \ + (__extension__ ((union blp_convert_double) \ + {{0xff,0xef,0xff,0xff, 0xff,0xff,0xff,0xfe}}) \ + .convert_double_d) +#endif /* endianness */ +#endif /* __GNUC__ and known endianness */ + +#else /* FPREP != FPREP_IEEE754 */ +#error Floating point representation must be known at compile time. +#endif /* fprep */ + +/* Figure out which integer type on this system is a signed 32-bit + integer. */ +#if SIZEOF_SHORT==4 + #define int32 short +#elif SIZEOF_INT==4 + #define int32 int +#elif SIZEOF_LONG==4 + #define int32 long +#else + #error Which one of your basic types is 32-bit signed integer? +#endif + +#if SIZEOF_FLOAT==8 + #define flt64 float + #define FLT64_MAX FLT_MAX +#elif SIZEOF_DOUBLE==8 + #define flt64 double + #define FLT64_MAX DBL_MAX +#elif SIZEOF_LONG_DOUBLE==8 + #define flt64 long double + #define FLT64_MAX LDBL_MAX +#else + #error Which one of your basic types is 64-bit floating point? + #define flt64 double + #define FLT64_MAX DBL_MAX +#endif + +/* Environments. */ + +/* Internationalization. */ +#include + +#if !ENABLE_NLS +/* If we don't do this then gettext() still monkeys with the string, + which causes gcc not to do its checking on printf() format + types. */ +#undef gettext +#define gettext(STRING) \ + STRING +#endif + +#define _(STRING) \ + gettext(STRING) + +#define N_(STRING) \ + STRING + +/* Even C emulation of alloca counts as an alloca implementation. */ +#if C_ALLOCA +#define HAVE_ALLOCA 1 +#endif + +/* Define PAGED_STACK if alloca() is supported and the stack can + expand arbitrarily. (Under some broken OSes like DOS and + Windows the stack is small and fixed in size.) This will prevent + big alloca() requests (like 1MB). */ +#if HAVE_ALLOCA && unix +#define PAGED_STACK 1 +#endif + +/* Saves on #if's. */ +#if HAVE_ALLOCA && !__CHECKER__ +#define local_alloc(X) \ + alloca(X) + +#define local_free(P) \ + do \ + { \ + } \ + while (0) +#elif !__CHECKER__ +#define local_alloc(X) \ + xmalloc (X) + +#define local_free(P) \ + free (P) +#else /* __CHECKER__ */ +/* Why define these this way? Because if you do it this way then if + you try to free a block returned by local_alloc() with the free() + function, you get an error message. */ +#define local_alloc(X) \ + ((void *) (((char *) (xmalloc (X+16))) + 16)) + +#define local_free(P) \ + free (((char *) P) - 16) +#endif /* __CHECKER__ */ + +/* Filesystems. */ + +/* Directory separator character for this OS, if applicable. */ +#if !__MSDOS__ +#define DIR_SEPARATOR '/' +#elif +#define DIR_SEPARATOR '\\' +#endif + +/* Path delimiter character. */ +#if !__MSDOS__ +#define PATH_DELIMITER ':' +#else +#define PATH_DELIMITER ';' +#endif + +/* MSDOS mkdir() takes only one argument. */ +#if __MSDOS__ && !__DJGPP__ +#define mkdir(path, mode) \ + mkdir (path) +#endif + +/* Options. */ + +/* Approximate amount of memory, in bytes, to allocate before paging + to disk. */ +#define MAX_WORKSPACE (4*1024*1024) /* 4 MBytes */ + +/* (libhistory) The location for the history file that records + commands entered interactively. Tilde expansion is performed. */ +#define HISTORY_FILE "~/.pspp_history" + +/* (libhistory) Maximum number of commands to record in history + file. */ +#define MAX_HISTORY 500 + +/* Output drivers. */ + +/* Define to exclude the HTML output driver. */ +/* #define NO_HTML 1 */ + +/* Define to exclude the PostScript and Encapsulated PostScript + driver. */ +/* #define NO_POSTSCRIPT 1 */ + +/* Procedure-specific options. */ + +/* CROSSTABS: Maximum number of tables to process in one pass. */ +#define MAX_CROSSTAB_TABLES 32 + +/* FREQUENCIES: Define to allow bars greater than 1/2" wide. */ +/* #define ALLOW_HUGE_BARS 1 */ + +/* FREQUENCIES: Minimum, maximum number of bars in a histogram. The + number is based on the number of unique values of the variable, + unless overridden. */ +#define MIN_HIST_BARS 3 +#define MAX_HIST_BARS 20 + +/* FREQUENCIES: Density of polyline used to approximate the normal + curve. The value is the number of samples taken per chart. Higher + values give smoother curves. */ +#define POLYLINE_DENSITY (MAX_HIST_BARS*4) diff --git a/reconfigure b/reconfigure new file mode 100755 index 00000000..8fc43d52 --- /dev/null +++ b/reconfigure @@ -0,0 +1,61 @@ +#! /bin/sh -e + +nls=--disable-nls +clean=no +include_deps=yes + +while true; do + if [ "$1" = "--enable-nls" ]; then + nls= + elif [ "$1" = "--disable-nls" ]; then + nls=--disable-nls + elif [ "$1" = "--clean" ]; then + clean=yes + elif [ "$1" = "--not-clean" ]; then + clean=no + elif [ "$1" = "--no-include-deps" ]; then + include_deps=no + elif [ "$1" = "--include-deps" ]; then + include_deps=yes + elif [ "$1" = "--help" ]; then + echo "Usage: $0 [--enable-nls] [--clean] [--include-deps] ..." + exit 0 + else + break + fi + + shift +done + +# Extract PSPP version number. +VERSION=`sed -ne 's/^.*\[//;s/].*$//;/^[0-9]*\.[0-9]*\.[0-9]*$/p' < configure.in` + +if [ "$clean" = "no" ]; then + echo "Generating a Makefile for cleaning..." + if [ ! -f Makefile ]; then + aclocal + autoheader + make -f Makefile.am docfiles VERSION=$VERSION + automake --foreign + autoconf + ./configure $nls $* + fi + echo "Cleaning the distribution..." + make -k maintainer-clean || true +fi + +echo "Configuring..." +aclocal +autoheader +make -f Makefile.am docfiles VERSION=$VERSION +automake +autoconf +./configure $nls $* +make mostlyclean || true # This causes dependencies to be generated + +if [ "$include_deps" = "yes" ]; then + echo "Configuring with included dependencies..." + automake --include-deps + autoconf + ./configure $nls $* +fi diff --git a/src/ChangeLog b/src/ChangeLog new file mode 100644 index 00000000..c3877c4a --- /dev/null +++ b/src/ChangeLog @@ -0,0 +1,7067 @@ +Sun Jan 2 21:40:13 2000 Ben Pfaff + + * Makefile.am: Reorganized. Put locale dir in version.c instead + of passing it to each compile command. Only put local gmp libs in + LD_ADD if not installed on system. Remove `boast' target. + + * All source files: struct and union typedefs eliminated. + `sizeof type' replaced by `sizeof object' where practical. Moved + `unused' qualifiers from start to end of declarations for gcc + 2.7.2 compatibility. Change `while (1)' to `for (;;)'. Made + assertions on pointers strictly compliant. Removed _ prefixes on + some function parameter names. + + * alloc.c: New source file, containing these external linkage + functions removed from common.c: xmalloc, xcalloc, xrealloc, + xstrdup. + + * arena.c: Removed. + + * arena.h: Removed. + + * ascii.c: Migrated from arenas to pools. + (struct ascii_driver_ext) ops[], box[], fonts[] changed from + c_string to len_string. All references changed. + (ascii_option) Signature changed to comply to new output.c + interface. + (count_fancy_chars) Removed. + (delineate) Removed support for rich text. + (ascii_text_metrics) Ditto. + (text_draw) Ditto. + (output_shorts) Change `box', `off', `on' from c_string to + len_string. Change `remaining' from int to size_t. + (ascii_close_page) Make page numbering less haphazard. + + * autorecode.c: Migrate from arenas to pools. + + * avl.c: Migrate from arenas to pools. Synch from libavl 1.4.0. + + * bitvector.h: New file containing these macros from misc.h: + SET_BIT, CLEAR_BIT, SET_BIT_TO, TEST_BIT, BIT_INDEX. + + * command.c: (struct command) cmd1, cmd2, cmd3 members changed to + word[3]. ncmd removed. + (var empty_string) Removed. + (var cmd_table) Declaration updated. + (var cmdtab) Removed. + (cmp_command) Removed. + (split_words) Rewritten to use strtok_r(). + (init_cmd_parser) Renamed cmd_init(). Rewritten. + (find_command) Removed. + (FILE_TYPE_okay) Rewritten. + (cmd_parse) Rewritten. Semantics of the return value of command + handlers has changed: they must now return one of the new CMD_* + enumerals, rather than a magic value. This meant that all + commands had to be modified, and they were. + (figure_out_command) New function. + + * command.def: Add CORRELATIONS, PEARSON CORRELATIONS. Add + #defines for INIT, INPU, etc. + + * command.h: New CMD_* enum series. + (cur_proc) Make const char *, not char *. + (cmd_init) Prototype. + (cmd_parse) Ditto. + + * common.c: Removed. + + * common.h: Removed. + + * correlations.q: New file. + + * crosstabs.q: Migrate from arenas to pools. Migrate to new-style + q2c. + (custom_tables) Renamed crs_custom_tables(). + (custom_variables) Renamed crs_custom_variables(). + (calc_integer) Add in some `const' qualifiers. + (table_value_missing) Change from a_string to len_string. + (float_M_suffix) Change from a_string to len_string. + + * data-in.c: Rewritten. All references to + parse_string_as_format() changed to data_in(). + + * data-in.h: New file. + + * data-list.c: Change DLS_* from #define's to enums. Move from + rpd_msg() to tmsg(). + (RPD_ERR) New #define. + (do_reading) Change dfm_push_cust() to dfm_push(), pop_cust() to + dfm_pop(). + (read_from_data_list_fixed) Change from old + parse_string_as_format() to new data_in(). + (read_from_data_list_free) Ditto. + (read_from_data_list_list) Ditto. + (cmd_repeating_data) Modify approach to checking for end of + command. + (rpd_msg) Removed. + (rpd_parse_record) Change from old parse_string_as_format() to new + data_in(). Change from old convert_format_to_string() to new + data_out(). + (read_one_set_of_repetitions) Change dfm_push_cust() to + dfm_push(), pop_cust() to dfm_pop(). + + * data-out.c: Rewritten. All references to + convert_format_to_string() changed to data_out(). + + * descript.q: Migrate to new q2c. + (cmd_descriptives) Removed. + (internal_cmd_descriptives) Renamed cmd_descriptives (). + (custom_variables) Renamed dsc_custom_variables(). + + * dfm.c: (struct dfm_fhuser_ext) `ln' removed. All references + removed. + (open_file_r) Initialize h->where.line_number. Migrate to new + struct string. + (open_file_w) Initialize h->where.line_number. + (read_record) Change from ext->ln to h->where.line_number. + Migrate to struct string. + (dfm_put_record) Rephrased. + (dfm_push_cust) Renamed dfm_push(), rewritten. + (dfm_pop) New function. + + * error.c: All references updated. + (glob var error_count) Renamed err_err_count. + (glob var warning_count) Renamed err_warning_count. + (glob var error_already_flagged) Renamed err_already_flagged. + (glob var verbosity) Renamed err_verbosity. + (glob var cust_fn) Removed. + (glob var cust_ln) Removed. + (static var file_loc) New. + (static var nfile_loc) New. + (static var mfile_loc) New. + (tmsg) New function. + (push_cust) Removed. + (pop_cust) Removed. + (msg) Rewritten. + (static var terminating) Removed. + (failure) Renamed err_failure(). + (hcf) Renamed err_hcf(). + (err_push_file_locator) New function. + (err_pop_file_locator) New function. + (err_location) New function. + (check_error_count) Renamed err_check_count(). + (vmsg) Renamed err_vmsg(). Interface changed. + (verbose_msg) Removed. + (err_cond_fail) New function. + (error_break) Renamed err_break(). + + * error.h: All references updated. + (enum MSG_CLASS_COUNT) Renamed ERR_CLASS_COUNT. + (enum ERR_CLASS_MASK, ERR_VERBOSITY_SHIFT, ERR_VERBOSITY_MASK) + New. + (struct file_locator) New. + (struct error) New. + (macro verbose_msg) Removed. + (macro cond_fail) Removed. + + * expr-opt.c: (evaluate_tree) sizeof(char) == 1. + + * expr-prs.c: Reorganized. All references updated. + (exprtypename) Renamed expr_type_name(). + (typename) Renamed type_name(). + (free_expression) Renamed expr_free(). + (parse_expression) Renamed expr_parse(). Uses new type_check() + function. + (init_functab) Renamed init_func_tab(). + (type_check) New function. + (parse_or) Rewritten to use new allocate_nonterminal() and + append_nonterminal_arg() functions. + (parse_and) Ditto. + (parse_not) Ditto. + (parse_rel) Ditto. Also simplified logic. + (parse_add) Ditto. + (parse_mul) Ditto. + (parse_neg) Ditto. + (parse_exp) Ditto. + (SYSMIS_func) Ditto. + (VALUE_func) Rephrased. + (CONCAT_func) Fix memory leak by replacing free by free_node on + lossage. + (generic_str_func) Ditto. + (parse_function) Ditto. Also rephrasings. Uses bsearch() to find + function. + (allocate_nonterminal) New function. + (append_nonterminal_arg) New function. + (static func_tab[]) Now at file level. + (cmp_func) Moved. + (init_func_tab) Moved. Now just uses qsort() to sort func_tab[]. + + * expr.h: (enum series OP_*) Moved to exprP.h. + (OP_* defines) Ditto. + (struct op_desc) Ditto. + (global ops[]) Ditto. + (struct num_con_node) Ditto. + (struct str_con_node) Ditto. + (struct var_node) Ditto. + (struct lag_node) Ditto. + (struct casenum_node) Ditto. + (struct nonterm_node) Ditto. + (union any_node) Members renamed. + (struct sys_node) Removed. + (struct val_node) Removed. + (operator typedef) Removed. + (typedef exprtype) Removed. + (enum series EX_*) Moved to exprP.h. + (struct expression) Ditto. Also renamed a lot of the members. + (PXP_* defines) Changed to enums. + (free_node prototype) Moved to exprP.h. + + * file-handle.h: (struct file_handle) New member `where'. + + * file-handle.q: Migrated to new q2c format. + (prepend_current_directory) Removed (dead code). + (cmd_file_handle) Incorporated all of internal_cmd_file_handle(). + (fh_get_handle_by_filename) Removed dead code. + Set new `where' member. + + * file-type.c: (file_type_source_read) References to + parse_string_as_format() changed to data_in(). + dfm_push_cust()/pop_cust() changed to dfm_push()/dfm_pop(). + + * filename.c: All references updated. + (init_filename) Renamed fn_init(). + (expand_line) Removed. + (macro EXPAND_LINE) Removed. + (interp_vars) Renamed fn_interp_vars(). Now uses st_*() instead + of custom functions. + (gnu_getcwd) Renamed fn_get_cwd(), rewritten. + (tilde_expand) Renamed fn_tilde_expand(), uses ds_*(). + (normalize_filename) Renamed fn_normalize(). + (search_path) Renamed fn_search_path(), rewritten. + (prepend_dir) Renamed fn_prepend_dir(). + (blp_getenv) Renamed fn_getenv(). + (blp_dirname) Renamed fn_dirname(). + (fn_basename) New function, not used. + (absolute_filename_p) Renamed fn_absolute_p(). + (is_special_filename) Renamed fn_special_p(). + (file_exists) Renamed fn_exists_p(). + (readlink_malloc) Renamed fn_readlink(). + (getenv_default) Renamed fn_getenv_default(). + (open_file) Renamed fn_open(). + (close_file) Renamed fn_close(). + (open_file_ext) Renamed fn_open_ext(). + (close_file_ext) Renamed fn_close_ext(). + + * font.h: Migrate from arenas to pools. + + * format.c: (parse_format_specifier_name) Deal with ds_* strings. + + * frequencies.g: Migrate from arenas to pools. + + * frequencies.q: Migrate to new q2c version. Migrate from arenas + to pools. + + * getline.c: All references updated. + (global getl_buf) Changed from char * to struct string. + (static getl_include_path) Ditto. + (global getl_buf_len) Removed. + (global getl_buf_size) Removed. + (getl_include_path) Deal with new getl_buf, getl_include_path. + (getl_uninitialize) New function. + (getl_get_current_directory) Rewritten. + (getl_clear_include_path) Rewritten. + (getl_add_include_dir) Rewritten. + (getl_add_file) Assertion fixed. + (getl_add_virtual_file) Change initial value of `remaining_loops' + from 2 to 1. + (welcome) Rewritten. + (handle_line_buffer) Make static. Change logic to make + getl_add_virtual_file() change sensible. Use ds_*() strings. + (getl_read_line) Use ds_*() strings. Implement SET ECHO. + (getl_close_file) Moved. + (getl_location) New function. + + * getline.h: All references updated. + (macro curln) Removed. + (macro curfn) Removed. + (macro am_interactive) Renamed getl_am_interactive. + (macro am_reading_script) Renamed getl_reading_script. + + * glob.c: (global fmt_parse_ignore_error) Removed. + (init_glob) Use locale_dir not LOCALEDIR. Use feholdexcept() on + systems that support it (C99). Turn off SET ECHO by default. No + necessary julcal initialization anymore. + + * groff-font.c: Migrate from arenas to pools. + (groff_read_font) Use err_push_file_locator(). + (groff_read_DESC) Ditto. + (font_msg) Use tmsg(). + + * hash.c: (hsh_sort) Fix debug code. + [GLOBAL_DEBUGGING] Include stdio.h. + + * hash.h: (macro force_hsh_insert) Rephrase. + + * heap.c: Rewritten. + + * heap.h: Rewritten. + + * html.c: (html_option) Change from outp_value to struct string. + (postopen) Change from curfn to getl_location(). + (escape_string) Remove rich-text code. Signature changed. + (output_tab_table) Switch from a_string to struct len_string. + Remove rich text support. + + * lexer.c: All references updated. Largely rewritten. Major + changes listed below. Removed tagged quote support. Adapted to + struct string tokstr. + (global tokstr) Changed to struct string. + (global tokstr_size) Removed. + (global tokstr_len) Removed. + (global tokid) New. + (global tokint) Removed. + (global toklongstr) Removed. + (C* defines) Removed. + (static tbl[]) Removed. + (static id[]) Removed. + (static une[]) Removed. + (discard_line) Renamed lex_discard_line(). + (get_entire_line) Renamed lex_entire_line(). + (get_rest_of_line) Renamed lex_rest_of_line(). + (get_dotted_rest_of_line) Merged into lex_rest_of_line(). + (make_hexit) Removed. + (syntax_error) Renamed lex_error(). Return value removed. + (get_token_representation) Renamed lex_token_representation(). + (putback) Renamed lex_put_back(). + (putfwd) Renamed lex_put_forward(). + (convert_negative_to_dash) Renamed lex_negative_to_dash(). + (set_prog) Renamed lex_set_prog(). + (init_lex) Renamed lex_init(). + (reset_eof) Renamed lex_reset_eof(). + (lookahead) Renamed lex_look_ahead(). + (check_id) Rewritten. + (yylex) Renamed lex_get(), rewritten. + (lex_end_of_command) New function. Many commands were rephrased + using this. + (lex_integer_p) New function. Replaces compare of tokint against + NOT_LONG. + (lex_integer) New function. Replaces tokint. + (match_tok) Renamed lex_match(). + (match_id) Renamed lex_match_id(). + (match_int) Renamed lex_match_int(). + (force_match_id) Renamed lex_force_match_id(), added return value. + (force_match) Renamed lex_force_match(), added return value. + (force_string) Renamed lex_force_string(), added return value. + (force_int) Renamed lex_force_int(), added return value. + (lex_id_match_len) New function. + (id_match) Renamed lex_id_match(), rewritten. + (get_line) Renamed lex_get_line(). + (preprocess_line) Renamed lex_preprocess_line(). + (tokname) Renamed lex_token_name(). + (bin_value_func) Removed. + (oct_value_func) Removed. + (hex_value_func) Removed. + (unexpected_eof) New function. + (convert_numeric_string_to_char_string) New function. + (parse_string) Rewritten, signature changed. + (add_tokstr_char) Removed. + (add_tokstr_unsigned) Removed. + (add_tokstr_string) Removed. + (parse_tagged_quote) Removed. + (skip_comment) Renamed lex_skip_comment(). + + * lexer.h: All references updated. + (macro is_id1) Renamed CHAR_IS_ID1. + (macro is_idn) Renamed CHAR_IS_IDN. + (token names ID, NUM, STRING, STOP, ... WITH, EXP) Renamed with + prefix T_: T_ID, T_NUM, T_STRING, T_STOP, ... T_WITH, T_EXP. + (macro get_token) Removed. + (macro id_match) Removed. + (macro force_match_id) Removed. + (macro force_match) Removed. + (macro force_string) Removed. + (macro force_int) Removed. + (macro force_num) Removed. + (macro force_id) Removed. + + * lexerP.h: Removed. + + * list.q: Migrated to new q2c format. + (write_line) Deal with struct len_string. + (write_varname) Ditto. + (write_fallback_headers) Ditto. + + * magic.c: New file, incorporating the following global variables + previously in other files: endian, second_lowest_value. And both + of those are conditional on #define's. + + * magic.h: New file, incorporating the following global variable + declarations: endian, second_lowest_value, and the following macro + declarations: NOT_DOUBLE, NOT_LONG, NOT_INT. + + * main.c: Added declarations of pgmname, finished, curdate, + start_interactive. + (main) Call new parse_script() function. + (parse_script) New function. + (execute_command) New function. + (dump_token) Removed. + (handle_error) New function. + + * matrix.c: New file. + + * matrix.h: New file. + + * matrix-data.c: Migrated from arenas to pools. + (mget_token) Change from parse_string_as_format() to data_in(). + + * means.q: Migrate to new q2c. + (custom_tables) Renamed mns_custom_tables(). + (custom_crossbreak) Renamed mns_custom_crossbreak(). + (custom_variables) Renamed mns_custom_variables(). + + * mis-val.c: (static var width) Changed from `int' to `size_t'. + (parse_varnames) Prototype. + (parse_numeric) Rephrasings. + (parse_alpha) Adapt to new struct string tokstr. + + * misc.c: (intlog10) Rewritten. + (spacing) Removed. + (ansi_rand) Renamed real_rand(), moved into random.c. + (ansi_srand) Renamed real_srand(), moved into random.c. + (setup_randomize) Moved to random.c. + (rand_uniform) Ditto. + (rand_normal) Ditto. + (rand_simple) Ditto. + (get_config_line) Removed. + (reverse) Removed (dead code). + + * misc.h: (macro SET_BIT) Moved to bitvector.h. + (macro CLEAR_BIT) Ditto. + (macro TEST_BIT) Ditto. + (macro SET_BIT_TO) Ditto. + (macro BIT_INDEX) Ditto. + + * output.c: (outp_read_devices) Move to err_push_file_locator() + from push_cust(). Use struct string. + (expand_op_tokstr) Removed. + (static var op_tokstr) Changed to struct string. + (static var op_tokstr_size) Removed. + (tokener) Rephrasings. Use struct string. + (parse_options) Use struct string. + (destroy_driver) Fix assertion. + (outp_get_paper_size) Move to err_push_file_locator(). + [0] Removed dead code. + (outp_string_width) Move to len_string. + + * output.h: Comment fixes. + (TAG_* enum series) Removed. + (struct outp_value) Removed. + (enum OUTP_T_FANCY) Removed. + (struct outp_text) `s' changed from a_string to len_string. + (struct outp_class) `option' change arg 3 from outp_value to + struct string. + + * pfm-read.c: (corrupt_msg) Rewritten. + + * pfm-write.c: (bufwrite) Fix assertion. + + * pool.c: New file, reference version. + + * pool.h: New file, reference version. + + * postscript.c: (ps_font_sizes) Fix assertion. + (ps_option) Change arg 3 from outp_value to struct string. + Adapt to struct string. + (macro output_line) Removed. + (macro add_string) Removed. + (output_encodings) Adapted to struct string. Moved to + err_push_file_locator(). + (find_encoding_file) Fix assertion. + (read_ps_encodings) Move to err_push_file_locator(). + (postopen) Use getl_location() instead of curfn. + (out_text_plain) Move to len_string. + (text) Ditto. Remove rich text support. + + * print.c: (cmd_print) Remove now-unneeded resource cleanup code. + (cmd_print_eject) Ditto. + (cmd_write) Ditto. + (internal_cmd_print) Now cleans up after itself. Uses + fh_parse_file_handle() now. + (cmd_print_space) Use PXP_NUMERIC to type-check. + + * q2c.c: Overhauled. Removed _("") i18n support. All references + updated. All output functions updated to handle structures rather + than local or static variables. Adapt to new PSPP lex_*() + functions. + (macro _) Removed. + (macro N_) Removed. + (macro MAX_N_SBC) Removed. + (global bare) Removed. + (enum STRING) Renamed T_STRING. + (enum ID) Renamed T_ID. + (get_buffer) Buffer size increased. + (strlower) Renamed st_lower(), rephrased. + (strupper) Renamed st_upper(), rephrased. + (skip_ws) New function. + (get_line) Don't special-case any types of lines (like those + beginning with ! or $, for instance). + (get_token) Renamed lex_get(). Rephrased. + (static var `prefix') New. + (parse) New function. + (parse_setting) Minor rephrasing. + (dump_specifier_vars) Ditto. + (make_identifier) Put null terminator on identifier, duh. + (dump_vars) Renamed dump_declarations(). Never indent. Never + static. Output changed entirely. + (dump_specifier_init) Rephrase. + (dump_vars_init) No index variable needed. Other modifications. + (dump_parser) Don't parse command name. Do dump functions instead + of just code fragments. + (dump_free) Dump function instead of code fragment. + (recognize_directive) New function. + (main) Use recognize_directive(). Don't rely on magic $ line + beginning: instead, parse comments. Update list of headers. + + * random.c: New file, containing the following functions: + real_rand(), real_srand(), setup_randomize, shuffle, rand_uniform, + rand_normal, rand_simple. + + * random.h: New file. + + * recode.c: (cmd_recode) Merge internal_cmd_recode() into this + function. `max_src_width', `max_dst_width' changed to size_t. + (internal_cmd_recode) Removed. + (parse_dest_spec) Merge similar cases. + (parse_src_spec) Add assertion. + + * repeat.c: (recognize_keyword) New function. + (internal_cmd_do_repeat) Parse and handle PRINT keyword on END + REPEAT. Improve recognition of END REPEAT (use + recognize_keyword()). Move from curfn to getl_location(). Use + struct string. + + (perform_DO_REPEAT_substitutions) Adapt to struct string. + + * set.q: Adapt to new q2c. + (cmd_set) Range-check some values better. + (custom_blanks) Renamed stc_custom_blanks(). + (custom_length) Renamed stc_custom_length(). + (custom_results) Renamed stc_custom_results(). + (custom_seed) Renamed stc_custom_seed(). + (custom_width) Renamed stc_custom_width(). + (custom_format) Renamed stc_custom_format(). + (custom_journal) Renamed stc_custom_journal(). + (custom_color) Renamed stc_custom_color(). + (custom_listing) Renamed stc_custom_listing(). + (custom_disk) Renamed stc_custom_disk(). + (custom_log) Renamed stc_custom_log(). + (custom_rcolor) Renamed stc_custom_rcolor(). + (custom_viewlength) Renamed stc_custom_viewlength(). + (custom_workdev) Renamed stc_custom_workdev(). + + * settings.h: Not necessary to include format.h any longer. + + * sfm-read.h: (macro bswap_int32) Moved here from sfmP.h. + (corrupt_msg) Rewritten. + + * sort.c: Adapt to rewritten heap ADT. + + * str.c: (aa_strcpy) Removed. + (ab_strcpy) Removed. + (ac_strcpy) Removed. + (ba_strcpy) Removed. + (bb_strcpy) Removed. + (ca_strcpy) Removed. + (aa_strdup) Removed. + (aa_strdupcpy) Removed. + (ba_strdup) Removed. + (sa_strdup) Removed. + (memrev) Renamed mm_reverse(). + (memrmem) Renamed mm_find_reverse(). + (cmp_str) Renamed st_compare_pad(). + (strmaxcpy) Removed. + (strbarepadcpy) Renamed st_bare_pad_copy(), signature changed. + (strbarepadlencpy) Renamed st_bare_pad_len_copy(), signature + changed. + (strpadcpy) Renamed st_pad_copy(), signature changed. + (blpstrset) Removed. + (ds_create) New function. + (ds_init) New function. + (ds_replace) New function. + (ds_destroy) New function. + (ds_clear) New function. + (ds_extend) New function. + (ds_shrink) New function. + (ds_truncate) New function. + (ds_length) New function. + (ds_size) New function. + (ds_value) New function. + (ds_end) New function. + (ds_concat) New function. + (ds_concat_buffer) New function. + (ds_printf) New function. + (ds_putchar) New function. + (ds_getline) New function. + (ds_get_config_line) New function derived from the old + misc.c:get_config_line(). + (ls_create) New function. + (ls_create_buffer) New function. + (ls_init) New function. + (ls_shallow_copy) New function. + (ls_destroy) New function. + (ls_null) New function. + (ls_null_p) New function. + (ls_empty_p) New function. + (ls_length) New function. + (ls_value) New function. + (ls_end) New function. + + * str.h: Reformatted. + (struct a_string) Removed. + (struct b_string) Removed. + (struct c_string) Removed. + (struct len_string) New. + (struct string) New. + (macro as_streq) Removed. + (macro bs_streq) Removed. + (macro cs_streq) Removed. + (macro sa_streq) Removed. + (macro sb_streq) Removed. + [__GNUC__] (inline function ds_putchar) New function. + [__GNUC__] (inline function ds_length) New function. + [__GNUC__] (inline function ds_value) New function. + [__GNUC__] (inline function ds_end) New function. + + * sysfile-info.c: (cmd_sysfile_info) Rephrased. + (display_vectors) Fix missing i18n. + + * t-test.q: Migrate to new q2c. + + * tab.c: Migrate from arenas to pools. + (tab_create) Use struct len_string. + (tab_realloc) Ditto. + (text_format) Ditto. + (tab_joint_text) Ditto. + (tab_natural_width) Remove rich text support. + (tab_natural_height) Ditto. + (tab_output_text) Handle TAT_FIX. + (tab_raw) Change arg from a_string to len_string. + (tabi_driver) Fix assertion. Use struct len_string. + (render_strip) Use struct len_string. Remove rich text support. + Add `const' qualifiers. + + * tab.h: (enum TAB_RICH) Remove. + (enums TAB_COL_NONE, TAB_COL_DONE) New. Where appropriate, + SOM_COL_* updated to read TAB_COL_*. + (struct tab_table) Change arena to pool. Change a_string to + len_string. + + * temporary.c: (restore_dictionary) Rewrite Checker code. + + * var.h: (macros MAX_SHORT_STRING, MIN_LONG_STRING, SYSMIS, + LOWEST, HIGHEST) Moved here from common.h. + (typedef any_trns) Removed. All references changed to `struct + trns_header'. + + * vars-atr.c: (force_create_variable) Fix assertion. + (force_dup_variable) Fix assertion. + +Thu Jun 3 18:40:42 1999 Ben Pfaff + + Using alphanumeric variables in functions under AGGREGATE + segfaulted. Fixed. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * aggregate.c: (parse_aggregate_functions) When setting the + FSTRING bit, also allocate memory for the `string' member of + agr_next. + (free_aggregate_functions) Free iter->string. Don't use the + non-function bits when indexing the array of functions. + [DEBUGGING] (debug_print) Don't use the non-function bits when + indexing the array of functions. + +Sun May 30 00:00:54 1999 Ben Pfaff + + Under certain circumstances, the final case would be omitted from + the results of an AGGREGATE operation. Fixed. Thanks to Dr. Dirk + Melcher for reporting this bug. + + * aggregate.c (agr_00x_end_func): Increment number of cases in + sink before writing case. For streams that keep track of how many + cases there are based on this value, this means that the last case + will be read in on the next stream read. + +Sat May 29 22:03:31 1999 Ben Pfaff + + Undefined behavior was invoked by referencing a freed pointer. + + * vfm.c (memory_stream_write): Free pointer *after* checking for + non-null status. + +Sat May 29 22:02:22 1999 Ben Pfaff + + A wrong record size was displayed when paging the active file to + disk. + + * vfm.c: (memory_stream_write) Fix off-by-one error. + +Sat May 29 21:50:26 1999 Ben Pfaff + + Not having enough temporary space for sorting caused a core dump. + Fixed. + + * sort.c: (allocate_cases) Initialize i. + +Sat May 29 21:40:54 1999 Ben Pfaff + + Syntax errors in function descriptions on AGGREGATE caused core + dumps. Fixed. + + * aggregate.c (cmd_aggregate): Don't free agr_dict after calling + free_aggregate_functions(), since that function already frees + agr_dict. + +Sat May 29 21:06:10 1999 Ben Pfaff + + A null pointer was dereferenced, causing a core dump, when + PERCENTILES was specified on FREQUENCIES. This fixes the problem, + but PSPP still doesn't calculate percentiles. Thanks to Regnor + Jernsletten for reporting this problem. + + * arena.c: (arena_malloc) If the arena hasn't been initialized + already, initialize it. + +Sat May 29 20:47:29 1999 Ben Pfaff + + * Makefile.cygwin: New file supplied by Hankin + for compilation with Cygnus Windows B20. Not used by other + systems. + +Sat May 29 20:36:04 1999 Ben Pfaff + + SORT always sorted in ascending order. Fixed. Thanks to Dr. Dirk + Melcher for reporting this bug. + + * sort.c: (compare_case_lists) Reverse sense of comparison if + sorting in descending order. + (compare_record) Ditto. + +Tue Mar 9 13:18:54 1999 Ben Pfaff + + SPLIT FILE with a string variable caused a core dump. Fixed. + + * vfm.c: If the variable is a string then make a temporary value + struct pointing to it. The underlying problem is a lot bigger + than this (see TODO) but this is a stopgap for the simple case at + least. + +Tue Mar 9 13:15:53 1999 Ben Pfaff + + Nested INCLUDEs didn't work. Fixed. + + * getline.c: (getl_include) Set first_line to NULL in allocated + structure. + +Tue Mar 9 13:13:46 1999 Ben Pfaff + + The MATCH FILES procedure set the values of variables not present + to 0. It should have been SYSMIS. This is now fixed. + + * get.c: (mtf_delete_file_in_place) Replace 0.0 by SYSMIS. + +Tue Mar 9 12:52:23 1999 Ben Pfaff + + The REMARK command was too aggressive about skipping lines. It + didn't like being the last command in a file. + + * command.c: (cmd_remark) Call get_entire_line() instead of + get_line(). + +Tue Mar 9 12:48:05 1999 Ben Pfaff + + Comment parsing wasn't consistent with the rest of the code in its + idea of where one command ends and another starts. This meant + that sometimes commands would be mysteriously ignored. Thanks to + Dr. Dirk Melcher for reporting this bug. + + * command.c: (parse_cmd) Hand off comment parsing to new function + skip_comment() in lexer.c. + * lexer.c: (skip_comment) New function. + +Wed Jan 20 20:22:07 1999 Ben Pfaff + + The TABLE subcommand on MATCH FILES worked only erratically at + best. This fixes it. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * get.c: (mtf_compare_BY_values) When comparing string values, a + difference of 1 is still a difference :-) + (mtf_processing) Inverted TABLE reading logic fixed. Also don't + advance TABLE files automatically when matched. Comment fixes. + +Tue Jan 19 22:32:31 1999 Ben Pfaff + + VARIABLE LABELS rejected a slash before the first variable + specification, contradicting the documentation. Thanks to Walter + M. Gray for reporting this bug. + + * var-labs.c: (cmd_variable_labels) Ignore a leading slash in + command specification. + +Tue Jan 19 22:29:54 1999 Ben Pfaff + + Because of an incorrect optimization in memory allocation, + CROSSTABS sometimes segfaulted when asked to output multiple + tables. Thanks to Walter M. Gray for + reporting this bug. + + * crosstabs.q: (postcalc) New variables maxcols, maxcells, which + are passed to output_pivot_table() for its use. + (output_pivot_table) Instead of assuming the number of columns is + constant, keep track with maxcols. In general mode, use maxcells + to determine whether more matrix cells need to be allocated. + +Tue Jan 19 22:27:46 1999 Ben Pfaff + + CROSSTABS didn't display value labels for column and row + variables. Thanks to Walter M. Gray for + reporting this bug. + + * crosstabs.q: (table_value_missing) If the specified value has a + value label for this variable, then show it instead of the raw + value. + (display_dimensions) Delegate display of value_labels to + table_value_missing. + +Mon Jan 18 20:04:06 1999 Ben Pfaff + + WRITE didn't write line ends. Fixed. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * print.c: (print_trns_proc) Write (CR/)LF if PRINT is used _or_ + if the file isn't declared as binary. + +Mon Jan 18 19:56:45 1999 Ben Pfaff + + MATCH FILES corrupted memory and dumped core on some syntax + errors. Fixed. + + * get.c: (cmd_match_files) Set file->handle to NULL before + jumping to lossage. + (mtf_free_file) Don't free a null dictionary. + +Mon Jan 18 19:27:57 1999 Ben Pfaff + + MATCH FILES should set numeric values not available to the + system-missing value, not to 0. Thanks to Dr. Dirk Melcher + for reporting this bug. + + * get.c: (mtf_processing) Set unused records to system-missing, + not 0. + +Mon Jan 18 15:06:46 1999 Ben Pfaff + + KEEP didn't work properly on the SAVE procedure. Fixed. Thanks + to Ralf Geschke for reporting this bug. + + * temporary.c: (save_dictionary) Initialize var_by_name AVL tree + in newly created dictionary, and add each copied variable to the + tree. + +Mon Jan 18 15:04:48 1999 Ben Pfaff + + Memory leak fix. + + * get.c: (trim_dictionary) Free variable list for KEEP after + finishing with it. + +Mon Jan 18 12:57:36 1999 Ben Pfaff + + Some systems didn't like the way open_file was coded. Thanks to + Hankin for pointing this out. + + * filename.c: (open_file) Don't try to store stdin, stdout, + stderr as part of an array, because that doesn't always work. + +Mon Jan 18 12:53:27 1999 Ben Pfaff + + The SAVE procedure didn't save long string variables properly. + Fixed by this patch. Thanks to Hankin + for this patch. + + * sfm-write.c: (write_variable) Fix off-by-one error in writing + out variable pad records. + +Tue Jan 5 14:29:27 1999 Ben Pfaff + + Previously, if PRINT SPACE were given a negative argument, it + would report an error, then spin in an (almost) infinite loop. + This fixes that behavior. + + * print.c: (print_space_trns_proc) After reporting a negative + argument, set number of lines to print to 1. + +Tue Jan 5 13:59:55 1999 Ben Pfaff + + SPSS 8.0 outputs some new record types in its system files, and it + allows longer value labels. Accept these system files. + + * sfm-read.c: (sfm_read_dictionary) Ignore record type 7 subtype + 11 emitted by SPSS 8.0. + +Tue Jan 5 13:55:50 1999 Ben Pfaff + + The LIST procedure was too conservative in allocating space for + buffers, which caused a bug that only showed up with very long + output variables. Thanks to Hankin for this + bug report. + + * list.q: (determine_layout) Allocate 1022 bytes instead of 256. + +Tue Jan 5 13:34:34 1999 Ben Pfaff + + Typo meant string format specifiers weren't checked properly. I + think that Hankin sent me this report, but I'm + willing to be corrected on this point. + + * format.c: (check_string_specifier) Fix obvious typo. + +Tue Jan 5 12:50:42 1999 Ben Pfaff + + Using $CASENUM in an expression didn't work. Here's a fix. + Thanks to Dirk Melcher for reporting this + bug. + + * expr-evl.c: (evaluate_expression) Add OP_CASENUM case. + + * expr-opt.c: (dump_node) OP_CASENUM is acceptable. + +Tue Jan 5 12:47:48 1999 Ben Pfaff + + The changes in 0.2.1 to fix DATA LIST FREE parsing broke some + other behavior, *sigh*. This patch hopefully fixes that. This + time I've actually tested it. + + Thanks to Hankin for reporting this bug. + + * data-list.c: (read_from_data_list_free, + read_from_data_list_list) Call parse_string_as_format() directly + without mucking around with the field width. + +Tue Jan 5 12:31:19 1999 Ben Pfaff + + Occasionally, you may encounter a script that wants to be + interpreted in interactive mode. Make -i emulate this behavior to + allow such scripts to be executed with PSPP. + + Thanks to Hankin for reporting this behavior. + + * cmdline.c: (pre_syntax_message[]) Update -i description. + + * lexer.c: (preprocess_line) When getl_interactive is 2 (i.e., + when -i is given on the command line) don't treat unindented lines + as starting a new command. + +Tue Jan 5 12:30:10 1999 Ben Pfaff + + In conjunction with egcs 1.1.1, Checker emits some bogus warnings, + mostly caused by local initialized aggregates. After egcs is + fixed upstream these can be removed, but for now they're not a big + deal. + + * ascii.c: (ascii_postopen_driver) Checker chokes on local + initialized arrays. Avoid this. + + * sfm-write.c: (sfm_write_dictionary) Don't use a local + initialized struct. + +Tue Jan 5 12:07:24 1999 Ben Pfaff + + egcs 1.1.1 has some new warnings relative to gcc 2.8.1, which the + following changes avoid. Currently I compile sources with egcs + 1.1.1 and gcc 2.7.2.3 before sending them out. + + * apply-dict.c: (apply_dict) Use new avl_traverser_init() macro. + + * ascii.c: (option_tab[]) Initialize all struct members. + + * avl.h: (avl_traverser_init) New macro. + + * command.c: (DEFCMD, UNIMPL macros, cmd_table[]) Initialize all + struct members. + + * crosstabs.q: (enum_var_values) Use new hsh_iterator_init() + macro. + + * hash.c: Comment fix. + + * hash.h: (hsh_iterator_init) New macro. + + * html.c: (option_tab[]) Initialize all struct members. + + * pfm-write.c: (write_value_labels) Use new avl_traverser_init() + macro. + + * postscript.c: (option_tab[]) Initialize all struct members. + (output_encodings, preclose, dump_lines) Use new + hsh_iterator_init() macro. + + * sfm-write.c: (write_value_labels) Use new avl_traverser_init() + macro. + + * sysfile-info.c: (describe_variable) Use new avl_traverser_init() + macro. + +Thu Nov 19 12:32:45 1998 Ben Pfaff + + * data-in.c: Examined each of the parsing functions to make sure + that they wouldn't dump core if they were passed a string of the + wrong length, since now the DATA LIST FREE/LIST routines don't + check for field width before passing it to the data parser. + (parse_RBHEX, parse_AHEX) Reject odd length input. + (parse_string_as_format) Reject input that's too short or too + long. + + * data-list.c: Before, the DATA LIST FREE/LIST routines would pad + a field to its entire declared output width then pass it to the + data-in parsing routines. This contradicted the documented + behavior. This is fixed in these changes. Thanks to Mark H. Wood + . In addition, this fixes a few more details of + free-format parsing that differed from SPSS. + (cut_field) Commas and spaces are treated identically. Returns + the proper column instead of a fixed 1 value. + (parse_field) Removed. + (read_from_data_list_free, read_from_data_list_list) Call + parse_string_as_format directly instead of parse_field. + + * heap.c: (heap_delete) Stylistic fixes. + +Sun Aug 9 11:12:13 1998 Ben Pfaff + + * loop.c: (loop_2_trns_proc) Formatting fix. + + * sel-if.c: (cmd_filter) Set FILTER_before_TEMPORARY. + + * var.h: (glob var FILTER_before_TEMPORARY) New global var. + + * vfm.c: (macro FILTERED) New. + (static var filter_var) New. + (process_active_file_write_case) Use FILTERED. + (setup_filter) Set filter_var. + (close_active_file) Delete the filter if not + FILTER_before_TEMPORARY. + (procedure_write_case) Use FILTERED. + +Sat Aug 8 00:20:14 1998 Ben Pfaff + + * crosstabs.q: Changed /PIVOT={ON,OFF} to /FORMAT={PIVOT,NOPIVOT}. + + * data-in.c: (parse_day_count) Message fix. + (parse_month) Style fix. + + * data-list.c: (struct data_list_pgm) New member eof. + (cmd_data_list) Init eof to 0. + (do_reading) Implement the /END subcommand and read-past-eof + checking. + + * do-if.c: Include stdio.h when debugging. + (cmd_else_if) Make sure the command is .-terminated. + + * glob.c: (init_glob) Capitalize the command prompt. + + * inpt-pgm.c: (end_case_trns_proc) Debugging message. + (end_file_trns_proc) Debugging message. + + * loop.c: (internal_cmd_loop) Make it work when there's no loop + index! + (loop_2_trns_proc) Enable MXLOOPS (why was this disabled?) + + * main.c: (dump_token) Make kwtab[] const. + + * set.q: Spelling, comment fixes. + + * sysfile-info.c: (cmd_display) DISPLAY VECTORS not DISPLAY + VECTOR. + + * vars-prs.c: (fill_all_vars) Style fix. + + * vfm.c: (index_to_varname) Return const. + +Tue Aug 4 23:49:23 1998 Ben Pfaff + + * Changes in many source files for partial -ansi -pedantic and + no-debugging compliance: Remove trailing common in enum + declarations; add `unused' attributes; insert some appropriate + casts. + + * cmdline.c: (parse_command_line) Add new --testing-mode flag. + + * command.c: (shell) Make static. + (run_command) Make static. + + * data-list.c: (dump_fixed_table) Remove use of local_strdup(). + + * dfm.c: (cmd_begin_data) I18n fix. + + * error.c: (verbose_msg) Define if __STRICT_ANSI__. + + * error.h: (macro verbose_msg) Define if __STRICT_ANSI__. + + * expr-opt.c: (evaluate_tree) Don't initialize local arrays if + __STRICT_ANSI__. + + * file-handle.q: Don't prepend the source file directory name to + the data file name. (Ongoing issue.) + (prepend_current_directory) Comment out. + (internal_cmd_file_handle) Don't call prepend_current_directory(). + (fh_get_handle_by_filename) Ditto. + + * filename.c: Append zero byte to readlink() return value. + + * getline.c: (getl_read_line) I18n fix. + + * lexer.h: Don't use gcc features if __STRICT_ANSI__. + + * misc.h: Don't use gcc features if __STRICT_ANSI__. + + * pfm-write.c: (bufwrite) Don't try to increment a void * pointer + directly. + + * postscript.c: (output_encodings) Don't use local_strdup(). + (postopen) Ditto. + + * print.c: Don't use gcc features if __STRICT_ANSI__. + + * q2c.c: (dump_vars) Don't put a , at the end of the last enum. + + * recode.c: (parse_src_spec) Fully brace nested if's. + + * set.q: (global var set_testing_mode) New var. + +Wed Jul 29 22:01:44 1998 Ben Pfaff + + * ascii.c: Add some more `unused' attributes that only come into + play when NDEBUG is defined. + (ascii_close_page) Set s_len when reallocating s. + + * crosstabs.q: (delete_missing) New function. + (output_pivot_table) Call delete_missing() if /MISSING=REPORT. + (make_summary_table) Create summary table reallocable. + + * postscript.c: Add more `unused' attributes as above. + + * tab.c: (tab_create) [GLOBAL_DEBUGGING] Set reallocable member. + (tab_realloc) [GLOBAL_DEBUGGING] Assert that table is reallocable. + + * tab.h: (struct tab_table) [GLOBAL_DEBUGGING] New `reallocable' + member. + + * var.h: (macro force_dup_variable) [!GLOBAL_DEBUGGING] Remove + gratuitous space between parameter definition. + + * vars-atr.c: Changed some assert(0)'s to abort()'s to prevent + complaints about running off the end of functions with NDEBUG + enabled. + +Sun Jul 5 00:17:25 1998 Ben Pfaff + + * Several source files: Removed some PORTME notes when reflection + revealed that ANSI forbids that sort of breakage. Also, added + lots of `unused' qualifiers here and there. + + * aggregate.c: (accumulate_aggregate_info) Remove local var + weighting that turned out not to be used. + + * avl.c: Update to version 1.1.0. Add unused specifier. + (avl_destroy) Initialize ab to 0. Comment fixes. Cast return + value to void *. + (avl_probe) Replace some instances of 1 with +1 where appropriate. + (avl_find) Cast return value to void *. + (avl_delete) q doesn't need to be initialized at the beginning of + the function. Replace some instances of 1 with +1. + (force_avl_delete) Renamed avl_force_delete, all references changed. + (compare_ints) `param' marked unused. + (print_int) `param' marked unused. + (recurse_tree) Replace some instances of 1 with +1. + + * avl.h: Update to version 1.1.0. Only declares avl function + types if not already declared. + (AVL_MAX_HEIGHT) Only define if not already defined. + (struct avl_node) New unused member char pad[2]. + [GLOBAL_DEBUGGING] Change conditionalization to NDEBUG instead. + (force_avl_insert) Renamed avl_force_insert. + (force_avl_delete) Renamed avl_force_delete. + + * crosstabs.q: (struct table_entry) Put `freq' into a union with + new member `data'. + (struct crosstab) Add new member `ofs'. + (glob var int_tab) Removed. + (custom_tables) In integer mode, assign v[i] properly through the + indirect var_dict. + (custom_variables) Now p.crs.max == max + 1. + [DEBUGGING] (debug_print) p.crs.min and p.crs.max are now ints. + (precalc) Implement integer mode. + (calc_integer) Implement integer mode. + (compare_table_entry) Remove unused local variable `comparing'. + (make_summary_table) Implement integer mode. + (macro ns_rows) Implemented as static variable now. + (several variables) Made static, from global. + (output_pivot_table) Use table_value_missing() for column heads. + Remove several unused local variables. Implement integer mode + table summing. Count up ns_rows. + (crosstabs_dim) Make columns wider when /MISSING=REPORT requested. + (find_pivot_extent) Moved into find_pivot_extent_general; now just + calls that function or find_pivot_extent_integer. + (find_pivot_extent_integer) New function. + (enum_var_values) Implemented for integer mode. + (table_value_missing) New function. + (display_dimensions) Call table_value_missing() for heads. + (float_M_suffix) New function. + (display_crosstabulation) Call table_value_missing() for row + heads. Handle missing values in /MISSING=REPORT mode. + (calc_fisher) Remove unused var N. + (calc_r) Remove unused var fact. + + * data-list.c: (dump_fixed_table) Fix table dimensioning. + (read_one_set_of_repetitions) Remove unused vars var_spec, column. + + * data-out.c: (insert_commas) Remove unused var cp. + (convert_CCx) Remove unused vars save_set_decimal, + save_set_grouping. + + * descript.q: (dump_z_table) Fix table dimensioning. + (pre_calc) Remove unused var j. + (display) Remove unused vars title, s. Fix table dimensioning. + + * expr-evl.c: Comment fixes. + + * frequencies.q: (full_dim) New function. + (dump_full) Fix table dimensioning. + (condensed_dim) New function. + (dump_condensed) Fix table dimensioning. + + * get.c: (cmd_match_files) Remove unused var n_val. Remove unused + label winnage. + + * html.c: (html_close_drive) Remove unused var i. + (postopen) Remove unused vars title, curfn_len, cp. + (preclose) Remove unused vars this, x. + + * lexer.c: Comment fixes. + + * matrix-data.c: (cmd_matrix_data) Remove unused var index. + + * means.q: (custom_tables) Remove unused var m_dim. + + * mis-val.c: Format fix. + + * modify-vars.c: (cmd_modify_vars) Remove unused var new_dict. + + * output.c: (outp_get_paper_size) Remove unused var cp. + + * pfm-read.c: (read_float) Remove unused var save, unused label + underflow. + (read_variables) Remove unused vars cp, j. + (read_value_label) Remove unused var j. + + * pfm-write.c: (bufwrite) Remove unused var i. + + * postscript.c: (ps_postopen_drive) Remove unused vars dev_info, + fn. + (output_encodings) Remove unused vars char_cp, n_output. + (read_ps_encodings) Remove unused var ep. + (postopen) Remove unused var title. + (preclose) Remove unused var fp. + (ps_open_page) Remove unused vars true, false, orientation, + mirror_horz, mirror_vert, width, length. + (ps_text_metrics) Remove unused var x. + + * q2c.c: (find_symbol) Remove unused var y. + (parse_setting) Remove unused parameter sbc, all references + changed. + (dump_parser) Remove unused var cp. + (dump_free) Remove unused var i. + + * set.q: (static vars args, n) Removed. + (internal_cmd_gset) Removed. + + * sfm-read.c: (sfm_read_dictionary) Removed unused var i. + (read_machine_flt64_info) Removed unused var file_endian. + (read_documents) Removed unused var i. + (read_compressed_data) Removed unused parameter dict, all + references changed. + + * sfm-write.c: (bufwrite) Removed unused var i. + (sfm_write_case) Removed unused var i. + + * sort.c: (merge_once) Remove unused var t. + (write_separate) #if 0 out as dead code. + + * split-file.c: (cmd_split_file) Remove unused var i. + + * sysfile-info.c: (sysfile_info_dim) New function. + (cmd_sysfile_info) Fix table dimensioning. + (variables_dim) New function. + (display_variables) Fix table dimensioning. + (describe_variable) Remove unused var prev_r. + + * t-test.q: (z_postcalc) Removed. + (pairs_calc) Remove unused var bad_weight. + (postcalc) Remove unused vars dfn, dfd. + + * tab.c: (tab_create) Set t->dim to NULL. + (tab_dim) Make sure t->dim is NULL first. + (tab_natural_width) Remove parameter `clamp'. + (tab_value) Remove duplicate assertion for table. + (tab_raw) New function. + (nowrap_dim) New function. + (wrap_dim) New function. + (tab_output_text) Fix table dimensioning. + + * tab.h: (tab_raw) New macro. + + * val-labs.c: (get_label) Remove unused var type. + (copy_value_labels) Remove unused var trav. + + * var.h: (struct crosstab_proc) Completely changed. + + * vars-prs.c: (parse_dict_variable) Remove unused var v. + + * vfm.c: (open_active_file) Remove unused vars i, lp. + + * weight.c: (weight_trns_proc) #if 0 out as dead code. + +Tue Jun 2 23:37:21 1998 Ben Pfaff + + * Makefile.am: Add apply-dict.c, flip.c. + + * apply-dict.c: New file. + + * command.c: (struct command) Make cmd[] larger for CLEAR + TRANSFORMATIONS command name. + (parse_cmd) Make sure we're in a valid state before using it as an + index. Discard variables and reset state on invalid transitions. + (cmd_clear_transformations) New function. + + * command.def: Add APPLY DICTIONARY, CLEAR TRANSFORMATIONS, FLIP. + Add unimplemented PRESERVE, RESTORE. + + * file-handle.h: Include stddef.h. + + * flip.c: New file. + + * pfm-read.c: (parse_value) Pad value label values with spaces, + not nulls. + + * sfm-read.c: (struct sfm_fhuser_ext) Add reference count. + (sfm_close) Decrement reference count, make sure it's zero. + (sfm_maybe_close) New function. + (sfm_read_dictionary) Handle reference counts. + + * vars-atr.c: (clear_default_dict) New function. + (discard_variables) Use clear_default_dict(). + +Sun May 31 00:58:05 1998 Ben Pfaff + + * Makefile.am: Add pfm-write.c. + (LDADD) Add the libgmp2 libraries. + + * command.def: Define EXPORT. + + * get.c: (cmd_export) New function. + (export_write_case_func) New function. + + * pfm-read.c: (static spss2ascii[]) Make it const. + + * pfm-write.c: New file. + + * sfm-write.c: Formatting, comment fixes. + + * var.h: Comment fix. + +Fri May 29 21:44:12 1998 Ben Pfaff + + * Makefile.am: Add pfm.h, pfm-read.c. + + * command.def: IMPORT is now implemented. + + * format.c: (glob var translate_fmt[]) New var. + + * get.c: (enum GTSV_NONE) Renamed GTSV_OPT_NONE. + (cmd_import) New function. + (import_source_read) New function. + (glob var import_source) New var. + + * pfm-read.c: New file. + + * pfm.h: New file. + + * sfm-read.c: (parse_format_spec) Local variable translate_fmt[] + moved in format.c. + (dump_dictionary) Disabled printing a couple of items. + +Mon May 25 12:42:37 1998 Ben Pfaff + + * crosstabs.q: (postcalc) Call make_summary_table(). + (make_summary_table) New function. + (insert_summary) New function. + (display_dimensions) Remove some unnecessary arguments, all + references changed. + (output_pivot_table) Fix lots of problems with the risk table + setup. + (submit) Don't display an empty table. + (display_risk) Fix order of arguments to calc_risk(). + + * glob.c: Always include assert.h and stdlib.h. + + * output.h: (enum OUTP_T_JUST_FULL) Removed, all references + removed. + + * tab.c: (tab_create) Cosmetic changes. + + * tab.h: (enum TAB_JUSTIFY) Removed, all references removed. + +Sun May 24 22:39:23 1998 Ben Pfaff + + * tab.def: Removed. + + * crosstabs.q: (output_pivot_table) Headers drawing and submission + code simplified, moved into new function submit(). + (submit) New function. + (crosstabs_dim) New function. + (display_directional) Substitute variable names for %s where + appropriate. + (somers_d_v[], somers_d_ase[], somers_d_t[]) New static vars. + (calc_symmetric) Initialize parameters only if non-NULL. + Calculate Somers' d. + (calc_directional) Calculate Somers' d (or copy it, really). + Calculate eta. + + * output.c: (outp_string_width) New function. + + * postscript.c: (postopen) Calculate font widths based on the + width of the zero '0' character, not the width of the space + character. Set paper-width and paper-length based on points, not + device units. + (ps_open_page) Fix page setup string for landscape mode. + + * som.h: (struct som_dimension) Removed. + (struct som_table_class) height, width members take int * not + som_dimesion * now. + + * tab.c: Many functions now have added parameter validation. + (tab_height, tab_width) These functions were removed and merged + into a single function tab_resize(), and all references changed. + (tab_dim) Rewritten since the interface changed; reduced from + hundreds of lines to two. All callers were changed. Currently + most of them just use tab_natural_dimensions as their callback and + await detailed translation of functionality. + (tab_natural_width) New function. + (tab_natural_height) New function. + (tab_natural_dimensions) New function. This is a callback + function, not something that you'd want to call directly. + (tab_nat_dim) Removed. + (tabi_table) Allocates t->w and t->h. + (tabi_driver) Inlined sum_columns()'s functionality. Calls the + dimensions callback. + (evaluate_dimensions) Removed. + (sum_columns) Removed. + + * tab.h: (enum TAL_1THIN) Removed. + (enum series t_*) Removed. + (struct tab_table) Members trh, trv changed to unsigned char * + from int *. Member dim changed to a function pointer from a + unsigned char *. Member max_stack_height removed. New members + hr_tot, vr_tot. + (macros tab_l, tab_r, tab_t, tab_b) New. + +Sat May 23 23:22:13 1998 Ben Pfaff + + * ascii.c: (delineate) Assign last_space_nchars before skipping + spaces, to fix right justification. + + * crosstabs.q: (static vars risk, direct) New vars. + (static var pearson_r) Removed. + (glob var chisq_fisher) Made static. + (static vars row_tot[], col_tot[]) Don't include grand total + anymore. + (static var grand_total) Renamed W, all references changed. + (output_pivot_table) Only make `table' if num_cells != 0. Make + risk and directional tables. Deal with grand total no longer part + of col_tot[]. Free rows and cols after we're done with them. + (display_risk) New function. + (display_directional) New function. + (clac_r) Rewritten so that it stores all its results into its + arguments, so it can be used for Spearman's correlation too. + (calc_symmetric) Added a t[] argument, all references changed. + Calculates ASEs for tau-b, tau-c, gamma. Calculates Spearman's r, + Pearson's r, Cohen's kappa. + (calc_risk) New function. + (calc_directional) New function. + + * som.c: (som_submit) Improved debugging code. + + * stats.c: (hypercube) New function. + (cube) New function. + (sqr) New function. + (normal_sig) Went back to old implementation, which actually + worked. + + * stats.h: (macros square, cube, hypercube) Removed. The + equivalent functions in stats.c are inlined here; all references + to square changed to sqr. + +Fri May 22 00:03:41 1998 Ben Pfaff + + * crosstabs.q: (N_SYMMETRIC) New define. + (postcalc) Disable debug printing. + (static vars chisq_fisher, pearson_r) New. + (output_pivot_table) Add support for symmetric measures. Add + chi-square output of exact sigs. + (display_chisq) Rewritten. + (display_symmetric) New function. + (gamma_int) New function. + (Pr) New function. + (swap) New function. + (calc_fisher) New function. + (calc_chisq) Check boundary conditions better. Calculate Yates, + Fisher, Mantel-Haenszel tests. + (calc_r) New function. + (calc_symmetric) New function. + + * stats.c: (normal_sig) Rewritten with new algorithm. Renamed + from calc_normal. + (chisq_sig) Better boundary conditions. Renamed from + calc_significance. + + * tab.h: (struct tab_table) New member cf. + + * tab.c: (tab_create) Set cf. + (tab_width) New function. + (tab_realloc) Handle cf. + (tab_vline) Handle cf. + (tab_hline) Handle cf. + (tab_box) Handle cf. + (tab_value) Handle cf. + (tab_float) Handle cf. + (tab_text) Handle cf. + (tab_joint_text) Handle cf. + (tab_offset) Handle cf. + (tab_next_row) Handle cf. + (evaluate_dimensions) Handle cf. + (render_strip) Handle cf. + +Wed May 20 00:03:59 1998 Ben Pfaff + + * crosstabs.q: (postcalc) New vars row_tot, col_tot, pass them to + output_pivot_table(). + (output_pivot_table) Moved lots of local variables outside and + made them static. Add beginnings of chi-square statistic + support. Now column and row totals aren't in the main matrix. + Always zero out any leftover rows & columns after we're done with + the table entries. Move all output stuff into + display_dimensions(), display_crosstabs(), display_chisq(). + (display_dimensions) New function. + (display_crosstabulation) New function. + (display_chisq) New function. + (calc_chisq) Implemented Pearson and likelihood-ratio chisquares. + + * frequencies.q: (dump_full, dump_condensed) Remove tab_null() + references, simplify logic. + + * postscript.c: Remove scale, translate-x, translate-y, + mirror-horz, mirror-vert, rotate-180 options. + (struct ps_driver_ext) Remove scale, translate_x, translate_y. + All references deleted. + (macro YT) New macro. + (array option_tab[]) Removed options. + (ps_option) Removed options. + (ps_open_page) Write page setup explicitly to output file, without + using now-deleted BP function. + (macro dump_line) Use YT(). + (macro dump_thick_line) Use YT(). + (draw_headers) Use YT(). + (switch_font) Reorder arguments to SF function. + (write_text) Use YT(). + + * sfm-read.c: (sfm_read_case) Don't attempt to read variables that + have get.fv == -1. + + * sysfile-info.c: (describe_variables) Don't use tab_nulls(). + + * tab.c: (tab_create) Initialize t->ct to zeros. Remove + null-debugging code. + (tab_realloc) Remove null-debugging code. Initialize new regions + of t->ct to zeros. + (tab_vline) Support offsets. + (tab_hline) Support offsets. + (tab_box) Support offsets. + (tab_null) Removed. + (tab_nulls) Removed. + (tab_row) Removed. + (tab_col) Removed. + (evaluate_dimensions) Remove null-debugging code. Understand + TAB_EMPTY attribute. Assert that text.s.s is always non-NULL if + TAB_EMPTY not present. + + * tab.h: New cell attribute TAB_EMPTY. + (macros tab_nr, tab_nc, tab_row, tab_col) New. + + * vars-atr.c: (init_variable) Set get.fv to -1 so that GET doesn't + try to read them from system files. + + * vfm.c: (dump_splits) Don't call tab_null(). + +Sat May 16 19:36:55 1998 Ben Pfaff + + * crosstabs.q: (struct crosstab) Added `missing' member. + (custom_tables) Init missing. + (calc_general) Handle missing values. + (calc_chisq) New function. + (output_pivot_table) Start work on chi-square output. Update for + new tab offset support functions. Shorten statistic names. + + * Several files: add in more `const's to placate gcc's warnings. + + * tab.h: (struct tab_table) Add col_ofs, row_ofs members. Comment + fixes. + + * tab.c: (tab_height, tab_realloc, tab_vline, tab_hline, tab_box, + tab_null, tab_nulls, tab_value, tab_float, tab_text, + tab_joint_text) Add col_ofs and row_ofs support. + (tab_offset) New function. + (tab_next_row) New function. + (tab_row) New function. + (tab_col) New function. + (tabi_table) Add col_ofs and row_ofs support. + + * vars-atr.c: (is_system_missing) New function. + +Tue May 12 16:14:30 1998 Ben Pfaff + + * crosstabs.q: Expanded subcommand names RESID --> RESIDUAL, etc. + (static var no_cells) Removed. + (static var num_cells) New. + (static var expected) New. + (static var cells[]) New. + (internal_cmd_crosstabs) Deal with new variables. + (postcalc) Removed most of the meat and put it in new function + output_pivot_table(). + (output_pivot_table) Calculates and outputs an entire pivot table. + + * postscript.c: (postopen) Fix problems with free()ing addresses + not obtained from malloc(). + + * som.c: (som_submit) Add assertion. + + * sysfile-info.c: (describe_variable) Use new tab_nulls() + function. + + * tab.c: (static var tab_names[]) New. + (tab_realloc) -1 for nc or nr indicates no change. + (tab_nulls) New function. + (tab_dim) Use tab_names[]. + (tabi_cumulate) Don't include bottom or right headers. Furrfu. + (evaluate_dimensions) Don't terminate on uninited cells, just put + an X in them and emit a notice. Use tab_names[]. + + * tab.h: Move bits into tab.def. + + * tab.def: New. Don't try to declare tab_table_class because then + som.h has to be included. + +Thu May 7 22:55:04 1998 Ben Pfaff + + * command.def: New file, contains all the command definitions + previously included bodily in command.c. + + * format.def: New file, contains all of the format definitions + previously split across format.h, format.c, and sfm-write.c. + + * lexer.h: Renamed from tokens.h in order to match corresponding + .c file name. + + * lexerP.h: Moved some rarely used functions exported by lexer.c + into here. + + * Makefile.am: Commemorate renamed files. + (EXTRA_DIST) Add command.def, format.def. + + * command.c: [0] (walk_cmdtable_func) Removed. + + * crosstabs.q: (postcalc) Made it work and print out matrices + proving it. + (enum_column_values) Renamed enum_var_values, generalized for any + variable. + + * format.h: (struct fmt_desc) New member `spss'. + + * q2c.c: (main) Generated code includes lexer.h instead of + tokens.h. + + * sfm-write.c: (write_format_spec) Use new spss member of fmt_spec + instead of an independent translation table. + +Tue May 5 13:19:03 1998 Ben Pfaff + + * Lots of source files: Added const to declarations. + + * aggregate.c: (parse_aggregate_function) Rename inner i to j. + + * arena.c: (arena_clear) Set prev pointer to null when done. + + * ascii.c: (ascii_option) Rename index as indx. + + * avl.c: This is now a separate library called libavl. + (xmalloc) Make static. + (avl_probe) Step A7 can use the cache instead of an explicit + compare. + (avl_delete) Don't maintain a q pointer because it's always + available in the pointer stack. Comment fix. + + * avl.h: This is now a separate library called libavl. + + * command.c: (cmd_table[]) Remove spurious trailing "". + + * common.h: Only include random() fix if this system needs it. + + * crosstabs.q: Include alloca headers. + (n_sorted_tab) New global var. + (postcalc) Mostly rewritten. + (find_pivot_extent) Rewritten. + (enum_column_values) Rewritten. + + * data-out.c: (convert_F) Rename inner n as n_spaces. + + * error.c: (dump_message) Don't have an outer var i. + + * file-handle.q: (static var f) Removed. All references removed. + (internal_cmd_file_handle) Uses a local variable instead of f. + + * get.c: (trim_dictionary) Change scope of i, i1, i2. + (cmd_match_files) Don't strcpy tokstr into sbc (why was this ever + done?) + + * getline.h: Declare getl_history as extern. Reported by + palme@uni-wuppertal.de (Hubert Palme). + + * postscript.c: (postopen) Some large mods for constness. + + * recode.c: Remove spurious copyrights since PSPP is owned by FSF + anyway. + +Fri Apr 24 12:52:47 1998 Ben Pfaff + + * Makefile.am: Rename BUILT_SOURCES to q_sources, all references + changed. Add avl.c, avl.h to pspp_SOURCES. Remove avllib from + LDADD. + + * avl.c, avl.h: New files. These form a clean-room + reimplementation of avllib. Iterative algorithms are used in + place of recursive ones, so there is no resemblance in the code. + + * Lots of headers: Don't include other headers by default. + + * Lots of source files: Explicitly include all needed headers. + + * arena.c: (arena_clear) New function. + + * crosstabs.q: (ROW_VAR, COL_VAR) New enums. + (static var ar) Removed. + (staitc vars ar_tc, ar_col) New. + (cmd_crosstabs) Destroy the arenas. + (internal_cmd_crosstabs) Create the arenas. + (precalc) Don't need a free function for the hash. + (calc_general) Make sure to zero out the trailer on the key data + before inserting. + (print_table_entries) Updated. + (postcalc) Worked on actually implementing. + (find_pivot_extent) New function. + (compare_value) New function. + (enum_column_values) New function. + + * data-in.c: (parse_month) Make local array `static const'. + + * data-out.c: (convert_date) Make local array `static const'. + (convert_WKDAY) Same. + (convert_MONTH) Same. + + * frequencies.q: (postprocess_freq_tab) avl_walk_inorder() has + been renamed to avl_walk(). + + * hash.c: Rewritten more efficiently. + + * hash.h: Add attribute const to hsh_next_prime declaration. + + * lexer.c: (id_match) Make arguments const. + + * postscript.c: (ps_postopen_driver) Make default fonts the + Helvetica family. + + * q2c.c: (main) Generated code needs stdlib.h. + + * sfm-write.c: (write_value_labels) An avl_traverser needs to be + initialized to 0 now, not to NULL. All other references to + avl_traverser were updated in the same way. + + * tokens.h: Macro version of id_match updated to use const + properly. + + * val-labs.c: (inc_ref_count) New function. + (copy_value_labels) Simply through use of new avl_copy() function. + +Wed Apr 15 13:01:58 1998 Ben Pfaff + + * crosstabs.q: Probably doesn't compile. New PIVOT subcommand. + (postcalc) Worked on this. + + * postscript.c: (OPO_DOUBLE_LINE) New enum. + (struct ps_driver_ext) New line_width_thick member. + (ps_preopen_drive) Init line_width_thick. + (option_tab[]) Add line-* options. + (ps_option) Parse line-* options. + (postopen) Add line_width_thick support. Strip leading spaces on + prologue output lines. + (ps_open_page) Include line_width_thick in output. + (macro dump_thick_line) New. + (dump_fancy_line) Support thick lines as well as double lines. + +Tue Apr 14 00:50:08 1998 Ben Pfaff + + * Makefile.am: Add crosstabs.c to BUILT_SOURCES. Add crosstabs.q + to pspp_SOURCES. Add crosstabs.q to EXTRA_DIST. + + * Many source files: Rename `options' to `pv_opts' as appropriate. + + * command.c: (static var cmd_table[]) Add CROSSTABS command. + + * common.c: (xcalloc) New function. + + * crosstabs.q: New file. Not finished yet, though. + + * data-list.c: Comment fix. + + * error.c: Remove some old Checker cruft. + + * frequencies.q: (dump_full) Cumulate valid percent instead of + regular percent. + + * getline.c: Comment fix. + + * hash.c: Comment fixes. + + * hash.h: (struct hsh_table) Make hash functions return unsigned + instead of int to avoid problems with taking the modulo of + negative return values. All references changed. + + * misc.c: (intlog10) Make its table static const instead of auto. + + * sfm-read.c: (read_header) Make `prefix' static const instead of + auto. + + * var.h: (union value) Add member `hash'. + (struct variable) Rename prv_index as `foo'--all references + changed. Reorder. + (typedef pv_opts) Removed. All references changed. + + * vars-prs.c: (parse_variables) Message fixes. + +Mon Mar 9 15:35:08 1998 Ben Pfaff + + * get.c: (cmd_match_files) Don't reverse the order of FILEs as + they are being inserted. Don't check for BY variables of + different types. Discard variables if the active file isn't + included in the merge. + (mtf_processing) Essentially rewritten. + (mtf_merge_dictionary) Check for master/slave variables of + different types/widths. + + * vfm.c: (static var not_canceled) New var. + (process_active_file) Don't call vfm_source->read() if + there's no vfm-source. Initialize not_canceled. + (process_active_file_write_case) Honor and update not_canceled. + (prepare_for_writing) Rollback changes from yesterday, they were + wrong. + (close_active_file) Don't destroy vfm_source unless it exists. + +Mon Mar 9 00:56:16 1998 Ben Pfaff + + * Lots of source files: Added { } around nested if/else constructs + to avoid new gcc 2.8 warnings. + + * data-in.c: (parse_Z) Declare `int' type explicitly. + (convert_Z) Ditto. + + * get.c: (struct mtf_file) Add prev, next_min, by, input members. + (cmd_match_files) Initialize mtf_by_values. Manage by, input, + prev members. Put TABLEs at the end of the chain and FILEs at the + beginning. Don't allow the active file in STATE_INIT. Use proper + `seen' value for the active file. Fill out the by members and + make sure they're of consistent type. Do the actual merge + operation. + (mtf_processing_finish) New function. + (var_type_description) New function. + (mtf_free_file) New function. + (mtf_free) Rewritten. + (mtf_delete_file_in_place) New function. + (mtf_read_nonactive_records) New function. + (mtf_compare_BY_values) New function. + (static var mtf_seq_no) New var. + (mtf_processing) New function. + (mtf_merge_dictionary) Assign nval members for the system file + dictionary. Assign fv values for its variables. Point each slave + variable to the corresponding master variable. + + * hash.c: Include str.h. + + * mis-val.c: (copy_missing_values) src arg is const. + + * misc.c: (spacing) Make `max' var explicitly int. + + * sfm-read.c: (dump_dictionary) Message reformatting. + (sfm_read_case) Add assertion. + + * sort.c: Esthetic fixes. + + * var.h: (struct match_files_proc) New struct. + (struct variable) Add private data match_files_proc. + + * vars-atr.c: (delete_variable) Implement. Add argument for the + dictionary that owning the variable. + (dup_variable) Add assertion. + + * vfm.c: Comment fixes, hopefully the comments are correct now. + (process_active_file) New function. + (process_active_file_write_case) New function. + (process_active_file_output_case) New function. + (prepare_for_writing) Use temp_dict->nval for vfm_info, not + default_dict.nval. + (write_case) Renamed procedure_write_case(). Now write_case is a + pointer to a function. Style fixes. + +1998-03-05 Ben Pfaff + + * Makefile.am: (q2c) Link with libmisc. + (version.c) Define default_config_path, include_path, + groff_font_path. + + * ascii.c: (ascii_postopen_driver) When the default newline string + is requested, open file in text mode. Suggested by + palme@uni-wuppertal.de (Hubert Palme). + (static vars line_buf, line_p) Change from char * to unsigned char + *. + (ascii_close_page) char * to unsigned char *. + + * cmdline.c: (parse_command_line) Implement -r option by + prepending ~/.pspp/rc to the list of files to process. + + * command.c: (cmd_remark) Reset getl_prompt to the standard prompt + before pulling in a final line. + (null_func, null_int_func) Removed (dead code). + + * descript.q: (display) Calculate width of variable name column + properly. Calculate number of valid cases properly. Reported by + palme@uni-wuppertal.de (Hubert Palme). + + * filename.c: (init_filename) Use default_config_path instead of + now obsolete CONFIG_PATH. + + * getline.c: (getl_initialize) Use include_path instead of now + obsolete INCLUDE_PATH. + (getl_add_file) New argument `where'. All references changed. + + * groff.c: (find_font_file) Use groff_font_path instead of now + obsolete GROFF_FONT_PATH. + + * postscript.c: (find_ps_file) Use groff_font_path instead of now + obsolete GROFF_FONT_PATH. Copy through temporary variable to + avoid problems with constness. + + * str.h: (macro cs_streq) New macro. + + * version.h: (glob var default_config_path, include_path, + groff_font_path) New vars. + +1998-02-23 Ben Pfaff + + * Many source files: Change verbose_msg() priority levels and + messages. + + * aggregate.c: Include debug-print.h. + + * cmdline.c: (parse_command_line) Add --safer/-s and --command/-c + options. + (static var pre_syntax_message) Document --safer/-s and + --command/-c. + + * command.c: (cmd_erase, cmd_host) Disable if set_safer is set. + + * dfm.c: (open_inline_file) [__CHECKER__] Zero out ext->file, + because it's not used but it's still copied. + (open_file_r) Remove gratuitous debug message. + + * filename.c: (safety_violation) New function. + (open_file) Remove gratuitous debug messages. Don't allow pipe + files if set_safer is set. + + * get.c: Turn off debugging. + + * getline.c: (getl_add_virtual_file) New function. + (getl_read_line) Add verbose_msg() call for opening new syntax + file. + (getl_perform_delayed_reset) Add a return value describing whether + any action was taken. Call reset_eof(). + + * getline.h: Comment fix. + + * groff-font.c: (groff_read_font) Use `goto next_iteration' in + place of incorrect `continue'. Use strtok_r() instead of + strtok(). Always check strtok_r() return value. + (groff_read_DESC) Use strtok_r() instead of strtok(). + + * lexer.c: (reset_eof) New function. + + * main.c: (parse) Get a token after performing a delayed reset + action; allow empty syntax files. + + * postscript.c: (output_encodings) Use strtok_r() instead of + strtok(). + + * q2c.c: (dump_parser) Use strtok_r() instead of strtok(). + + * set.q: Comment fixes. + (glob var set_safer) New var. + (internal_cmd_set) Support SAFER. + + * str.h: [!HAVE_STRTOK_R] Declare strtok_r() prototype. + + * temporary.c: (free_dictionary) Set d->splits to NULL after + freeing. + + * vars-atr.c: (clear_variable) Decrement dict->n_splits if + variable deleted, not if it *isn't* deleted. + +1998-02-16 Ben Pfaff + + * command.c: (array cmd_table[]) Add MATCH FILES. + + * common.c: Comment fixes. + + * data-list.c, dfm.c, error.c, filename.c, list.q, matrix-data.c, + modify-vars.c, postscript.c, sfm-read.c, sfm-write.c, tab.c: + Include alloca.h. Problem reported by palme@uni-wuppertal.de + (Hubert Palme). + + * expr-opt.c: Include str.h. Problem reported by + palme@uni-wuppertal.de (Hubert Palme). + + * get.c: (cmd_get) [DEBUGGING] Update v->p.get to v->get. + (static var mtf_by) Change from char ** to variable **. + (static var mtf_master) New var. + (mtf_merge_dictionary) New function. + (cmd_match_files) Init mtf_master. Parse mtf_by according to new + var type. Reorder tests properly. Initialize file->dict. Detect + TABLE= without BY=. Read file dictionaries and merge them. Give + subcommand name with IN, LAST, FIRST error messages. Create IN, + LAST, FIRST variables. Comment fixes. + (mtf_free) Don't free default_dict. Free mtf_master. + + * getline.c: Define getl_mode. Change getl_buf_size to size_t + from int. + (handle_line_buffer) Cast int to size_t in comparison to avoid + warning. + + * getline.h: Declare getl_mode extern. + + * groff-font.c: (groff_read_font) Type-fix calls to getline. + (groff_read_DESC) Make line_size a size_t. + (match_tok) Parenthesize name to avoid macro expansion. + + * mis-val.c: (copy_missing_values) New function. + + * postscript.c: (postopen) Make buf_size a size_t. + + * sfm-read.c: (dump_dictionary) Make global from static. Print + variable info in parts for easier debugging with Checker. + + * temporary.c: (copy_variable) Use copy_value_labels(). + (new_dictionary) New arg: whether to copy file label, documents. + + * val-labs.c: (copy_value_labels) New function. + + * var.h: (enums MISSING_*) Add MISSING_COUNT. + + * vars-atr.c: [GLOBAL_DEBUGGING] (force_dup_variable) New + function. + (dup_variable) Set prv_index, get.fv, get.nv. + +Fri Feb 13 15:38:36 1998 Ben Pfaff + + * Makefile.am: (pspp_SOURCE) Add htmlP.h. + + * Many source files: For ANSI-compliance, add empty statement + after label. Reported by palme@uni-wuppertal.de (Hubert Palme) + and Micah Altman . + + * data-in.c: (parse_numeric) Some header files break on + -DBL_MIN_10_EXP because they get a --; add () for safety. + Reported by palme@uni-wuppertal.de (Hubert Palme). + + * dfm.c: Idea by Dr Eberhard W Lisse . + (struct dfm_fhuser_ext) Change `file' from FILE * to file_ext. + (dfm_close) Use close_file_ext. + (open_inline_file) Set file.file to NULL, not file. + (open_file_r, open_file_w) Initialize file.file; fill in file_ext + struct and use open_file_ext(). + (read_record) Use file.file. + + * file-handle.q: (prepend_current_directory) Pass through special + filenames. + + * filename.c: Only include unistd.h if HAVE_UNISTD_H. + (normalize_filename) Pass through special filenames. + (open_file, close_file) Accept pipe| and |pipe syntaxes as + equivalent. + (dirname) Rename blp_dirname() because of name conflict on some + OS. All references changed. Reported by palme@uni-wuppertal.de + (Hubert Palme). + (is_special_filename) New function. + + * get.c: (GTSV_OPT*) Add GTSV_OPT_MATCH_FILES. + (trim_dictionary) Conditionalize some of the options on whether + GTSV_OPT_MATCH_FILES is in *options. + (rename_variables) Don't allow variables to be renamed as scratch + variables. + (MTF_*) New enum series. + (struct mtf_file) New struct. + (static vars mtf_head, mtf_tail, mtf_by, mtf_n_by, mtf_free) New + vars. + (cmd_match_files, mtf_free) New functions. + + * lexer.c: (match_int) Needed parentheses around name to escape + macro expansion. Reported by Micah Altman + . + + * print.c: Needed to include alloca.h. Reported by Micah Altman + . + + * recode.c: (convert_to_double) Parenthesize -DBL_MIN_10_EXP to + -(DBL_MIN_10_EXP). Reported by palme@uni-wuppertal.de (Hubert + Palme). + + * str.h: Include stdarg.h. Reported by palme@uni-wuppertal.de + (Hubert Palme) and Micah Altman . + +Thu Feb 5 00:18:21 1998 Ben Pfaff + + * html.c: (struct html_driver_ext) Move into htmlP.h. + (html_preopen_driver) Initialize cp_x, cp_y. + (html_submit) Implement as call to output_tab_table(). + (change_attributes) New function. + (escape_string) New function. + (output_tab_table) New function. + + * list.q: (write_all_headers) Add code for writing headers for the + html driver. + (clean_up) Write out the html close-table tag. + (determine_layout) Ignore html driver. + (list_cases) Write html data. + + * som.c: (som_submit) Move more of the code into output_table(). + + * tab.c: (static var hit) Make a global var and rename tab_hit. + (static var tab_table_class) Make a global var. + + * htmlP.h: New file. + +Tue Feb 3 16:12:18 1998 Ben Pfaff + + * dump-sysfile.c: Removed. + + * html.c: (preclose) Change comment in emitted code. + + * matrix-data.c: Debugging off by default. Comment fixes. + (static var container) New var. + (cmd_matrix_data) Create and destroy container. Initialize + is_per_factor[] to 0s. Move code into new function + string_to_content_type(). Require split values to be present in + the data when ROWTYPE_ is explicit. Call specific function, not + general read_matrices(). + (string_to_content_type) New function. + (context) Exclude all whitespace, not just spaces. + (mget_token) A dot is a number. Add assertion. + (static var data) Renamed nr_data. + (static var factor_values) Renamed nr_factor_values. + (read_matrices) Renamed read_matrices_without_rowtype(). Handle + only specific case. Close data_file before exit. + (fill_matrix) New function. + (read_data_lines) Renamed nr_read_data_lines(). Remove debug + printing. Style fixes. Message fixes. Move code into + fill_matrix(). + (read_matrices_without_rowtype) Rename + matrix_data_read_without_rowtype(). Fix off-by-one error on + loops. Allocate nr_data[] memory from arena. + (read_matrices_with_rowtype) Removed. + (read_splits) Renamed nr_read_splits(). Style fixes. + (read_factors) Renamed nr_read_factors(). + (dump_cell_content) Comment fixes. Arguments changed. Change + debug printing. All references changed. + (output_data) Renamed nr_output_data(). + (static var wr_content) New var. + (struct factor_data) New struct. + (static var wr_data) New var. + (static var wr_current) New var. + (matrix_data_source_destroy_source) Removed. + (read_matrices_with_rowtype) New function. + (matrix_data_read_with_rowtype) New function. + (wr_read_splits) New function. + (compare_factors) New function. + (wr_output_data) New function. + (wr_read_rowtype) New function. + (wr_read_factors) New function. + (wr_read_indeps) New function. + (glob var matrix_data_source) Make destroy_source member NULL as + well. + +Fri Jan 23 00:09:08 1998 Ben Pfaff + + * lexer.c: (syntax_error) Give better error message when at end of + file. + + * matrix-data.c: (var content_names[]) Fix PROX spelling. Change + N_SCALAR to output as plain N. + (mdump_token) Change output format. + (context) Fix message output interaction with spaces in input. + (another_token) New function. + (force_eol) Improved error message. + (static var max_cell_index) New var. + (read_matrices) Init `cells'. factor_values is now per-cell. + Init max_cell_index. + (read_data_lines) Replace `compare' local with new `compare' arg. + Debugging messages changed. Only read factors if per_factor. + Propagate error return from read_factors(), force_eol(). + Copy N_SCALAR values across the N vector. + (read_matrices_without_rowtype) Don't init `cells'. Don't need to + check parentheses manually since we now have is_per_factor[]. + Call read_data_lines() with new args. Check for end of data after + looping, using another_token(). + (read_factors) Arguments changed. Use max_cell_index to determine + whether to read or compare factors. Message fixes. + (dump_cell_content) New function. + (output_data) Completely rewritten because content types were + supported to be nested inside factor values, not vice versa. + +Thu Jan 22 00:26:38 1998 Ben Pfaff + + * lexer.c: (syntax_error) Support formatted varargs messages. + + * matrix-data.c: Turn debugging on by default. + (static content_type[]) New array. + (static content_names[]) New array. + (static rowtype_, varname_) New vars. + (static is_per_factor[]) New array. + (static split_values) Moved declaration. + (static n_continuous, first_continuous) New var. + (cmd_matrix_data) Don't init split_values. Assign ROWTYPE_ to + rowtype_. Simplify SPLIT code. Init is_per_factor[]. Assign + VARNAME_ to varname_. Initialize first_continuous, n_continuous. + Check for continuous variables. + [DEBUGGING] (debug_print) Remove content_names[]. + (mdump_token) New macro. + (mget_token_dump) New function. + (mdump_token) New function. + (context) New function. + (mget_token) Fix messages. + (static var data, split_values, factor_values) New vars. + (read_matrices) Manage split_values, factor_values. + (read_data_lines) New function. + (read_matrices_without_rowtype) Implemented. + (read_splits) Message fixes. Uses `just_read'. + (read_factors) New function. + (output_data) New function. + (matrix_data_source_destroy_source) Close the file handle. + (glob var matrix_source) Change name from "DATA LIST" to "MATRIX + DATA". + + * str.c: (strpadcmp) Removed. + + * vfm.c: (dump_splits) Initialize i; fix test for end of splits. + +Sun Jan 18 00:30:59 1998 Ben Pfaff + + * Lots of source files: Add cast to unsigned character to calls to + tolower() and toupper(). + + * aggregate.c: Set default_dict.splits to NULL. + + * command.c: (static variable tab[]) Add MATRIX DATA. + + * data-in.c: Add debugging defines. Formatting fixes. + + * expr-opt.c: Formatting fixes. + + * lexer.c: (syntax_error) Message fixes. + + * matrix-data.c: New enum series. + (static vars fmt, section, diag, explicit_rowtype, signle_split, + split_values, n_factors, factors, cells, pop_n, contents, + n_contents) New vars. + (cmd_matrix_data) Finished implementation. + (compare_variables_by_mxd_vartype) New function. + [DEBUGGING] (debug_print) New function. + (static vars mtoken, mtokstr, mtoklen, mtokval) New vars. + (read_matrices) New function. + (read_matrices_without_rowtype) New function. + (read_matrices_with_rowtype) New function. + (read_splits) New function. + (mget_token) New function. + (force_eol) New function. + [0] (test_tokenizer) New function. + (matrix_data_source_destroy_source) New function. + (glob var matrix_data_source) New var. + + * misc.h: Include ieeefp.h if present. + + * split-file.h: (cmd_split_file) Changes corresponding to struct + dictionary changes. + + * str.h: Fix memmem prototype. + + * temporary.c: (save_dictionary, restore_dictionary, + free_dictionary) Changes corresponding to struct dictionary + changes. + + * var.h: (MXD_* enums) New enum series. + (struct matrix_data_proc) New struct. + (struct split) Removed. + (struct dictionary) Changed `splits' member from `split *' to + `variable **'. + (macro force_create_variable) New macro. Replaced lots of + create_variable()/assert() calls with calls to this macro. + + * vars-atr.c: (discard_variables) Changed assertion. + [GLOBAL_DEBUGGING] (force_create_variable) New function + called by the macro of the same name. + (clear_variable) Changes to delete splits from the dictionary + corresponding to struct dictionary changes. + + * vars-prs.c: (parse_variables) [GLOBAL_DEBUGGING] Check for + corrupted variable `index' values in the dictionary passed in + every time this function is called. + + * vfm.c: (dump_splits, SPLIT_FILE_procfunc) Changes corresponding + to struct dictionary changes. + +Tue Jan 13 23:45:02 1998 Ben Pfaff + + * Makefile.am: (pspp_SOURCES) Add matrix-data.c. + + * command.c: New includes. + (static array cmd_table[]) Add ERASE, HOST, NEW FILE. + (cmd_erase) New function. + [unix] (shell) New function. + (run_command) New function. + (cmd_host) New function. + (cmd_new_file) New function. + + * expr-prs.c: (parse_primary) Message fix. + + * inpt-pgm.c: Formatting fix. + (cmd_reread) Implement the FILE subcommand. + + * matrix-data.c: New file. + + * q2c.c: (dump_header) Change output commenting style. + + * weight.c: Comment fix. + +Tue Jan 13 00:53:39 1998 Ben Pfaff + + * aggregate.c: (buf64_10x) Renamed buf64_1xx, all references + changed. + (buf_10x) Renamed buf_1xx, all references changed. + (cmd_aggregate) Implemented cases 010, 011, 110, and 111 (all + cases now implemented). + (create_sysfile) New function. + (agr_11x_func) New function. + + * data-in.c: (parse_numeric) Work properly if there's an + explicitly coded decimal point in the data and decimal places are + specified on DATA LIST. Bug reported by Dr Eberhard W Lisse + . + + * get.c: (cmd_get, cmd_save_internal) Allow extraneous slash + before file specification on GET, SAVE, XSAVE. Bug reported by Dr + Eberhard W Lisse . + + * q2c.c: [!HAVE_STRERROR] Include misc/strerror.c, not + strerror.c. Bug reported by Alexandre Oliva + . + + * sort.c: Include sort.h. Comment fixes. A few esthetic fixes. + (static var separate_case_tab) New var. + (cmd_sort_cases) Cancel temporary transformations here. Free + v_sort before return. + (sort_cases) Run an EXECUTE procedure if SEPARATE is nonzero and + we're reading from a sort stream. Don't cancel temporary + transformations. Offload internal sorting to do_internal_sort(). + (do_internal_sort) New function. Handles internal sorting even + when SEPARATE is nonzero. Doesn't free v_sort. + (do_external_sort) Take new arg SEPARATE. Only destroy `x' if + it's non-NULL. + (write_initial_runs) Take new arg SEPARATE. Only destroy the old + sink if SEPARATE is zero. + (read_output_cases) Renamed read_sort_output(), all references + changed. Now uses separate_case_tab when it exists. + (write_separate) New function. + + * vfm.c: (page_to_disk) Destroy memory_source_cases, not + memory_sink_cases. Don't redundantly call + vfm_source->destroy_source(). + (memory_stream_mode) After switching over, set memory_sink_cases + to NULL. + +Sat Jan 10 23:35:51 1998 Ben Pfaff + + * aggregate.c: (struct agr_var) Expand dbl[] array from 2 to 3 + elements. + (static var prev_case) New, moved out of aggregate_single_case() + local scope. + (static var buf64_10x, buf_10x) New. + (cmd_aggregate) Initialize prev_case. Comment fixes. Implement + the 000, 001, 100, and 101 cases. Free prev_case. + (parse_aggregate_functions) Disallow scratch variables. + (free_aggregate_functions) Only free agr_dict if non-null. Use + iter->function to determine numeric/string type, not + iter->src->type. + (aggregate_single_case) Don't manage prev_case. Initialize + aggregate info after dumping it. + (accumulate_aggregate_info) Fix sum, weighted sum, mean, weighted + mean, stddev, weighted stddev definitions. + (dump_aggregate_info) Implemented. + (initialize_aggregate_info) Renamed from + initialize_aggregate_functions(). Initializes dbl[2]. + (agr_00x_trns_proc, agr_00x_end_func, write_case_to_sfm, + agr_10x_trns_proc, agr_10x_trns_free, agr_10x_end_func) New. + + * cases.c: (alloc_val) Removed. + + * get.c: (cmd_save_internal) Initialize new `dict' member. + + * sfm-write.c: (sfm_write_dictionary, write_header, + write_variable, write_value_labels, write_documents) Reorganize, + simplify for new parameter structure. + (write_variable) Only one variable * argument now. + + * sfm.h: (struct sfm_write_info) Removed `pri', `sec', and + replaced by new `dict' member. + + * temporary.c: (new_dictionary) Initialize n_documents. + + * vars-atr.c: (dup_variable) Allocate `value's from dict into + v->fv manually. + (init_variable, replace_variable) Eliminate usage of alloc_val(). + + * vars-prs.c: (parse_DATA_LIST_vars) Accept PV_NO_SCRATCH option. + + * vfm.c: (arrange_compaction) Allow `temporary' value of 2 to + signal that AGGREGATE is to be used for forming final cases. + (close_active_file) Call end_func before stopping lagging. Cancel + temporary after finishing compaction. + (write_case) Comment fixes. Cleaned up. + (compact_case) Let AGGREGATE handle compaction when `temporary' is + 2. + +Sat Jan 10 02:10:47 1998 Ben Pfaff + + * Makefile.am: (BUILT_SOURCES) Add means.c. + (pspp_SOURCES) Add means.c. + (EXTRA_DIST) Add means.q. + + * command.c: (array cmd_table[]) Add MEANS. + + * common.h: Esthetic fixes. Comment fixes. Test for + MAX_SHORT_STRING greater than 8. + (macros LOWEST, HIGHEST) New. + + * data-in.c, data-list.c, recode.c: Comment fixes. + + * means.q: New file, base version. + + * mis-val.c: (parse_num_or_range, parse_numeric) Replace -DBL_MAX + with LOWEST, DBL_MAX with HIGHEST. + + * q2c.c: (dump_vars) Add an enum to array types giving the number + of values for the enum. + + * sfm-read.c: (sfm_read_dictionary, read_machine_flt64_info) + Replace second_lowest_value with second_lowest_flt64. + + * sfm-write.c: (write_variable, write_rec_7_34) Replace + second_lowest_value with second_lowest_flt64. + + * t-test.q: Comment fix. + + * temporary.c: (restore_dictionary) Esthetic fix. + + * tokens.h: (force_match_id, force_match, force_string, force_int, + force_num, force_id) Replace msg() with syntax_error(). + + * var.h: (struct means_proc) New. + (struct variable) Add mns member to `p' union. + + * vars-prs.c: (parse_variable, parse_dict_variable, + parse_variables, parse_DATA_LIST_vars) Replace msg() with + syntax_error(). + +Thu Jan 8 22:28:41 1998 Ben Pfaff + + * Makefile.am: (pspp_SOURCES) Add tab.h. + + * Most source files: Added a cast to unsigned char in usages of + the ctype is*() functions. Replaced `end of command expected' + calls to msg() with calls to syntax_error(). + + * frequencies.q: (dump_condensed) Fix tab_dim() column reference. + + * lexer.c: (hex_val) Removed (was dead code). + (idmatch) Parenthesize function name to avoid macro expansion. + + * postscript.c: Comment fixes. + (ps_preopen_driver) Change default font size to 10pt. + + * sfm-read.c: (read_variables) Byteswap sv.print, sv.write as + int32s. + (parse_format_spec) Change system-file format spec argument type + to int32. Parse the format spec with bitwise operators. + + * sfmP.h: (struct sysfile_format) Removed. + (struct sysfile_variable) Changed print, write members from + sysfile_format to int32. + + * tokens.h: Esthetic fixes. + [__GNUC__] (macro id_match) New macro to hopefully speed up + identifier matching. + (macros match_id, match_tok, match_int) Implemented in + compiler-independent manner; no longer GNU C only. + + * vfm.h: Include time.h. + +Mon Jan 5 11:06:15 1998 Ben Pfaff + + * data-list.c: (dump_fixed_table) Change tab_dim(). + + * dump-sysfile.c: (open_sysfile) Fix mmap() call. + + * error.c: Include command.h. + + * frequencies.g: Formatting fixes. + + * frequencies.q: Add tab_dim() calls. Make the total cell a + joined cell. + + * glob.c: Include command.h. + + * sfm-read.c: (struct sfm_fhuser_ext) New members sysmis, highest, + lowest. + (sfm_read_dictionary) Initialize sysmis, highest, lowest. + (sfm_read_machine_flt64_info) Update sysmis, highest, lowest. + (read_variables) Byteswap sv.type; byteswap sv.print, sv.write as + the other elements (is this right?). + (read_variables) Use lowest, highest members. + (parse_format_spec) New arg `vv' for more stringent checking. + (dump_dictionary) Byteswaps nonexplicit data. + (sfm_read_case) Byteswap numeric data. + + * som.c: Initialize table_num to 1. + (render_segments) Remember to increment y_index after each table + segment. + + * sysfile-info.c: (cmd_sysfile_info) Change tab_dim(). Don't call + avl_count() on a NULL tree. No title for the second table. + (cmd_display) Handle DISPLAY VECTORS by calling display_vectors(). + Handle AS_SCRATCH as AS_NAMES. Warn if no variables. Re-enable; + fix call to display_variables(). + (display_variables) Default to 4 columns, not 3. Set up headers. + Column title is Variable, not Name. Fix index column. + Add joint text. Add tab_dim(). Handle value labels properly. + Handle DISPLAY LABELS properly. Draw boxes correctly. + (describe_variable) Value labels don't need titles. Don't clear + nonexistent index column. + (compare_vectors_by_name) New function. + (display_vectors) New function. + + * tab.c: (tab_height) Add assertion. + (tab_null) Add debug code. + (evaluate_dimensions) Add debug code. + + * var.h: (struct variable) get_proc data is sometimes used + simultaneously with other per-procedure info, therefore it was + removed from the union. All references changed. + +Sun Jan 4 18:13:33 1998 Ben Pfaff + + * ascii.c: (ascii_close_page) Put title on second line of headers + if there is no subtitle. + + * command.c: (glob var cur_proc) Move definition here, from + common.c. + (cmd_remark) Emit blank line before remarks. + + * command.h: (glob var cur_proc) Move declaration here, from + common.h. + + * data-list.c: (dump_fixed_table) Fix messages. + (dump_free_table) Call tab_nat_dim(). + + * descript.q: (dump_z_table) Modify tab_dim() call. + + * frequencies.q: (dump_condensed, dump_statistics) Add tab_dim() + call. + (dump_statistics) Don't output header. + + * groff-font.c: Minor format fix. + + * html.c: Comment fix. + + * list.q: (write_varname) Indent after advancing page. + + * output.h: Minor reordering. + + * postscript.c: Comment fixes. Many places, '\n' was replaced by + a reference to eol[]. + (struct ps_driver_ext) New member eol[]. + (ps_preopen_driver) Initialize eol[]. + (ps_postopen_driver) Fix sense of text for text_opt, line_opt + defaults. Handle headers. Fix test for minimum page length. + (static var option_tab[]) Add `line-ends'. + (ps_option) Handle line-ends to change eol[]. + (postopen) Scale prop_em_width and fixed_width properly. Set the + prologue title to outp_title if applicable. Replace the prologue + line ends with eol[]. Call draw_headers() if headers are enabled. + (text_width) New function. + (out_text_plain) New function. + (draw_headers) New function. + + * print.c: (dump_table) Call tab_nat_dim(). + + * som.c: (som_blank_line) Only advance a line if not at the top of + a page. + (som_submit) Move several informational table calls here. + Increment subtable_num if SOMF_NO_TITLE not set. + (output_table) Advance a line if SOMF_NO_SPACING not set. + (render_columns, render_segments, render_simple) Handle spacing + between tables. Handle table titles. Remove debug output. + + * som.h: (SOMF_*) New enum series. + (struct som_table_class) New member `flags'. + + * sysfile-info.c: (cmd_sysfile_info) Calls tab_nat_dim(). No + headers or spacing. + (display_variables) Calls tab_nat_dim(). + (describe_variable) Remove restriction on number of value labels. + Make value labels separated by thin lines. + + * tab.c: (tab_create) Default `flags' to none. + (tab_float) New arg `w'. All references changed. + (tab_nat_dim) New function. + (tab_output_text) No title or spacing. + (tab_flags) New function. + (tabi_flags) New function. + (tabi_title) New function. + (strip_height) Removed. + (tabi_render) Skip title when necessary. + (static var tab_tab_class) Add tabi_flags, tabi_title. + (evaluate_dimensions) Disable display of column, row size. + (sum_columns) Add title height to top header. + (render_strip) Moved within file. + + * tab.h: (struct tab_table) New member `flags'. + + * vfm.c: (dump_splits) Calls tab_nat_dim(). No title. + +Sat Jan 3 16:55:44 1998 Ben Pfaff + + * Most source files: Add `const' attribute in all appropriate + places. + + * sysfile-info.c: (cmd_sysfile_info) Add tab_dim() call, add a + column to the variables table for use by describe_variable(). + (cmd_display) Disable for the present. + (display_documents) Don't wrap documents. + (display_variables) Table has four columns now. + (describe_variable) Table has four columns now. Don't use a + subtable, use joined cells instead. + + * tab.c: (tab_create) Don't set `join'. + (tab_realloc) ct array is not made up of a_string's. + Reallocate trh, hrh, h arrays, initialize trh array. Initialize + cell contents on GLOBAL_DEBUGGING, not DEBUGGING. + (text_format) New function. + (tab_title) Rewritten, uses text_format(). + (tab_text) Rewritten, uses text_format(). + (tab_joint_text) New function. + (tab_join) Removed. + (static var hit) New variable. + (render_strip) New args r1, r2. Implement joined cells that fit + on a single page. + (tabi_render) Increment hit. Pass new args to render_strip(). + (evaluate_dimensions) [GLOBAL_DEBUGGING] Check for uninitialized + cells. For t_naw and t_nah, ignore joined cells and null cells in + calculations. + + * tab.h: (struct tab_join_rect) Removed. + (struct tab_table) Removed `join'. + (TAB_JOIN_MAIN) Removed. + (struct tab_joined_cell) New struct. + (TAT_NOWRAP) New enum. + +Fri Jan 2 01:39:58 1998 Ben Pfaff + + * ascii.c: (ascii_postopen) Replace ASCII_* macros with their + expansions. + (ascii_postopen_driver) Fix initialization of *_spacing so that + the TAL_0 bit doesn't count. + + * data-list.c: (dump_fixed_table) Use natural width for Format + column. + + * glob.c: (rerange) Removed. + (get_date) Formatting fixes. Internationalization fix. + + * html.c: (html_postopen_driver) Replace HTML_DEFAULT_OUTPUT_FILE + with "pspp.html". + + * postscript.c: (ps_postopen_driver) Replace + PS_DEFAULT_OUTPUT_FILE with "pspp.ps". + + * som.c: (som_submit) Don't eject page before every table. + (output_table) Fix order of arguments on call to area(). + (render_columns) Fix calculation of max_len. + + * tab.c: (tabi_cumulate) Minor change to increase elegance. + (render_strip) New function. + (strip_height) New function. + (tabi_render) Rewrite as calls to render_strip(). + + * tab.h: (TAT_* enums) Removed TAT_RICH, all references removed. + Renumbered TAT_PRINTF, TAT_TITLE, TAT_FIX to correspond better + with the TAB_* and OUTP_T_* constants. + +Thu Jan 1 11:53:52 1998 Ben Pfaff + + * Makefile.am: Formatting fixes. + + * ascii.c: (ascii_postopen_driver) Initialize *_line_spacing[], + *_line_width[]. + + * data-list.c: (dump_fixed_table) Add tab_dim() call. + + * descript.q: (dump_z_table, display) Add tab_dim() calls. + + * dump-sysfile.c: (glob var length) Make type off_t. + (usage) Fix arguments. + (main) Return 0. + + * output.h: (OUTP_T_*) Change constants' value to match tab.h. + Now right-justification is the default so many references had to + change. + (struct outp_class) Removed line_width, all references changed. + (OUTP_DEV_*) Add OUTP_DEV_DISABLED. + (struct outp_driver) Add elements horiz_line_width, + vert_line_width, horiz_line_spacing, vert_line_spacing. Remove + som element. + + * postscript.c: (outp_encodings) Formatting fixes. Fix garbage + collection. + (postopen) Initialize all the informational members of + outp_driver. + + * som.c: (som_blank_line) New function, renamed from blank_line(), + all references changed. + (som_submit) Disables drivers whose pages can't be opened. + (render_columns, render_simple, render_segments) Add debug output. + (render_columns) Fix loop range. + (render_simple) Don't try to render the headers, they're taken + care of automatically. Advance cp_y past the table when done. + (render_segments) Fix loop ranges. + + * tab.c: Initialize new members of tab_table. + (tab_vline) Handle trv[]; don't set style for spacing-only lines. + (tab_hline) Handle trh[]; don't set style for spacing-only lines. + (tab_box) Handle trh[], trv[]; don't set style for spacing-only + lines. + (set_expr) Removed. + (tab_dim) New function. + (tab_col_width) Removed. + (tab_row_height) Removed. + (tab_output_text) Call tab_dim(). + (tabi_driver) Call evaluate_dimensions(), sum_columns(). + (tabi_area) Implemented. + (tabi_cumulate) Implemented. + (tabi_render) Partially implemented, but broken. + (var tab_table_class) Made static. + (evaluate_dimensions) New function. + (sum_columns) New function. + + * tab.h: (enum t_*) Now start at t_end. New: t_ptw, t_nr, t_nc, + t_nah, t_naw, t_neg, t_xch, t_dup, t_lbl, t_jnz, t_sac, t_sar, + t_scr, t_srr, t_sentinel. Removed: t_nat. + (struct tab_table) New: wl, wr, ht, hb, trh, hrh, trv, wrv, dim, + max_stack_height, w, h. Removed: ce, re. + (macro blank_line) Removed. + (glob var zero_length) Removed. + +Fri Dec 26 15:44:31 1997 Ben Pfaff + + * Most source files: include some of the new include files broken + out of var.h. + + * Makefile.am: (pspp_SOURCES) Add all the new source files to the + list. + + * aggregate.c: (glob var outfile) Make static. + + * command.c: (glob var pgm_state) Move here. + + * common.c: (glob vars endian, second_lowest_value, pgmname, + finished, curdate, cur_proc, start_interactive, history_file) Move + here. + + * descript.q: (structs dsc_z_score, descriptives_trns) Move here. + + * file-handle.q: (glob vars files, inline_file) Move here. + + * glob.c: Lost lots of glob vars, detailed in individual file + entries. + (init_glob) set_printer, set_screen were obsolete, deleted. + set_cprompt has fewer spaces because pspp has fewer letters than + fiasco. + + * inpt-pgm.c: (glob vars inp_init, inp_init_size) Move here. + (inp_nval) Made static. + + * lexer.c: (glob vars token, tokval, tokstr, tokstr_size, + tokstr_len, toklongstr, tokint) Move here. + + * misc.c: Lost several vars and functions. + + * set.q: (all the set_* variables) Move here. + + * str.c: (strmaxcpy, strbarepadcpy, strbarepadlencpy, strpadcpy, + blpstrset, strpadcmp, memrev, memrmem, cmp_str) Move here from + misc.c. + + * tab.c: (set_expr, tab_col_width, tab_row_height) New functions. + + * tab.h: (enum series t_*) New enums. + (struct tab_table) Use arena struct tag. New members ce, re. + + * tokens.h: Comment fixes. + + * var.h: Move lots of enums and variables and functions and + structures to other files. Use and declare a lot more union and + struct tags. Comment fixes. + + * vector.c: (glob vars vec, nvec) Move here. + + * vfm.c: (glob vars reinit_sysmis, reinit_blanks, init_zero, + init_blanks, last_vfm_invocation) Move here. + + * cases.h: New file. + (struct long_vec) Move here. + (vec_init, vec_clear, vec_insert, vec_delete, devector, envector) + Move here. + + * command.h: New file. + (STATE_* enums) Move here. + (glob var pgm_state) Move here. + + * format.c: New file. + (glob var formats) Move here. + (parse_format_specifier_name, fmt_to_string, + check_input_specifier, check_output_specifier, + check_string_specifier, convert_fmt_ItoO, parse_format_specifier) + Move here. + + * format.h: New file. Move functions now in format.c here. + (FMT_* enums) Move here. + (struct fmt_desc) Move here. + (FCAT_* enums) Move here. + (struct fmt_spec) Move here. + (glob vars formats, fmt_parse_ignore_error) Move here. + + * inpt-pgm.h: New file. + (INP_* enums) Move here, make #defines into enums. + (glob vars inp_init, inp_init_size) Move here. + + * sort.h: New file. + (glob vars v_sort, nv_sort) Move here. + (sort_cases, read_sort_output) Move here. + + * vector.h: New file. + (struct vector) Move here, add struct tag. + (glob vars vec, nvec) Move here. + (find_vector) Move here. + + * New file. + (glob vars last_vfm_invocation, temp_case, reinit_sysmis, + reinit_blanks, init_zero, init_blanks) Move here. + (struct case_stream) Move here. + (glob vars vfm_source, vfm_sink, vfm_memory_stream, + vfm_disk_stream, sort_stream, data_list_source, + input_program_source, file_type_source, get_source, n_lag) Move + here. + (procedure, write_case, lagged_case, compact_case, page_to_disk) + Move here. + +Wed Dec 24 22:40:42 1997 Ben Pfaff + + * Makefile.am: (pspp_SOURCES) Added html.c, som.c, som.h. + (LDADD) Add libdcdflib. + + * ascii.c: Comment and formatting fixes. Almost every external + function had an assert added, checking driver_open and page_open. + (ascii_init_driver) Broken into ascii_preopen_driver, + ascii_postopen_driver, ascii_close_driver. Manages driver_open. + (ascii_open_page) Sets page_open. + (ascii_close_page) Clears page_open. + + * html.c: Comment and formatting fixes. Almost every external + function had an assert added, checking driver_open and page_open. + (html_init_driver) Broken into html_preopen_driver, + html_postopen_driver, html_close_driver. Manages driver_open. + (html_open_page) Sets page_open. + (html_close_page) Clears page_open. + (html_submit) Disabled. + + * lexer.c: (parse_string) Remove debugging printf. + + * list.q: (determine_layout) Open a page if one is not yet open. + + * output.c: Comment fixes. + (add_class) Set the class member of the new list element. + (parse_options) Don't handle device type. + (colon_tokenize) New function. + (configure_driver) New four-field format with a field for device + type. Now initialize driver_open, page_open, next, and prev + fields. Use new colon_tokenize() function. Don't do a memory + copy to replace a driver, it doesn't work; instead delete the old + driver and insert a new one. + (destroy_driver) Don't call som_destroy_driver(). Close the page + if it's open. Find the class in the list of classes and decrement + that reference count. Remove the driver from the global driver + list. + (outp_iterate_enabled_drivers) Renamed outp_drivers(). All + references changed. Rewritten. Don't return a driver that's not + enabled. + (outp_eject_page) All references to som_internal_eject_page() + changed to use this. Sets cp_x to 0 as well as cp_y. + + * output.h: (OUTP_I_* enums) Removed. + (struct som_submission_form) Removed. + (struct outp_class) init_driver broken into preopen_driver, + postopen_driver, and close_driver. submit changed to take a + som_table argument. + + * postscript.c: Comment and formatting fixes. Almost every + external function had an assert added, checking driver_open and + page_open. + (ps_init_driver) Broken into ps_preopen_driver, + ps_postopen_driver, ps_close_driver. Manages driver_open. + (ps_open_page) Sets page_open. + (ps_close_page) Clears page_open. + + * som.c: New file, base implementation. + + * som.h: (struct som_table) Add struct tag. + (enum SOM_COL_ACROSS) Removed. + (SOM_ROWS, SOM_COLUMNS) New enums. + (struct som_table_class) Add member `cumulate'. Remove `segment'; + change `render' arguments. + (struct som_point, struct som_rect) Removed. + (som_submit_table) Fixed typo, should have been som_submit. + + * sysfile-info: (describe_variable) Don't try to insert a + subtable; just destroy it for now. + + * t-test.q: Include dcdflib/cdflib.h instead of cdflib.h. Fix + references to value labels. + + * tab.c: (tab_destroy) New function. + (tab_columns) Change argument. + [0] (tab_submit) Remove dead code. + (tab_title) Allocate string from the table's arena. + (tab_output_text) Only free the buffer if we allocated it. + (tab_submit) New function. + (static vars t, d) New static vars. + (tabi_table, tabi_driver, tabi_count, tabi_area, tabi_columns, + tabi_headers, tabi_cumulate, tabi_render) New functions. + (glob var tab_table_class) New global var. + + * tab.h: (struct tab_join_rect) Don't use a som_rect; directly + encapsulate the rectangle. All references changed. + +Sun Dec 21 16:18:58 1997 Ben Pfaff + + * All header files updated to use struct tags in addition to + typedefs for all structures. Don't use word `struct' in struct + tags. + + * Makefile.am: (pspp_SOURCES) Remove html.c. + (INCLUDES) Replace the lib/* includes with a single lib/ include; + all references updated. + + * command.c: (parse_cmd) Remove call to som_check_workspace. + (output_line) Update to new som. + + * data-in.c: (parse_numeric) A single dot is not an error; it is + the system-missing value. + + * data-list.c: (dump_fixed_table, dump_free_table) Update to new + som. + + * data-out.c: Added `const' as appropriate to many prototypes. + (convert_E, convert_F, convert_CCx) Take double argument instead + of value * argument. + (convert_format_to_string) Call changed functions appropriately. + Instead of modifying the caller's value for FCAT_SHIFT_DECIMAL, + make a local copy of the value. + + * descript.q: Remove custom_variables() prototype now provided by + q2c. + (custom_variables) Don't increment sbc_variables, the caller does + this. + (dump_z_table, display) Update to new som. + + * error.c: (vmsg) Add const to prototype. Remove code to handle + `too many errors' condition. + (check_error_count) New function. + (msg) Add const to prototype. + + * filename.c: (open_file) Rewrite for elegance. + + * frequencies.q: Remove custom_*() prototypes now provided by q2c. + (dump_full, dump_condensed, dump_statistics) Update for new som. + + * list.q: Don't include somP.h. Change all references to + som_driver_ext to refer to the new members of som_driver. Change + som_internal_eject_page() references to outp_eject_page(). + + * main.c: (parse) Rewrite for elegance. Add call to + check_error_count(). + + * output.c: (add_class, outp_list_classes, outp_configure_driver) + Rewrite or revise for new outp_driver_class_list structure. + (outp_iterate_enabled_drivers) Fix comparison between disabled + devices and current device type. + (outp_eject_page) New function. + + * output.h: Comment fixes. + (struct outp_driver) New members driver_open, page_open, cp_x, + cp_y, font_height, prop_em_width, fixed_width. Deleted members + ref_count, next. + (struct outp_driver_class_list) New struct. + (outp_class_list) Changed to type outp_driver_class_list; all + references updated. + + * print.c: (dump_table, print_trns_proc) Updated for new som. + + * q2c.c: (dump_vars) Simplify array subcommand code. Declare + prototypes for custom subcommands. + (dump_subcommand) Always include the `else'. + (dump_parser) Fix comments in output code. + + * set.q: Reordered functions. + + * som-frnt.c, som-high.c, som-low.c, somP.h: Removed. + + * som.h: Rewritten from scratch. + + * str.h: Remove dead code. + + * tab.c, tab.h: New files, base implementation. + + * sysfile-info.c: (cmd_sysfile_info, describe_variable) Update to + new som. + + * t-test.q: New code from John Williams + . Include math.h, cdflib.h. + Many many new static vars and defines. + (precalc, postcalc, g_postcalc, z_postcalc, t_pairs, t_groups, + groups_calc, pairs_calc, z_dev_calc, z_calc) New functions. + (struct value_list) New struct. + (variance, covariance, pooled_variance, oneway, pearson_r, f_sig, + t_crt, t_sig, print_t_groups) New functions. + (cmd_t_test) Implemented. + + * temporary.c: (cancel_temporary) Only free the temp_dict if it's + non-NULL. + + * vfm.c: (dump_splits) Update to new som. + +Thu Dec 4 23:02:22 1997 Ben Pfaff + + * Makefile.am: (fiasco_SOURCES) Add html.c. + + * aggregate.c: Base source. + + * ascii.c: (postopen, preclose) Reformat. + + * data-out.c, expr-evl.c: Comment fixes. + + * filename.c: (open_file) When opening a file for writing, use + line buffering instead of full buffering for better interactive + performance. Suggested by Valerio Aimale + . Also, recognize special file + names `stdin', `stdout', `stderr'. + + * groff-font.c: Comment fixes. + + * html.c: New file; base version. + + * list.q: (write_all_headers, clean_up, determine_layout, + list_cases) Ignore `special' devices for now. Needs to be fixed + later. + + * output.c: (outp_init) Add html driver to list; reverse list + order. + + * output.h: (struct outp_class_struct) New members `special', + `submit'; comment fixes. All references changed. + + * postscript.c: (ps_init_driver) Make defaults for text_opt, + line_opt depend on whether the OUTP_DEV_SCREEN bit is set on the + device. + (postopen) Comment fix. + (preclose) Comment fixes, formatting fixes. Change x->file.file + references to more proper f->file. + + * som-high.c: (som_submit_table) Special classes use their own + renderers. + + * som.h: Comment fixes. + + * temporary.c: (new_dictionary) Don't try to xstrdup() a NULL + string. + +Tue Dec 2 14:36:07 1997 Ben Pfaff + + * Makefile.am: (fiasco_SOURCES) Add aggregate.c back in. + + * aggregate.c: Still working on this. + + * command.c: (cmd_table[]) Add AGGREGATE back in. + (split_words) Make '-' a legal word separator as well as ' '. + + * main.c: Comment fixes. + + * q2c.c: (dump_parser) Don't require the procedure's full name to + be present, in the generated source. + + * t-test.q: Change name to `t-test' from `t test'. Let PAIRS be + multiply specified and let it be default; let MISSING, CRITERIA, + FORMAT be multiply specified. + (cmd_t_test) Parse command name. [DEBUGGING] Call debug_print(). + (custom_groups) Fix defaults. + (custom_pairs) Check whether this is a PAIRS subcommand before + attempting to parse. Better garbage collection. Proper storage + allocation. + [DEBUGGING] (debug_print) New function. + + * temporary.c: Comment fixes. + (copy_variable) Don't copy variable name and index. + (save_dictionary) Copy variable name and index by hand. + + * vars-atr.c: Comment fixes. + (create_variable) New dictionary argument. All references + changed. + (common_init_stuff) New dictionary argument. All references + changed. + (init_variable) New dictionary argument. All references changed. + (dup_variable) New function. + + * vars-prs.c: (parse_variables) If there are any errors, we always + return 0. Previously, it was possible for some types of errors to + be ignored. + +Sat Nov 22 01:20:59 1997 Ben Pfaff + + * Makefile.am: (fiasco_SOURCES) For 0.1.5 release, remove + aggregate.c. + + * command.c: (cmd_table[]) Comment out AGGREGATE; add T TEST. + + * list.q, t-test.q: Remove ALL option from VARLIST declaration in + grammar rules. + + * q2c.c: Comment fixes. + (SBC_* enums) Remove SBC_VARLIST_ALL; all references removed. + + * t-test.q: (cmd_list) Rename cmd_t_test. + + * temporary.c: (new_dictionary) Don't declare as static. + +Fri Nov 21 00:03:06 1997 Ben Pfaff + + * aggregate.c: Changes, still not finished. + + * file-handle.q, frequencies.q, list.q, set.q: Comment fixes. + + * q2c.c: Comment fixes. Now its output is internationalized. + (get_token) Fix parsing of escapes within literal strings. + (main) Fix bad #line directives in output. + + * t-test.q: Base implementation. + + * temporary.c: (new_dictionary) New function. + (restore_dictionary) [__CHECKER__] Change fill character to * + (from @). + +Sun Nov 16 01:29:57 1997 Ben Pfaff + + * Makefile.am: (BUILT_SOURCES, fiasco_SOURCES) Add t-test.c + + * aggregate.c: Changes, still not finished. + + * descript.q, list.q: Comment fixes. + + * q2c.c: Almost completely rewritten. + + * t-test.q: New file, not complete. + +Fri Nov 14 00:14:48 1997 Ben Pfaff + + * aggregate.c: Changes, still not finished. + + * sort.c: (sort_cases) Call cancel_temporary() instead of doing it + by hand. + + * temporary.c: (cancel_temporary) New function. + + * vars-atr.c: (discard_variables) Call cancel_temporary() instead + of doing it by hand. + + * vfm.c: (close_active_file) After restoring a TEMPORARY + dictionary, set temp_dict to NULL. Cancel TEMPORARY through + cancel_temporary(). + (SPLIT_FILE_procfunc) Comment fix. + +Tue Oct 28 16:08:45 1997 Ben Pfaff + + * Makefile.am: (fiasco_SOURCES) Add aggregate.c. + + * aggregate.c: New file, not finished yet. + + * command.c: (cmd_table) Add AGGREGATE. + + * common.h: (pgm_state) Move declaration to var.h. + + * lexer.c: (bin_value_func, oct_value_func, hex_value_func) i18n + fixes. + (parse_string) Message fix. + + * recode.c: Comment fix. + + * sfm-read.c: (read_variables) Code esthetic fixes. + (write_header) Default date is `Jan', not `JAN'. + + * sfmP.h: (bswap_int32) [!__linux__] Fix off-by-one errors. + + * sort.c: (cmd_sort_cases) Farm the work out to new function + parse_sort_variables(). + (parse_sort_variables) New function. + (sort_cases) New function. Cancels temporary transformations, + which sorting didn't do previously. + (cmd_sort_cases) Better garbage collection on error. Uses + do_external_sort(). + (write_initial_runs, merge_once) Improved code esthetics. + (sort_stream_read) Reduced to one call to read_output_cases(). + (read_output_cases) New function. + + * var-labs.c: (cmd_variable_labels) Re-enabled truncation of + variable labels to 120 characters. + + * var.h: Comment fixes. + (glob var pgm_state) From common.h. + + * vars-atr.c: (discard_variables) Set pgm_state to STATE_INIT. + + * vars-prs.c: (parse_DATA_LIST_vars) Support PV_SINGLE in + options. Set *names to NULL on error. + + * vfm.c: (memory_stream_init) Assert compaction_nval != 0. + +Thu Oct 9 09:59:49 1997 Ben Pfaff + + * sfm-write.c, vfm.c: [HAVE_UNISTD] #include , needed by + SunOS4. From Alexandre Oliva . + +Wed Oct 8 18:55:24 1997 Ben Pfaff + + * vfm.c: (page_to_disk) Added missing local variables. + +Tue Oct 7 20:23:17 1997 Ben Pfaff + + * get.c: Comment fix. + + * sort.c: (cmd_sort_cases) Attempt to perform internal sort if the + source is anything other than a disk stream, not just if it's in a + memory stream. Call page_to_disk() before external sort. + (allocate_cases) Message fix. + + * vfm.c: (prepare_for_writing) Warn user when paging workspace to + disk. + (page_to_disk) New function. + +Sun Oct 5 15:56:14 1997 Ben Pfaff + + * Makefile.am: (INCLUDES) Include .. instead of $(top_srcdir). + + * common.h: (macro strerror) Remove. From Alexandre Oliva + . + + * get.c: (dict_delete_run) The number of variables to delete is + not necessarily the number of variables that need to be shifted + up. + (trim_dictionary) Don't set *options to 0. Fix bug that caused + too many variables to be deleted. + + * postscript.c: Comment fix. + + * q2c.c: Include strerror.c. From Alexandre Oliva + . + + * set.q: #undef ON and OFF. From Alexandre Oliva + . + + * sfm-read.c: (sfm_read_dictionary) Don't set the file class too + early, otherwise errors cause a bad free(). + + * str.h: (macro nvsprintf) s/FORMATS/FORMAT/ typo. From Alexandre + Oliva . + + * temporary.c: (save_dictionary) Don't allocate memory if + n_documents is 0. + + * vfm.c: (memory_stream_write) Message fix. + +Sat Oct 4 16:20:43 1997 Ben Pfaff + + * command.c: (static var cmd_table[]) Define REPEATING DATA + command. + + * common.h: Added support for broken systems that are missing + EXIT_SUCCESS, EXIT_FAILURE, RAND_MAX, and/or strerror(). + + * Many source files: Replace syntax error messages via msg() with + call to syntax_error(). + + * data-list.c: (dump_fixed_table) Add support for dumping table + for REPEATING DATA as well as DATA LIST FIXED. + (cmd_repeating_data) Allows and requires `/' between subcommands. + Does proper thing with allowing rpd.starts_end to stay 0. Allows + CONTINUED specifications to be omitted. Forces CONTINUED to be + specified if ID is. Calculates starts_end, cont_end from logical + record length as reported by fhp. Calls dump_fixed_table() if + requested. Fixed length of record copied by memcpy. + (parse_num_or_var) Sets `num' to 0, not NOT_INT, for variables. + Message fix. + (realize_value) Returns sensible value for out-of-range variable + values. + (rpd_parse_record) New argument `ofs'. Fixed confusion between + length of occurrences and length of line. Added warning for + fields that exceed the line length. Fixed infinite loop. + (read_one_set_of_repetitions) Numerous minor changes for more + complete SPSS compliance. Message fixes. + + * dfm.c: (dfm_close) If the file being closed is the inline file, + read all the remaining data before closing it. + (dfm_get_record) Don't close the file on lossage, as either it + has been closed already or it doesn't belong to us. + + * error.c: (puts_stdout) New function. + (vmsg) Use puts_stdout instead of puts. + + * file-handle.q: (fh_record_width) New function. + + * inpt-pgm.c: (init_case) Fixed buffer overrun when inp_nval % 4 + == 0. + (clear_case) Ditto. + (input_program_source_read) Made an old kluge an approved method. + + * lexer.c: (syntax_error) New function. + + * misc.c: [BROKEN_RAND] (ansi_rand, ansi_srand; static var next) + New. + + * output.c: (oupt_get_paper_size) Message fix. + + * q2c.c: Numerous fixes to formatting of generated code made to + conform to GNU coding standards. Uses syntax_error() in generated + code. Other miscellaneous generated message fixes. Added support + for broken systems that are missing EXIT_SUCCESS, EXIT_FAILURE, + RAND_MAX, and/or strerror(). + +Sat Oct 4 02:09:56 1997 Ben Pfaff + + * data-in.c: Comment fixes. + + * data-list.c: (struct repeating_data_trns) New member `id_spec'. + (find_variable_input_spec) New function. + (cmd_repeating_data) Initializes id_spec. + (rpd_parse_record) Implemented. + (read_one_set_of_repetitions) Returns -3 by default in order to + kluge out some potential bugs. + + * data-out.c: Comment fixes. + + * file-type.c: (internal_cmd_record_type) Message fix. + + * inpt-pgm.c: (input_program_source_read) Special temporary kluge + for handling -3 return value. + +Sat Sep 20 23:58:15 1997 Ben Pfaff + + * data-list.c: Comment fixes. + (struct dls_var_spec) Reordered members. + (read_from_data_list_fixed) Restructured. + (struct repeating_data_trns) Reordered members. Renamed `starts' + as `starts_beg', `ends' as `starts_end'. + (cmd_repeating_data) Calculates length of repeated data if + necessary and possible. + (parse_num_or_var) Don't allow string variables. + (realize_value) New function. + (rpd_msg) New function. + (rpd_parse_record) New function. Currently stubbed out. + (read_one_set_of_repetitions) Implemented. + + * inpt-pgm.c: (input_program_source_read) Comment fix. + +Thu Sep 18 21:34:57 1997 Ben Pfaff + + * command.c: (cmd_end_repeat_p) Removed. + (init_cmd_parser) Doesn't set cmd_end_repeat_p. + (parse_cmd_name) Removed. + + * data-list.c: Comment fixes. + (data_list_pgm) Removed `eof' member. + (static var first) New var. + (cmd_data_list) Sets `first'. Ensures that DATA LIST uses the + FILE TYPE file inside FILE TYPE structures. + (append_var_spec) Appends to *first, not dls.spec. + (parse_fixed) Message fixes. + (struct rpd_num_or_var) New. + (struct repeating_data_trns) New. + (static var rpd) New. + (cmd_repeating_data) New function. + (parse_num_or_var) New function. + (parse_repeating_data) New function. + (read_one_set_of_repetitions) New function. + + * file-type.c: (cmd_file_type) Message fixes. Always + default_handle to FILE TYPE file handle. + (internal_cmd_record_type) Message fixes. + +Wed Aug 20 14:22:03 1997 Ben Pfaff + + * repeat.c: Comment fix. Disable debugging. + + * temporary.c: (restore_dictionary) Sets splits to NULL and + n_splits to 0 before destroying the variables because now doing + this tries to remove split variables. + + * vars-atr.c: (discard_variables) Asserts that n_splits is 0 after + destroying the dictionary. + (clear_variable) Removes a variable from splits after destroying + it. + +Mon Aug 18 18:06:55 1997 Ben Pfaff + + * cmdline.c: (set_compat) Removed. + (pick_compat) Removed. + (parse_command_line) Removed -c option. + (pre_syntax_message) Removed -c option. + (usage) Remove compatibility code. + + * common.h: (macros VER_PC, VER_WND, VER_X) Removed. + (glob var compat) Removed. + + * compute.c: (type_check) Fixed messages about type mismatches. + + * data-list.c: (cmd_data_list) Removed compatibility code. + (fixed_parse_compatible) Calls convert_negative_to_dash(). + Fixed bug where it only set the variable in fx.spec if it created + the variable itself. + (dump_fmt_list) Spelling fix. + (cut_field) Removed compatibility code. + + * dfm.c: (cmd_begin_data) Don't require a command terminator on + BEGIN DATA command. + + * expr-evl.c: (evaluate_expression) Implement LAG. + + * expr-prs.c: (parse_add) Calls convert_negative_to_dash(). + (parse_neg) Calls convert_negative_to_dash(). + (LAG_func) Increases n_lag to the lag requested. Fixed assignment + bug. + + * expr.h: (struct expression_struct) Removed member max_lag. + + * file-type.c: (parse_col_spec) Calls convert_negative_to_dash(). + (internal_cmd_record_type) Removed special handling to produce + negative numbers from dash tokens. + + * getline.c: (static var DO_REPEAT_level) New var. + (getl_add_DO_REPEAT_file) Increments DO_REPEAT_level. + (handle_line_buffer) Copies the line into getl_buf; doesn't call + copy_with_DO_REPEAT_substitutions(). + (getl_read_line) Maintains value of getl_mode. Calls + perform_DO_REPEAT_substitutions() whenever DO_REPEAT_level is + positive. + (getl_close_file) Decrements DO_REPEAT_level when appropriate. + + * getline.h: (getl_mode) New glob var. + + * glob.c: Comment fixes. + (init_glob) Restructured. Sets set_seed. + (init_compat_dependent) Removed. All references removed. + (get_date) Format changed from MM/DD/YY to DD MMM YYYY. + (__htonl, __htons) Removed. (What were these for?) + + * lexer.c: (static var tbl) Dash set to class CNUM. + (make_hexit) New function from data-out.c. + (get_token_representation) Rewritten. + (convert_negative_to_dash) New function. + (lex_init_compat_dependent) Removed. + (yylex) A dash is parsed as part of a number if it is followed by + a digit. The ASCII representation of a number is copied to + tokstr. String parsing farmed out to parse_string(). Comment + fixes. + (bin_value_func, oct_value_func, hex_value_func, parse_string) New + functions. + (preprocess_line) Line processing depends on interactive/batch + mode, not on compatibility mode. Removed PC+ compatibility code. + + * loop.c: (loop_3_trns_proc) Comment fix. + + * main.c: Remove dead code. + (main) Remove call to init_compat_dependent(). + + * misc.c: (convert_fmt_ItoO) Make E format conversion more + conformant. + + * print.c: (parse_string_argument) Calls + convert_negative_to_dash(). + (fixed_parse_compatible) Calls convert_negative_to_dash(). + + * repeat.c: (RPT_* defines) Removed. + (struct rpt_numeric) Removed. + (struct repeat_entry) New member type, changed `replacement' from + char * to char **. + (clean_up) Deallocation adapted to new repeat_entry. + (internal_cmd_do_repeat) `type' defaults to 0. Remove lookahead() + usage. Creates vars for `type' of 1. + (parse_ids) Sets type of 1. Adapted to new repeat_entry. + (store_numeric) Rewritten, new interface. + (parse_numbers) Rewritten. + (parse_strings) Rewritten. + (find_DO_REPEAT_substitution) New function. + (perform_DO_REPEAT_substitutions) New function. + (copy_with_DO_REPEAT_substitutions) Removed. + (debug_print) Rewritten. + + * set.q: Comment fix. + (custom_results) Removed compatibility code. + (internal_cmd_set) Removed SET EMULATION subcommand. Removed + compatibility code. + + * sysfile-info.c: (cmd_display) Removed compatibility code. + + * tokens.h: Comment fixes. + (token types enum) Removed `toktype' typedef name for this int + type. Removed SUBST. Restructured. + + * vars-atr.c: (discard_variables) Sets n_lag to 0. + + * vars-prs.c: Comment fix. + + * vfm.c: Comment fixes. + (glob var n_lag) New var. + (static vars lag_count, lag_head, lag_queue) New vars. + (procedure) Removed argument nlag. + (setup_lag) New function. + (close_active_file) Discards lagging state. + (lag_case) New function. + (lagged_case) New function. + (write_case) Lags a case if lagging. + + * weight.c: (cmd_weight) Removed compatibility code. + +Sun Aug 17 22:34:40 1997 Ben Pfaff + + * getline.h: (struct getl_script) New members loop_index, macros. + + * getline.c: (getl_add_file) Sets first_line field to NULL. + (getl_add_DO_REPEAT_file) New function. + (handle_line_buffer) When the current line's length is negative, + set the filename and line number. Increment line number after + reading line. Pass the line to + copy_with_DO_REPEAT_substitutions() for processing. + (getl_close_file) Free DO REPEAT lines before freeing the + filename, and just set the filename to NULL when doing this, + because otherwise the filename gets freed twice. + + * glob.c: (glob var queuing) Removed. All references removed. + + * lexer.c: Comment fixes. + (get_token_representation) New function. + + * repeat.c: Comment fixes. + (struct repeat_entry) Replaced type and v union members with a + simple string. + (append_record) New function. + (internal_cmd_do_repeat) Started reforming it for the new + repeat_entry struct. Properly records filename changes in the + getl_line_buf. Fixed improper use of = for ==. Fixed sense of + strncasecmp() result usage. Uses append_record() to simplify. + Properly discards END REPEAT line. Calls getl_add_DO_REPEAT_file + to add in the file. + + (copy_with_DO_REPEAT_substitutions) Started coding. + + [DEBUGGING] (debug_print_lines) New function. + + * set.q: (custom_results, internal_cmd_set) s/VER_PCP40/VER_PC/; + + * tokens.h: (macro is_id1, is_idn) New macros. + +Sat Aug 16 10:57:41 1997 Ben Pfaff + + * cmdline.c: (static var pre_syntax_message) Changed `win' + compatibility mode to `wnd'. + + * data-list.c: (fixed_parse_spss) Renamed + fixed_parse_compatible(). + + * glob.c: (init_glob) Excise unused code for + program_invocation_short_name. + + * lexer.c: (preprocess_line) Leading indentors are ignored in Wnd + as well as in X. + + * print.c: (fixed_parse_spss) Renamed fixed_parse_compatible(). + + * set.q: `win' compatibility renamed `wnd'. + +Thu Aug 14 22:11:12 1997 Ben Pfaff + + * filename.c: [__WIN32__] Change the included Windows header files + (again). + (absolute_filename_p) [__MSDOS__] A filename with a colon as the + second character is absolute. + (dirname) Fix logic error. Don't printf() the results. + (prepend_dir) Don't printf() the results. + + * getline.c: (handle_line_buffer) New function. + (getl_read_line) Reads line with handle_line_buffer() when + appropriate. + (getl_close_file) Discard line buffer data. + + * getline.h: Comment fixes. + (struct getl_line_list) New struct. + (getl_script_struct) Added line buffer members. These are hooks + for use by DO REPEAT to allow it to insert virtual source code + into the program. + + * glob.c: (init_glob) [__DJGPP__ || (__WIN32__ && __BORLANDC__)] + Override Borland C++ stupidity that claims Windows has a console + window size of 0x3. + + * repeat.c: This is in the process of being restructured from + using a token-buffering approach to the DO REPEAT facility to + using the more flexible approach of a line-buffering approach in + conjunction with the getline module. Comment fixes. + (struct tok_struct) Removed. + (static vars queue_index, queue_head, queue) Removed. + (static vars line_buf_head, line_buf_tail) New vars. + (internal_cmd_do_repeat) Instead of queuing tokens, queue lines. + Not complete. + (pull_queue, destroy_queue) Removed. + [DEBUGGING] (debug_print_tokens) Removed. + +Tue Aug 5 13:57:58 1997 Ben Pfaff + + * file-handle.q: (prepend_current_directory) New function. + (internal_cmd_file_handle, fh_get_handle_by_filename) Prepends + current directory before normalizing filename. + + * filename.c: (gnu_getcwd) New function. + (absolute_filename_p) New function. + (search_path) New argument, PREPEND. All references changed to + pass NULL except those explicitly mentioned. Uses + absolute_filename_p(). Prepends PREPEND before trying the + filename. + (dirname, prepend_dir) New functions. + + * getline.c: (getl_get_current_directory) New function. + (getl_include) Passes getl_get_current_directory() as PREPEND arg + to search_path(). + +Sun Aug 3 11:42:36 1997 Ben Pfaff + + * In several source files, the term `script' was replaced with + `syntax file' inside error messages. Usage of the term `script' + in the sense of a syntax file is now deprecated. + + * cmdline.c: (static vars pre_syntax_message, post_syntax_message) + Updated messages. + + * dump-sysfile.c: (usage) Update message. + + * getline.c: (getl_read_line) Ignore lines beginning with `#!'. + + * getline.h: (glob var getl_include_path) Declare extern. + + * list.q: Define EXTERN as extern before #including somP.h. + + * var.h: Remove declaration of `disptype' variable. + + * vfm.c: (close_active_file) After switching the data sink to a + data source, set vfm_sink to NULL, because it doesn't exist any + more. + +Thu Jul 17 21:41:44 1997 Ben Pfaff + + * glob.c: [__BORLANDC__] Include math.h. Define _matherr() and + _matherrl() to ignore all math errors. + + * sfm-read.c: (read_value_labels) When reading the labels from + disk, read the little parts separately instead of as a struct; + this avoids alignment problems. + + * sfm-write.c: (struct sfm_fhuser_ext) New member `elem_type'. + (sfm_write_dictionary) Sets elem_type and frees it on lossage. + (write_header) Allocates and initializes elem_type. + (sfm_write_case) Uses elem_type to determine how to handle each + flt64 element. + (sfm_close) Frees elem_type. + + * sfmP.h: Comment fix. + [__BORLANDC__] Uses #pragma -a to adjust structure member + alignment. + +Thu Jul 17 01:55:12 1997 Ben Pfaff + + * Makefile.am: (fiasco_SOURCES) Remove display.c. + + * common.c: Fix typo. + + * dfm.c: (read_record) Remove strncasecmp() emulation and fix the + sense of the condition. + + * expr-evl.c: (macro ALLOC_STRING_SPACE) [!PAGED_STACK] Add + line-continuation backslash. + + * filename.c: [__WIN32__] Include before . + + * frequencies.q: (custom_grouped, add_percentile) Don't use a + non-constant expression as an argument to sizeof. + + * glob.c: [__WIN32__ && __BORLANDC__] When including , + undefine gettext macro because that's a conio function. + + * hash.h: (hsh_prime_tab declaration) Remove. + + * list.q: (write_fallback_headers) Move `leader' allocation out of + main loop. Change to local_alloc() allocation. + + * output.h: Formatting fixes. Put __attribute__ in right place on + function prototypes. + + * sfm-read.c: (read_machine_flt64_info, read_variables) Change + incorrect `SECOND_LOWEST_VALUE' references to proper + `second_lowest_value'. + + * som-frnt.c: (EXTERN macro) Define as `extern' instead of null + value. This way 2 out of 3 of the som files define the vars + extern, the correct way, that actually works under BC++. + (som_set_float) Don't use nonconstant initializers for a struct. + + * som-high.c: Add the standard alloca() header. + (replicate_table) Add prototype. + + Merged DISPLAY routine. + * sysfile-info.c: (AS_*) New enum series. + (cmd_sysfile_info) Gutted. Calls describe_variable() to do the + dirty work. + (cmd_display, display_macros, display_documents, + display_variables) Stolen from defunct display.c. + (describe_variable) New function. + + * temporary.c: [0] (display_tree) New debug function. + (copy_variable) Performs shallow copy of value labels instead of + deep copy; i.e., just copys the AVL tree and increments the + reference counts. + + * val-labs.c: Comment fixes. + (do_value_labels) Optionally skip leading forward slash. + (get_label) Creates only a single value label instead of many + copies of one, and sets the reference count. + + * display.c: Removed. + + * dump-sysfile.c: New file, not yet complete. + +Fri Jul 11 23:02:18 1997 Ben Pfaff + + For lots of source files I added more verbose_msg's. These aren't + listed below as they have tested as being benign. In some cases + these replaced debug_printf() calls. + + * output.c: (outp_read_devices) Message fix. + + * postscript.c: (output_encodings) Message fix. Reports errors on + fclose(). + (postopen) Message fix. + +Fri Jul 11 14:09:40 1997 Ben Pfaff + + * dfm.c: (dfm_close) Don't call fclose() for a NULL FILE. + + * filename.c: (close_file_ext) Set f->file to NULL *after* closing + it. + + * main.c: Remove #include. + + * mis-val.c: (parse_numeric) Set .f member for each missing[] + instead of trying to just set the missing[] itself, which is a + gcc-specific idiom. + + * sfm-read.c: (read_variables) Same. + + * str.h: Add memmem() prototype. + + * val-labs.c, var-labs.c: Replace with . + +Thu Jul 10 22:13:53 1997 Ben Pfaff + + * Makefile.am: (q2c) Don't include any libraries in the link. + + * dfm.c: (force_line_buffer_extension) New macro. + (count_tabs) New function. + (tabs_To_spaces) New function. + (read_record) Calls tabs_to_spaces() on the line being processed. + + * q2c.c: Disabled i18n for this proglet so that libintl.a doesn't + have to be compiled twice (once for CC, once for LOCAL_CC). + +Sun Jul 6 19:14:33 1997 Ben Pfaff + + * Makefile.am: (INCLUDES) Add intl directory; fix directories. + (LDADD) Add @INTLLIBS@. + (q2c) Add LIBS, @INTLLIBS@ to link step. + + * inpt-pgm.c: Turn off debugging. + + * postscript.c: (postopen) Format fix. local_free() blocks + returned by local_alloc(); don't free() them. + +Sat Jul 5 23:44:51 1997 Ben Pfaff + + * data-in.c: (parse_string_as_format) Comment fix. Fix check for + string length. + + * data-list.c: (read_from_data_list_fixed) Pass proper value for + LEN arg, not simply the full string length. + + * sort.c: (allocate_file_handles) Check SPSS compatible temp file + directories before generic temp file directories. + + * vfm.c: Disable debugging. + +Fri Jul 4 13:26:41 1997 Ben Pfaff + + * get.c: Comment fix. + (cmd_save_internal) Always passes GTSV_OPT_SAVE option. + +Wed Jun 25 22:52:28 1997 Ben Pfaff + + * expr-prs.c: (debug_print_postfix) Conditionally included on + GLOBAL_DEBUGGING. Removed out_header() reference. + + * exprP.h: Removed #undef GLOBAL_DEBUGGING. + +Sun Jun 22 22:00:28 1997 Ben Pfaff + + * ascii.c: Removed obsolete ascii_close_page() prototype. + + * command.c: (output_line) Comment fix. + + * data-in.c: Formatting fix. + (parse_string_as_format) Now the `fc' argument is used only for + the purpose of error messages; it is not an index into the string + passed. All references changed. + + * data-list.c: Comment fix. + (cut_field) Comment fix. Now returns the column number of the + position of the field cut out on success. + (parse_field) Added `column' argument. Puts the column numbers in + the error message. + (read_from_data_list_free, read_from_data_list_list) Record the + column number returned by cut_field(), pass it to parse_field(). + + * dfm.c: Comment fix. + + * do-ifP.h: Comment fix. + + * expr-prs.c: (SYSMIS_func) Implemented string-type arguments for + the SYSMIS function. + + * expr.h, exprP.h: Comment fix. + + * glob.c: (init_glob) Only calls setlocale() and family if + ENABLE_NLS set. + + * hash.h: Comment fix. + + * include.c: Comment fix. + + * output.c: Comment fix. + + * postscript.c: (ps_line_intersection) Simplified assertion. + + * repeat.c: Comment fix. + + * vars-atr.c: Comment fix. + + * vars-prs.c: Comment fix. + + * vfm.c: (vector_initialization) [DEBUGGING] Fixed undefined + behavior with usage of postincrement. + (memory_stream_read) Discards cases as it goes. + +Sun Jun 15 16:45:17 1997 Ben Pfaff + + * Makefile.am: Cleans q2c, not just distcleans it. Distcleans + foo. + + * Most source files: Includes debug-print.h, related comment + fixes. + + * cases.c: (alloc_val) Removed complex allocation code. Merely + increments default_dict.nval and returns the former value. + (envector, devector) Removed references to lv member of struct + variable. + + * common.h: (macro VME) Replaced complex definition with simple + one. + + * data-list.c: (cmd_data_list) Sets vfm_source instead of + read_active_file and cancel_input_pgm. + (read_from_data_list, cancel_data_list) Removed. + (data_list_source_read, data_list_source_destroy_source) New + functions. + (glob var data_list_source) New var. + + * dfm.c: (open_file_r, open_file_w) Simplified debug output. + (cmd_begin_data) Improved criteria for an input program accessing + the inline file. Still not perfect. + + * do-if.c: (do_if_trns_proc) Simplified debug output. + + * expr-prs.c: Comment fixes. + [DEBUGGING] (debug_print_postfix) Simplified debug output. + + * file-handle.q: (fh_close_handle) Simplified debug output. + + * file-type.c: Comment fixes. + (cmd_file_type) Sets vfm_source instead of read_active_file and + cancel_input_pgm. + (cmd_end_file_type) On failure, discards variables in place of + just canceling the input program. + (read_from_file_type) Renamed file_type_source_read. + (cancel_file_type) Renamed file_type_source_destroy_source. + (glob var file_type_source) New var. + + * get.c: (GTSV_* enum series) New enums GTSV_OPT_SAVE, GTSV_NONE. + (cmd_get) Initializes options to GTSV_NONE before passing to + trim_dictionary(). Removed `lv' reference. Sets vfm_source + instead of read_active_file and cancel_input_pgm. + (cmd_save_internal) Initializes options before passing to + trim_dictionary(). Local var `nval' removed. + (dict_delete_run) Comment fixes. + (trim_dictionary) Comment fixes. Disallows scratch variables if + GTSV_OPT_SAVE set in options. + (read_from_get) Renamed get_source_read. + (cancel_get) Renamed get_source_destroy_source. + (glob var get_source) New var. + + * inpt-pgm.c: (cmd_input_program) Sets vfm_source instead of + read_active_file and cancel_input_pgm. + (read_from_input_program) Renamed input_program_source_read. + Simplified debug output. + (cancel_input_program) Renamed + input_program_source_destroy_source. + (glob var input_program_source) New var. + + * loop.c: (loop_1_trns_proc) Simplified debug output. + + * main.c: (dump_token) Made eof output more explicit. + + * sfm-read.c: (read_variables, dump_dictionary) Removed `lv' + references. + + * sort.c: (cmd_sort_cases) Disallows scratch variables. Removed + code for always-memory or always-disk cases. malloc's case-list + based on vfm_source_info.ncases. Explicit support for + memory_stream via memory_source_cases. + (do_external_sort) Sets vfm_source instead of read_active_file and + cancel_input_pgm. + (allocate_file_handles) The temporary directory permissions are + set to 0700 instead of 0777. + (allocate_cases) Formatting fixes. Simplified debug output. + (output_record) Compacts the case if necessary before writing it + out. + (close_handle, open_handle_w) Simplified debug output. + (write_initial_runs) Destroys vfm_sink, then sets it to + sort_stream. Writes records to memory based on + vfm_sink_info.case_size. + (write_to_sort_cases) Renamed sort_stream_write(). + (merge) Simplified error handling. Simplified debug output. + Formatting fixes. + (read_from_external_sort) Renamed sort_stream_read(). + Reads records based on vfm_source_info.case_size. + (sort_stream_write) Writes records to memory based on + vfm_sink_info.case_size. + (sort_stream_mode) New function. + (glob var sort_stream) New variable. + + * temporary.c: (cmd_temporary) Simplified debug output. + (copy_variable) Removed references to `lv'. + + * title.c: (get_title) Simplified debug output. + + * var.h: Comment fixes. + (struct get_proc) Removed member `lv'. + (struct variable) Removed member `lv'. Comment fixes. + (glob vars read_active_file, write_active_file, cancel_input_pgm) + Removed. + (struct case_stream) New. + + * vars-atr.c: (discard_variables) Changed cancel_input_pgm, + read_active_file references to use vfm_source. + (init_variable, replace_variable) Removed references to `lv'. + + * vfm.c: Comment fixes. + (glob var vfm_source, vfm_sink, vfm_source_info, vfm_sink_info) + New variables. + (static var queue, qh, qt, n_lag) Removed. All references + removed. + (glob var compaction_necessary, compaction_nval, compaction_case, + paging) New variables. + (record_case) Removed. + (procedure) Comment fixes. Calls vfm_source->read() instead of + read_active_file(). + (lag) Removed. + (prepare_for_writing, arrange_compaction, make_temp_case, + vector_initialization, setup_filter) New function. + (open_active_file) Most of the code moved into the abovementioned + new functions. Now sets temp_dict to &default_dict if there is no + temporary dictionary, for convenience. New debug output. + (close_active_file) Deals with changing the sink to the source. + Calls finish_compaction(). Frees compaction_case. Mostly + rewritten. + (glob vars disk_source_file, disk_sink_file) New vars. + (destroy_active_file, read_from_memory) Removed. + (disk_stream_init, disk_stream_read, disk_stream_write, + disk_stream_mode, disk_stream_destroy_source, + disk_stream_destroy_sink) New functions. + (glob var vfm_disk_stream) New var. + (glob vars memory_source_cases, memory_sink_cases, + memory_sink_iter, memory_sink_max_cases) New vars. + (memory_stream_init, memory_stream_read, memory_stream_write, + memory_stream_mode, memory_stream_destroy_source, + memory_stream_destroy_sink) New functions. + (glob var vfm_memory_stream) New var. + (write_case) Local var `i' renamed `cur_trns'; local var `retval' + named `more_cases'. Simplified debug output. Otherwise mostly + rewritten. + (record_case) Moved into the stream drivers. Removed. + (transform) Removed (was dead code). + (SPLIT_FILE_procfunc) s/vfm_replacement/vfm_sink_info/. In the + common case that the splits don't change, we don't need to copy + the case into prev_case again--pointless. + (compact_case) New function. + (finish_compaction) New function. + + * vfmP.h: Comment fixes. + (DEV_* enum series) Removed. + (struct storage) Renamed `stream_info'. Removed variant record. + Removed `device' member. + + * debug-print.h: New file. + +Sun Jun 8 01:12:38 1997 Ben Pfaff + + * autorecode.c: Turned off debugging. + + * data-list.c: (destroy_dls) Closes the associated file handle. + + * descript.q: (custom_variables) Added PV_NO_SCRATCH to + parse_variables() options. + + * dfm.c: (open_file_r) Removed gratuituous argument to msg() call. + + * display.c: (display_variables) Really fixed null cell bug. + + * file-handle.q: (fh_close_handle) Changed debugging message. + + * frequencies.q: (custom_variables) Added PV_NO_SCRATCH to + parse_variables() options. + + * list.q: Added PV_NO_SCRATCH in q2c varlist options. + (cmd_list) Fails if no variables specified. + (determine_layout) Writes blank lines manually. + + * loop.c: (loop_1_trns_proc) Made debugging code only print + messages if debugging. + + * q2c.c: (dump_subcommand) Appends sbc->message to SBC_VARLIST + parse_variables() arguments. + (main) Parses optional parenthesized options to varlist + subcommands into sbc->message. + + * sfm-read.c: Format fix. + + * var.h: (FV_*) New enum series. + (PV_*) New enum PV_NO_SCRATCH. + + * vars-prs.c: (find_var) Removed. + (fill_all_vars) Takes FV_* enum instead of boolean third + argument. Rewritten to deal with scratch as well as system + variables. + (parse_variables) Error message on scratch variable if + PV_NO_SCRATCH set. + + * vfm.c: (static var virt_begin_func) New var. + (procedure) Sets up virt_begin_func. + (SPLIT_FILE_procfunc) For the first case, calls virt_begin_func() + after dump_splits(). For succeeding groups changes, calls + virt_begin_func() instead of begin_func(). + +Fri Jun 6 22:42:23 1997 Ben Pfaff + + * count.c, data-out.c, file-handle.q, list.q, loop.c: Turned off + debugging. + + * dfm.c: Added some debugging messages, disabled by default. + (open_file_r) Fixed error message. + (read_record) On eof on inline_file, instead of calling + fh_close_handle(), simply jump to eof label like a normal file. + Message fixes. + + * display.c: Thin lines between rows for certain kinds of + listing. Fixed `null cell' bug. + + * error.c: (failure) Flush stdout, stderr before failing. + + * file-handle.q: (fh_close_handle) Added debugging message. + + * frequencies.q: (dump_full) Bottom line extends across entire + table width. Changed title formatting. + (dump_condensed) Changed title formatting. + (dump_statistics) Fixed title formatting. + + * glob.c: (init_glob) Moved initialization of cur_proc out of #if. + Sets default value of set_format. + + * list.q: (cmd_list) Calls blank_line() before determine_layout(). + Passes write_all_headers() to procedure() as pre-group func. + (write_all_headers) New function. + (determine_layout) Removed calls to write_header(). + Calls blank_line() before and after write_fallback_headers(). + + * recode.c: (recode_trns_free) Only attempts to free head->map if + non-NULL. + + * sfm-read.c: (read_variables) Allows `#' at beginning of system + file variable names but gives a warning. Sets `left' based on + first character being/not being `#'. On lossage frees dict->var. + + * som-high.c: (som_draw_title) Simplified title formatting. + + * vfm.c: (dump_splits) Fixed and changed splits formatting. + +Thu Jun 5 22:51:15 1997 Ben Pfaff + + * autorecode.c: (cmd_autorecode) Sets h_trans to NULL at + beginning. Frees v_src, v_dest on successful exit. Frees + h_trans[*], h_trans on lossage. + (recode) Frees h_trans[*], h_trans. + + * dfm.c: (dfm_close) Formatting change. + (open_inline_file) Now passed a dfm_fhuser_ext to initialize; no + longer allocates its own in inline_file. + (open_file_r) Passes the local dfm_fhuser_ext to + open_inline_file(). + (open_file_w) Message fix. + (read_record) Buffer reallocation strategy changed. Frees + ext->line even in inline_file to prevent leaks. + (dfm_put_record) Fixed bug where `ext' was cached before the file + was opened and thus it would be NULL when the file really was + open. + (cmd_begin_data) Sets up inline_file basics itself, then calls + open_inline_file() for the dfm_fhuser_ext. Formatting fix. + + * list.q: (write_line) Formatting fix. + (clean_up) Minor strategy change. Sets proportional font after + finishing cleanup. + (determine_layout) Sets fixed font before writing regular headers, + or after writing fallback headers. + + * modify-vars.c: (cmd_modify_vars) Frees variable lists for DROP + and KEEP vars after using them. + + * postscript.c: (ps_init_driver) Frees x->family. + (postopen) When loading fonts, free the temporary font name buffer + after using it. + (ps_text_set_font_by_position) Free temporary font name buffer + after using it. + (text) Fixed code that calculated `lig' so that `lig' always gets + initialized. Formatting fix. + + * som-low.c: (get_cell_size, som_get_table_size) `prop_height' -> + `font_height'. + [GLOBAL_DEBUGGIGN] (check_table) Use arena_alloc() to allocate + cells, not xmalloc(), so that the cells will get destroyed + automatically. + + * sysfile-info.c: (cmd_sysfile_info) Frees the dictionary after + using it. + +Tue Jun 3 23:33:22 1997 Ben Pfaff + + * ascii.c: (ascii_text_draw) Always sets metrics for strings that + are drawn. + + * dfm.c: Comment fix. + + * list.q: Comment fixes. Include somP.h. Removed static vars + table, n_columns, n_rows, part. New struct list_ext. New static + var line_buf. + (n_lines_remaining, n_chars_width, write_line) New functions. + (cmd_list, list_cases) Rewritten. + (begin_row, end_row, flush_table) Removed. + (write_header, clean_up, write_varname, write_fallback_headers, + determine_layout) New functions. + + * output.c: (outp_iterate_enabled_drivers) Minor reformat. + + * output.h: Comment fix. + + * postscript.c: Comment fix. + (struct ps_driver_ext) Removed prop_size, fixed_size members; + added font_size. All references changed. + (ps_init_driver) Initializes font_size. Simplified space checking + code. + (static var option_tab[]) Removed prop-size, fixed-size; added + font-size. + (ps_option) Handles font_size. + + * som-high.c: Moved prototypes into somP.h. + (som_init_driver) New function. + (som_submit_table) Moved some code into new function + som_init_driver(). + (build_target) Moved some code into new function + som_internal_eject_page(). + (som_eject_page) Uses som_internal_eject_page(). + (som_internal_eject_page) New function. + + * som-low.c: Moved prototypes into somP.h. + + * som.h: Formatting fixes. + + * somP.h: (struct som_driver_ext) Removed em_width; + added prop_em_width, fixed_width. + +Mon Jun 2 14:25:25 1997 Ben Pfaff + + * Makefile.am: Added `localedir' definition. Added + -DLOCALEDIR="..." to DEFS. Added -I. to INCLUDES. + + * ascii.c: (macro draw_line) Fixed capitalization. + + * ascii.c, autorecode.c, cases.c, cmdline.c, command.c, common.c, + compute.c, count.c, data-in.c, data-list.c, data-out.c, + descript.q, dfm.c, display.c, do-if.c, error.c, expr-evl.c, + expr-opt.c, expr-prs.c, file-handle.q, file-type.c, filename.c, + formats.c, frequencies.q, get.c, getline.c, glob.c, groff-font.c, + hash.c, heap.c, include.c, inpt-pgm.c, lexer.c, list.q, loop.c, + main.c, mis-val.c, misc.c, modify-vars.c, numeric.c, output.c, + postscript.c, print.c, q2c.c, recode.c, rename-vars.c, repeat.c, + sample.c, sel-if.c, sfm-read.c, sfm-write.c, sfmP.h, som-frnt.c, + som-high.c, som-low.c, sort.c, split-file.c, sysfile-info.c, + temporary.c, title.c, tokens.h, val-labs.c, var-labs.c, + vars-atr.c, vars-prs.c, vector.c, vfm.c, weight.c: Marked strings + for internationlization. + + * glob.c: [HAVE_LOCALE_H] Includes locale.h. + +Sun Jun 1 23:31:18 1997 Ben Pfaff + + * do-if.c, sort.c, val-labs.c: Comment fixes. + + * glob.c: (init_glob) Uncommented, updated i18n support. + + * arena.c, ascii.c, data-in.c, descript.q, error.c, expr-evl.c, + expr-opt.c, expr-prs.c, filename.c, frequencies.q, groff-font.c, + output.c, postscript.c, sfm-read.c, som-high.c, vars-prs.c: Made + the declarations of macros taking arguments a lot nicer. + +Sun Jun 1 17:22:04 1997 Ben Pfaff + + * error.h: Removed CE, CW aliases for SE, SW. + + * q2c.c: Removed explicit streq() definition since it's duplicated + in str.h. + + * approx.h, error.h, font.h, hash.h, misc.h, output.h, somP.h, + stats.h, str.h, tokens.h: Made the declarations of macros taking + arguments a lot nicer-looking of . + Comment fixes. + +Sun Jun 1 12:02:06 1997 Ben Pfaff + + * cmdline.c: Comment fixes. + (pick_compat) Changed return type to int. Now, instead of setting + glob var `compat' to the emulation, returns the emulation. All + references changed. + (parse_command_line) Added terminating null to end of + `long_options' array definition. + (pre_syntax_message) Fixes. + (usage) Shows the default emulation in the syntax message by + calling pick_compat(). + + * getline.c: (getl_add_include_dir) Separates paths with + PATH_DELIMITER, not DIR_SEPARATOR. + + * glob.c: (init_glob) Fixed references to DEFAULT_VER_PCP40, + DEFAULT_VER_WIN61, DEFAULT_VER_X40. + + * output.c: (outp_configure_macro) Make earlier definitions for a + particular key override later ones for the same key. + +Fri May 30 19:40:49 1997 Ben Pfaff + + * ascii.c: Comment fixes. + + * output.c: (outp_get_paper_size) + s/STAT_OUTPUT_INIT_FILE/STAT_OUTPUT_PAPERSIZE_FILE/. + +Sun May 25 22:34:07 1997 Ben Pfaff + + * ascii.c, postscript.c, sfm-read.c, sfm-write.c, sort.c: Include + . GNU libc 2 enforces this! + + * command.c: (parse_cmd) Fixed problem with `else' clause being + paired with wrong `if'. Comment fix. + +Fri May 9 16:53:52 1997 Ben Pfaff + + * getline.c: [!HAVE_LIBREADLINE] (read_console) Changed + blp_getline() to getline(). + + * output.c: (outp_eval_dimension) Changed the fix from last time; + there was no variable `a'. + + * q2c.c: (get_line) Fixed boundary condition overrun bug. + +Mon May 5 21:58:22 1997 Ben Pfaff + + * output.c: (outp_evaluate_dimension) Fixed handling of negative + numbers having fractional parts. Added case of a fraction without + a whole-number part. + +Fri May 2 22:08:05 1997 Ben Pfaff + + * ascii.c: (ascii_text_get_font_position) Removed. + + * expr.h, exprP.h: Disabled debugging. + + * groff-font.c, postscript.c: Changed `groff' to `Groff' in + several places. + + * output.h: (struct outp_class_struct) Removed + text_get_font_position method. All references deleted. + + * postscript.c: Big change here. Fontmaps were completely + eliminated because of a change in philosophy. Comment fixes. + (struct ps_fontmap, ps2dit_map, font_family, dit2family_map) + Removed. + (struct ps_driver_ext) `position', `fontmap', `prop_name', + `fixed_name' members removed. New members `prop_family', + `fixed_family'. `family' member changed to type char *. + (static var ps_fontmaps) Removed. + () Removed. + (ps_init_driver) Removed obsolete references, updated. + Initializes `translate_x', `translate_y', `scale'. Doesn't read + fontmap, of course. Refers to font names through internal_name + rather than subversive means. Frees proper items. + (static var option_tab[]) Removed `fontmap-file' option; renamed + `fixed-font', `prop-font'. + (ps_option) Corresponds to option_tab[]. + (read_fontmap, release_fontmap, ps_to_dit, compare_ps2dit, + hash_ps2dit, compare_dit2family, hash_dit2family, compare_family, + hash_family) Removed. + (postopen) Generates font names from family names. Gets + PostScript font name properly. New prologue file comment `!!!' + style. + (ps_open_page) Adds translate_x, translate_y to BP prologue + function; gives SF argument floating-point format. + (ps_text_set_font_by_name) Doesn't try to map PostScript->Groff + font name. Doesn't change font family. + (ps_text_set_font_by_position) Generates Groff font name from font + family name instead of through table lookup. + (ps_text_set_font_by_family) Renamed `ps_text_set_font_family', + all references changed. Reduced to simple string assignment. + (ps_get_font_name) Removed. + (ps_get_font_family) Reduced to string return. + (text) Doesn't save `position' since it no longer exists. Ugly + kluge to save font family--fix soon? + (load_font) Removed PostScript name argument. + +Thu May 1 14:58:59 1997 Ben Pfaff + + * postscript.c: Comment fix. + (ps_open_page) Puts scale factor in PostScript output. + +Sat Apr 26 11:49:32 1997 Ben Pfaff + + * Makefile.am: Distcleans q2c. + +Wed Apr 23 21:33:48 1997 Ben Pfaff + + * ascii.c: (delineate) Sets text size even if width is zero. + + * command.c: Comment fix. + (static var cmd_table[]) Re-enabled EVALUATE command. + (parse_cmd) Lotsa comment fixes. Fixed infinite loop in parsing + of comments in script files. Now more liberal on criteria for + performing a state transition--if *anything* happened correctly, + not just if *everything* happened correctly. + + * data-out.c: (convert_F) Comment fix. Why in the fsck does + Checker segfault on formatting large numbers and why in the fsck + hadn't I noticed this before? + + * expr.h, exprP.h: No longer turn off GLOBAL_DEBUGGING. + + * list.q: (cmd_list) Commented out the actual output routine + because of various problems. Probably will abandon the idea of + using the general `crushed tables' for the LIST procedure. + + * temporary.c: (restore_dictionary) Sets var_by_name to NULL after + clearing it. Allocates a new var_by_name dictionary before trying + to add members to it. + + * vars-atr.c: [DEBUGGING] (dump_one_var_node) Removed argument + `sib'. Changed type of `node' argument. + [DEBUGGING] (dump_var_tree) Replaced avlwalk() with + avl_walk_inorder(). + (clear_variable) Only dumps the var tree if var_by_name non-NULL. + [DEBUGGING] Only deletes the variable from var_by_name if that var + non-NULL. + +Fri Apr 18 16:48:41 1997 Ben Pfaff + + * Makefile.am: Added include files to SOURCES. Added + frequencies.q to EXTRA_DIST. Removed include/ from INCLUDES. Now + includes rules for q2c. Added `boast' target. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-clean Makefile.in. + + * Makefile.am: Fixed redundant EXTRA_DIST line. + + * ascii.c: Comment fixes. + (ascii_line_vert) Fixed overly aggressive range check. + + * display.c: Removed dead code. + + * list.q: Turn debugging on. + (flush_table) New debug code. + + * sfm-read.c: (read_value_labels) malloc's the structure before + trying to assign to its members. + + * sfm-write.c: Comment fix. + + * som-high.c: (som_submit_table) Sets som.t and som.d on each call + to output_table(). + (output_table) No arguments anymore--gets them through `som' + global. New debug code. In crushed tables, now sets `htv' as + well as `hv' to avoid bad confusion later. + (dump_crush_page) New debug code. + + * som-low.c: (som_dump_crush_page) New debug code. + +Thu Mar 27 01:11:29 1997 Ben Pfaff + + All source files: Broke long lines into multiple lines. + + * ascii.c: (ascii_close_page) Uses host_system var in place of + HOST_SYSTEM constant. + + * cmdline.c: (var syntax_message[]) Broke into + pre_syntax_message[] and post_syntax_message[]. + (usage) Outputs both parts, separated by driver list. + + * error.h: Fixed broken formatting. + + * expr-opt.c: (str_search, str_rsearch) New functions. + + * misc.c: (blp_getdelim) Removed. All references changed to + `getdelim'. + (str_search, str_rsearch) Removed. + (memrmem) New function. + + * misc.h: (blp_getline) Removed. All reference changed to + `getline'. + + * stat.h: New file. + + * filename.c: Includes "stat.h", not . + (blp_getenv) Uses host_system var instead of HOST_SYSTEM constant. + + * output.c: (outp_list_classes) Changed output formatting. + + * sfm-write.c: (write_header) Uses host_system var instead of + HOST_SYSTEM constant. + (write_rec_7_34) Extracts version numbers from the version string. + Untested. + + * sort.c: Includes "stat.h", not . + + * str.c: (strcasecmp) Removed. + + * title.c: (cmd_document) Uses host_system var instead of + HOST_SYSTEM constant. + + * version.c: Generated on-the-fly by the Makefile instead of being + static. + + * str.h: Comment fixes. Doesn't substitute for missing memmove or + memcpy. + [!HAVE_STRNCASECMP] Declares strncasecmp(). + + * version.h: Removed stray character. Comment fixes. + (vars host_system, build_system) New vars. + +Mon Mar 24 21:47:31 1997 Ben Pfaff + + * Most source files: Changed formatting of copyright notice; fixed + FSF address; reformatted to better conform to GNU standards; + comment fixes. Added markups to prevent GNU indent from messing + up my beautiful formatting :-). + + * q2c.c: (get_line) Ignores lines that begin with `/* *INDENT' so + that GNU indent markups can be passed through without problems. + +Wed Feb 19 21:30:31 1997 Ben Pfaff + + * get.c: Turned off debugging. + + * glob.c: (init_glob) Turned on save-file compression by default. + + * sfm-write.c: (sfm_write_case) Fixed bug which resulted in less + compression than was possible in save files. + +Sun Feb 16 20:57:20 1997 Ben Pfaff + + * data-out.c: (convert_F) Comment fixes. Debug message fixes. + + * frequencies.q: Removed Fiasco extensions. Updated calculation + algorithms. Polished output format. + (struct frq_info_struct) Removed members `max_degree', `min_n', + all references removed. + (macro frq_extensions) Removed. + (static vars min_n, max_degree) Removed, all references removed. + (internal_cmd_frequencies) Doesn't handle extensions. Doesn't + calculate `min_n', `max_degree'. + (postcalc) Passes new arg to dump_statistics(). + (dump_full) Honor NOLABEL option. Buggy? Adds variable name + title. + (dump_condensed) Adds variable name title. + (sum_freqs) Removed. + (calc_stats) Updated calculation algorithm. + (dump_statistics) Removed warning for too-few observations. + Changed table formatting. Adds variable name title if passed new + arg is nonzero. + + * output.h: Comment fix. + + * recode.c, sample.c, sort.c: Disabled debug code. + + * som-frnt.c: (som_set_value, som_set_float, som_set_text) + Improved debug code. + + * var.h: (enum series frq_*) Removed Fiasco extensions. + +Sat Feb 15 21:26:53 1997 Ben Pfaff + + * command.c: Added PROCESS IF to command table. + + * Lots & lots of places, removed checks for NULLs preceding calls + to free_expression(), which itself checks. + + * descript.q: Removed Fiasco extensions. Removed optimizations + for non-weighted active files. Implemented some options. + Finished polishing output format. Comment fixes. Merged + `descript.g'. + (static vars n_glob_miss_list, n_glob_valid, n_glob_missing, + max_degree, min_n) Removed. + (macro dsc_extensions) Removed. + (struct dsc_info_struct) Removed `min_n' member, all references + fixed. + (internal_cmd_descriptives) Removed calculation of min_n, + max_degree. Only deals with one `calc' routine instead of two + flavors. + (precalc) Eliminated redundancy. Updated for changes to + descriptives_proc structure. + (calc) Moved here from `descript.g'. Rewritten to calculate + statistics via `moments about the mean' rather than by summing, + summing squares, summing cubes, and so on. + (postcalc) Rewritten for new-style statistical calculation. + (display) Removed support for displaying variables across rows. + No longer crushes the descriptives table. Removed ancient code. + Added display of N, by variable and listwise. + + * descript.g: Removed; merged into `descript.q'. + + * expr-evl.c: (evaluate_expression) Now returns a double. For + numeric results, it returns the result as well as storing it in + the passed `value' structure if non-NULL. For string results it + just returns 0.0 and it must be passed non-NULL. Many references + to this function were optimized by use of this change, especially + but not exclusively in `compute.c'. + + * frequencies.g: Comment fix. + + * glob.c: (glob var process_if_expr) New global var. + + * postscript.c: (static var option_tab[]) Corrected entry for + `fixed_size'. + (postopen) Sets x->size to x->prop_size. + (ps_text_set_font_by_name) Sets font size as well as typeface for + PROP and FIXED fonts. + + * sel-if.c: (cmd_process_if) New function. + + * sfm-write.c: (struct sfm_fhuser_ext) New member `n_cases'. + (sfm_write_dictionary) Sets `n_cases' to 0. + (sfm_write_case) Increments `n_cases'. + (sfm_close) Attempts to seek the system file back to the header + and write the number of cases in its proper slot. + + * som-frnt.c: (som_insert_table) Masks off expansion options since + only SOPT_X_NORM seems to work sensibly. + + * som-low.c: (get_cell_size) Fixed bug when a table cell was sized + with a `fixed' value of 2. + + * sort.c: (cmd_sort_cases) Cancels PROCESS IF. + + * sysfile-info.c: (cmd_sysfile_info) Doesn't display more than 10 + value labels; uses SOPT_NONE instead of SOPT_X_BOTH. + + * var.h: (enum series dsc_*) Removed Fiasco extensions. + (struct descriptives_proc) Removed `miss_noweight'; new members + `X_bar', `M2', `M3', `M4', `min', `max'. + + * vars-atr.c: (discard_variables) Cancels PROCESS IF. + + * vfm.c: (close_active_file) Cancels PROCESS IF. + (write_case) Doesn't process cases unselected by PROCESS IF. + +Fri Feb 14 23:32:58 1997 Ben Pfaff + + * glob.c: (glob var err) Removed. + + * sysfile-info.c: (cmd_sysfile_info) When adjusting table size, + doesn't have to take into account number of value labels since + they're in a subtable anyway. Also, doesn't display more than 10 + value labels since we can't yet break pages in subtables. + +Tue Feb 4 15:15:50 1997 Ben Pfaff + + * som-frnt.c: (som_change_table_size) Simple change for elegance + that shouldn't change behavior. + (som_set_value) Comment fix. + + * som-high.c: (som_submit_table) Message fix. + +Wed Jan 22 21:54:00 1997 Ben Pfaff + + * command.c: Added SYSFILE INFO to command table. + + * file-handle.q: (fh_handle_filename) New function. + + * get.c: (save_trns_proc) Fixed a bug in padding of output data + with spaces. + + * main.c: (parse) New return value for command functions, -3. + + * misc.h: Comment fix. + + * output.h: Comment fixes. + (macro COMPONENTS) Removed. + + * postscript.c: (write_text) Modified literal_chars[] so that `(' + and ')' are not written to the output in strings as literals. + + * sfm-read.c: (sfm_read_dictionary) New argument. + (read_header) New argument. Sets the information structure's + values from the header information. + (read_variables) [__CHECKER__] Redefines isalnum()--some sort of + bizarre Checker problem, I guess. + (read_variables) Proper cleanup on lossage. + + * sfm.h: (struct sfm_read_info) New struct for use by + sfm_read_dictionary(). + + * som-frnt.c: (som_create_table) New argument CREATE_FLAGS, + currently used just for tables that can be dynamically resized and + thus have to be allocated with arena_malloc() instead of + arena_alloc(). All references changed. + (som_change_table_size) New function. + (som_insert_table) Bugfix: now inserts `cell', not `c'! + + * som-high.c: [GLOBAL_DEBUGGING] (check_table) Moved to som-low.c. + (som_submit_table) [GLOBAL_DEBUGGING] Doesn't call check_table() + any more. + + * som-low.c: (draw_cell) Calls draw_table_cell() for SCON_TABLE + cells. + (draw_intersection) Now takes an argument specifying the table in + question. All references changed. + (draw_table_cell) New function. + (som_get_table_size) [GLOBAL_DEBUGGING] Calls check_table(). + (som_get_table_size) Many nice new explanatory comments. + [GLOBAL_DEBUGGING] (check_table) Moved here from som-high.c. + + * som.h: New enum series SOM_CREATE_* for use as create flags with + som_create_table(). + + * str.h: Moved a comment here from TODO. + + * sysfile-info.c: New file. Reference implementation. + +Sun Jan 19 14:22:11 1997 Ben Pfaff + + * command.c: Added RENAME VARIABLES to table of commands. + + * data-in.c: (dls_error) Sets `cust_field'. + (parse_N) Message fix. + (parse_day_count) New function. + (to_roman) Never outputs VX as a `short form' of V. + (parse_month) Fixed parsing of Roman numerals. + (parse_trailer) Message fix. + (parse_DATE, parse_ADATE, parse_EDATE, parse_SDATE, parse_JDATE, + parse_QYR, parse_MOYR, parse_WKYR, parse_DTIME) Issue a message if + the date is invalid. + (parse_SDATE) Fixed swapped day, year. + (parse_JDATE) Fixed bug for dates in 1582. + (parse_DTIME) Allows days not between 1 and 31. + (parse_numeric) Makes local copy of f.type for easier usage. + FMT_DOLLAR fixed. + + * data-out.c: (convert_F) When outputting as scientific, properly + sets f.type as fp->type. + (insert_commas) Fixed operator precedence problem with setting of + nitems. Changed strcpy to memcpy (no null terminator). + (convert_date) Fixed FMT_JDATE: added 1900 to year. + (convert_CCx) Essentially rewritten, but now it works. + + * display.c: (cmd_display) Added DISPLAY FILE LABEL (undocumented + feature of Fiasco). + (display_documents) Implemented. + + * error.c: (glob var cust_field) New var. + (vmsg) Displays cust_field as part of message classes DE and DW. + + * formats.c: (debug_print) Fixed to compile under updated + dictionary format. + + * get.c: (cmd_get, cmd_save_internal) Close file handle on + failure. + + * misc.c: (parse_format_specifier) Formatting fix. + + * modify-vars.c: (struct var_modification) Renamed `n_reorder' as + `n_rename' for clarity. + (cmd_modify_vars) Initializes `forward' and `positional' at + appropriate times. Frees lists of vars to rename on failure. + Comment fix. Frees memory on success. + (rearrange_dict) Simplified `for' loop condition. + + * rename-vars.c: New file (reference implementation). + + * set.q: (internal_cmd_set) Fixed `emu' test condition. + + * sfm-read.c: (read_header) File label is created only if file + label in file is not blank. + (read_variables) Initializes `dict' local variable. + (read_documents) Proper behavior on lossage. + + * sfm-write.c: (write_header) Doesn't blank out the file label + (why was this here to begin with?!) + + * temporary.c: (save_dictionary) File label is copied only if + non-NULL. Doesn't try to xstrdup() dictionary documents. + Adapted so as to not irritate Checker. + (free_dictionary) Only destroys var_by_name if non-NULL. + + * title.c: (cmd_file_label) Doesn't skip FILE, LABEL tokens. + (cmd_document) Doesn't skip DOCUMENT token. Adds some header + lines to the document, indents the document. Also, it works now. + (add_document_line) New function. + + * var.h: (struct dictionary) Reordering. + + * vars-prs.c: (parse_variables) On lossage, only local_free()'s + bits if it was allocated to begin with. + +Thu Jan 16 13:08:57 1997 Ben Pfaff + + * command.c: Added MODIFY VARS to list of commands. + + * configure.in: Updated custom macros for autoconf 2.12. Removed + mmap reference; fixed termcap library reference. + + * display.c: (display_variables) Fixed a few bugs although it's + still not well written. + + * error.c: [!__CHECKER__] (chkr_disp_call_chain) New function. + (induce_segfault) Calls chkr_disp_call_chain() instead of + inducing an actual SIGSEGV. + + * expr-opt.c: (evaluate_tree) Swapped order of arguments to + str_search() and str_rsearch(). Fixed tests for matches on + OP_INDEX and OP_RINDEX. + + * filename.c: (good_getcwd) Removed as the new libc for Checker + doesn't contain this bug, apparently. + + * misc.c: (str_search, str_rsearch) Changed order of arguments for + consistency with GNU memmem. + (blp_getdelim) Changed `len' from `int' to `size_t'. + + * modify-vars.c: Reference implementation. + + * som-frnt.c: (zero_length) New global var. + (som_create_table) Message fix. + + * som.h: Added gcc attributions to som_set_text(), + som_output_text() prototypes. blank_line() refers to + zero_length[] instead of a literal null string to suppress gcc + warnings. + + * sort.c: (do_external_sort) Fixed fencepost error on lossage. + (allocate_cases) Decrements x_max so the last element of x[] can + be used by the algorithm. + + * var.h: Changed minor details of `variable' declaration. + (struct modify_vars_proc) New struct. + (struct variable) Added field p.mfv. + + * vars-atr.c: Comment fix. + + * vars-prs.c: (fill_all_vars) More optimal implementation. + + * vfm.c: (dump_splits) Sets the last byte of temp_buf to a null + character, which it shouldn't have to do but printf() seems to + read the null byte even though I supply a maximum length... + +Fri Jan 10 20:22:08 1997 Ben Pfaff + + * command.c: Removed command alias X for QUIT. + (parse_cmd) Fixed comment parsing. + + * dfm.c: (struct dfm_fhuser_ext) Fields `len', `size' are now of + type size_t. + (read_record) Fixed references to len, size. + (dfm_get_record) Restructured. + + * file-handle.h: (struct file_handle) Field `lrecl' now of type + size_t. + + * file-handle.q: (internal_cmd_file_handle) Checks for nonpositive + record length. + + * modify-vars.c: New file. Not complete. + + * set.q: (set_ccx) Fixed operator precedence problem regarding ^ + and ==. + + * sfm-read.c: (bswap_flt64, read_header, write_variable) Fixed + problems caused by int/size_t differences. + + * sort.c: (output_record, merge_once) Cast `size_t's to `int's in + appropriate spots. + + * str.c: (strcasecmp) Fixed bug that cropped up when the strings + being compared were of equal length. + +Thu Jan 2 19:08:23 1997 Ben Pfaff + + * command.c: Added DOCUMENT, DROP DOCUMENTS, FILE LABEL. + + * lexer.c: (get_dotted_rest_of_line) New function. + + * sel-if.c: (cmd_filter) Cannot choose string or scratch variables + as filters. + + * sfm-read.c: (sfm_read_dictionary) Calls read_documents() to read + type 6 records. Frees the dictionary properly. + (read_header) Initializes the dictionary instead of letting + read_variables() do it. Sets the dictionary file label from the + system file. + (read_documents) New function. + + * sfm-write.c: (sfm_write_dictionary) Calls write_documents() to + write type 6 record if appropriate. + (write_header) Writes file label from dictionary. + (write_documents) New function. + + * temporary.c: (save_dictionary, restore_dictionary, + free_dictionary) Properly handle new fields in dictionary struct. + + * title.c: (get_title) Returns after failure(). + (cmd_file_label, cmd_document, cmd_drop_documents) New functions + for new commands FILE LABEL, DOCUMENT, DROP DOCUMENTS. Untested. + + * var.h: (struct dictionary) New fields `label', `n_documents', + `documents'. + +Wed Jan 1 22:08:10 1997 Ben Pfaff + + * command.c: Added FILTER to list of commands. + + * frequencies.g: [WEIGHTING] Removed test for weighting!=-1 since + it's always true. + + * get.c: (cmd_save_internal) Removed weighting code since it's now + handled by sfm-write.c. Properly commented out debug code. + + * glob.c: (glob var weighting) Removed. + + * sel-if.c: Comment fixes. + (cmd_filter) New function. + + * sfm-read.c: (struct sfm_fhuser_ext) New field `weight_index'. + (sfm_read_dictionary) Sets weighting variable direct in the + created dictionary now. (Apparently we previously didn't support + weighting on GET?) + (read_header) Sets weight_index field in sfm_fhuser_ext from + header read from disk. + + * sfm-write.c: (sfm_write_dictionary) Comment fix. + (write_header) Now sets the weighting in the header from the + passed primary dictionary instead of from the sfm_write_info. + + * sfm.h: (struct sfm_write_info) Removed field `weight'. + + * som-high.c: (dump_crush_table) Fixed a couple of assertions that + broke on boundary conditions. + + * var.h: (struct dictionary) New fields `weight_var', + `weight_index', and `filter_var'. + (glob var weighting) Removed. This is now part of struct + dictionary. All references changed; the less mechanical changes + are described above. + + * vars-atr.c: (find_dict_variable) New function. + + * vfm.c: (static var filter_index) New variable. + (open_active_file) Initializes filter_index from default_dict. + (write_case) Calls proc_func() only if the filter variable is + nonzero; this implements FILTER behavior. + + * weight.c: (static var weight_varname) Removed. + (cmd_weight) Modified default_dict instead of glob vars. + (update_weighting) Changed the signature to modify a dictionary + instead of glob vars. Now returns the weighting variable. + (get_weighting_variable) Removed; its function is absorbed by + update_weighting(). + (stop_weighting) Operates on a dictionary now. + +Wed Jan 1 17:00:59 1997 Ben Pfaff + + * sort.c: Removed debugging info from messages. + (do_external_sort) Cleans up after itself by deleting the + temporary directory on failure. (On success it is deleted by the + input program.) + (allocate_cases) Removed debug code. Added clean up code. + (output_record) Removed debug code. + (merge) Added code to close all the input files that are currently + open. This is a likely location for bugs, because I'm not sure + about boundary conditions. Removed an unnecesary heap_delete(). + (merge_once) Removed input file "optimization" that in fact + screwed up the rest of the code. Message and comment fixes. + +Sun Dec 29 21:36:48 1996 Ben Pfaff + + * error.c: [__CHECKER__] (induce_segfault) Flushes output streams. + + * heap.c: (heap_delete) New argument. + + * sort.c: Finished implementation of external sort. + + * vfm.c: (read_from_disk) Returns after a disk error. + +Sun Dec 22 23:10:39 1996 Ben Pfaff + + * sort.c: (static var state) Removed. + (static vars max_handles, tmp_basename, tmp_extname, + huffman_queue) New variables. + (do_external_sort) Moved most code to new functions. + Creates huffman_queue. + (allocate_file_handles, allocate_cases) New functions. + (static vars run_no, run_length, file_index, case_count) New + variables. + (output_record) Returns success. Now really writes to the output + file. + (begin_run, end_run) New functions. + (write_initial_runs) Returns success. Initializes run_no to -1. + Calls begin_run(), end_run() at appropriate times. Outputs debug + messages. + (write_to_sort_cases) Calls begin_run(), end_run() at appropriate + times. + (merge) New function. + + * heap.c, heap.h: New files. Hopefully in near-final form. + +Sat Dec 21 21:51:04 1996 Ben Pfaff + + * glob.c: Added write_active_file to global vars. + + * sort.c: Several new miscellaneous static variables. + (cmd_sort_cases) Big comment fix. + (perform_case_2) Renamed `do_external_sort' and completely + rewritten. + (case_2_proc_func) Removed. + (output_record, write_initial_runs, write_to_sort_cases, + compare_record) New functions. + + * vfm.c: [DEBUGGING] (index_to_varname) Excised bit rot. + +Tue Dec 17 18:57:59 1996 Ben Pfaff + + * sort.c: (perform_case_2) Changed the method for allocation of + lots of memory--now allocates one case at a time in hopes that + more cases can be allocated with heavily fragmented memory. + + * var.h: (write_active_file) New global var. + + * vfm.c: (procedure, close_active_file, write_case, + SPLIT_FILE_procfunc) Now allow beginfunc, procfunc, and endfunc + arguments to procedure() to be NULL. All references to + procedure() that made use of dummy functions were changed to NULL + functions. + (open_active_file) If write_active_file is non-NULL, the output + device becomes DEV_PGM (a new enum). + (close_active_file) Sets write_active_file to NULL. + (read_from_memory) Comment fix. + (record_case) Calls write_active_file() when the output device is + DEV_PGM. + +Sun Dec 15 15:32:16 1996 Ben Pfaff + + * sort.c: New file. + + * autorecode.c: (cmd_autorecode) Fixed parsing of options. + Fixed checking for duplicate varnames. + (recode) xmalloc()'s the transformation instead of arena_alloc()'ing + it. + (autorecode_trns_free) Destroys hash tables for each recoding + specification. + (autorecode_proc_func) Compares NULL to *vpp instead of vpp. + + * command.c: Added SORT CASES to cmd_table. + (null_func, null_int_func) Prototyped. + + * descript.g: (calc_weight, calc_noweight) Computes own case + number now. + + * frequencies.q: (dump_statistics) Fixed problem with + too-few-cases warning message. + + * get.c: (cmd_save_internal) Handles weighting properly. + + * hash.c: (hsh_dump) Output format changed. + (force_hsh_insert) Actually works now, prototype changed. + + * list.q: (static var case_num) New variable. + (cmd_list) Initializes case_num. + (list_cases) Increments case_num. + + * var.h: Added definitions for SORT CASES. Comment fixes. + + * vfm.c: Some definitions moved to new file vfmP.h. Comment + fixes. `active' renamed vfm_active, `rep' renamed + vfm_replacement, all references changed. + (procedure) The procfunc no longer receives a case number. All + references changed. + (write_case) Subtle reordering. + (SPLIT_FILE_procfunc) Counts cases differently. Slightly less + redundant. + + * weight.c: (get_weighting_variable) New function. + + * vfmP.h: New file with definitions from vfm.c. + +Sat Dec 14 10:35:30 1996 Ben Pfaff + + * command.c: (FILE_TYPE_okay) Commented out some tests because + they're clumsy and not yet needed. + + * var.h: Most *_trns structures moved to their respective source + files. Some were moved into a new file, do-ifP.h. Comment fixes. + (union any_trns) Changed to a typedef for trns_header. + (struct input_program_pgm) Removed. + + * vars-prs.c: (parse_variables) Only local_free()'s bits if it + was allocated in the first place. + +Fri Dec 13 21:30:53 1996 Ben Pfaff + + * autorecode.c: New file. + + * command.c: Added AUTORECODE to command table; re-enabled SET. + + * data-out.c: (convert_F) Handles infinities and NaNs properly. + + * error.c: (vmsg) Comment fixes. + + * hash.c: Comment fix. + (hashpjw_d) New function. + (hashpjw) Reimplemented as call to more general function + hashpjw_d(). + (internal_comparison_fn) Initializes pointers properly. + (hsh_sort) [GLOBAL_DEBUGGING] New debugging code. + (force_hsh_insert, force_hsh_find) New debugging wrapper + functions. + + * main.c: (main) Message fix. + + * output.c: (outp_read_devices) Message fix. + + * set.q: Comment fixes. + (custom_results) Implemented Wnd/X form of subcommand. + (set_routing) New function. + (internal_cmd_set) Implemented ERRORS, MESSAGES. + + * settings.h: (SET_ROUTE_*) New enum series. + (set_results) Renamed set_results_file, all references changed. + (set_messages) Removed. + (glob vars set_errors, set_messages, set_results) New vars. + + * title.c: (get_title) Remembers to xstrdup() the result of + get_rest_of_line(). + + * var.h: (arc_item, arc_spec, autorecode_trns) New structures for + use by AUTORECODE. + (union any_trns) New element `arc'. + +Fri Dec 6 23:53:47 1996 Ben Pfaff + + * command.c: (output_line) Removed references to set_screen. + + * error.c: (static var terminating) New var. + (hcf) Sets terminating to 1. + (vmsg) If terminating is nonzero, does not attempt to call hcf(). + This prevents an infinite loop if an error occurs within hcf(). + + * expr-evl.c: (evaluate_expression) [__CHECKER__] Replaced case + statement circumlocution with `case 42000' trick. + (evaluate_expression) New support for OP_STR_MIS. + + * expr-opt.c: (evaluate_expression) [__CHECKER__] Replaced case + statement circumlocution with `case 42000' trick. + (dump_node) Handles OP_STR_MIS. + + * expr-prs.c: (MISSING_func, SYSMIS_func) Rewrote to handle string + variables exceptions. + (parse_function) Message fix. + (ops[]) Added OP_STR_MIS. + + * expr.h: Added OP_STR_MIS to OP_* enum. Comment fixes. + + * exprP.h: [__CHECKER__] Removed case statement circumlocution. + + * glob.c: Removed set_scrnfile glob var. + (init_glob) set_errorbreak set to 0 by default. + + * groff-font.c: Changed included files. + (groff_read_font) Initializes font_arena local var correctly. + (default_font) New function. + + * output.c: Comment fixes. + (glob var disabled_devices) New variable. + [GLOBAL_DEBUGGING] (static var iterating_driver_list) New + variable. + [GLOBAL_DEBUGGING] (reentrancy) New function. + [GLOBAL_DEBUGGING] (outp_read_devices, outp_done, find_driver, + outp_iterate_enabled_drivers) Calls to reentrancy(). + (destroy_list) New function. + (outp_done) Moved code to destroy_list(). + (parse_options) Parses `listing', `screen', `printer' options + internally. + (configure_driver) Sets new `device' member of driver. + (outp_iterate_enabled_drivers, outp_enable_device) New functions. + + * output.h: Comment fixes. New enum series OUTP_DEV_*. + (struct outp_driver_struct) New member `device'. + + * postscript.c: (find_encoding_file) Doesn't display its own error + messages. + (default_encoding) New function. + (switch_font) Calls default_encoding() if no encoding can be + found. + (text) Makes up a character metric if none exists for the desired + character. + (load_font) Properly copies a fallback filename. Calls + default_font() for a font if none at all are known. + + * set.q: Comment fixes. Removed OUTPUT subcommand. + (custom_listing) Calls outp_enable_device() to enable/disable + listing device. + (turn_screen_on) Removed. + (internal_cmd_set) Calls outp_enable_device() to enable/disable + screen, printer devices. + + * settings.h: Comment fixes. + (glob vars set_output, set_printer, set_screen, set_scrnfile) + Removed. + + * som-high.c: (som_submit_table, som_eject_page) Use + outp_iterate_enabled_drivers() instead of iterating + outp_driver_list directly. + +Wed Dec 4 21:34:17 1996 Ben Pfaff + + * data-in.c: (parse_EDATE, parse_SDATE) New functions. + (parse_string_as_format) Handles new formats. + (parse_numeric) Now handles DOT and PCT formats. + + * data-out.c: (convert_E, convert_F, insert_commas) Handle DOT + format now. + (convert_date) Handle EDATE and SDATE formats. + (convert_CCx) Now if there's not room for the currency characters, + converts it as F format if it's positive instead of giving up + quickly. Also fixed save-and-restore bug with decimal point + characters. + (convert_format_to_string) Handles new formats. + + * misc.c: (formats[]) Added new formats. + (convert_fmt_ItoO) Supports new formats. + + * sfm-read.c: (parse_format_spec) Supports new formats. Better + data checking. New argument, all references changed. + + * sfm-write.c: (write_format_spec) Supports new formats. + + * var.h: New formats FMT_DOT, FMT_PCT, FMT_EDATE, FMT_SDATE. + Comment fixes. + +Sun Dec 1 17:19:00 1996 Ben Pfaff + + * cmdline.c: Comment fixes. + (parse_command_line) Changed return type to void. + + * data-in.c: (parse_string_as_format) Added FMT_CCA...FMT_CCE to + switch. + (parse_numeric) Handles international numbers (comma as decimal + point). Some reformatting. + + * data-list.c: (parse_free) Default output format is now + set_format instead of hard-coded F8.2. + (read_from_data_list_list) Emits error message on undefined data + only if set_undefined is nonzero. + + * data-out.c: (convert_E) Changes decimal point from period to + comma if appropriate. Restructured. Better comments. + (convert_F) Changes decimal point from period to comma if + appropriate. + (insert_commas) Major bug with handling of negative values fixed. + Also, inserts periods instead of commas if appropriate. + (convert_CCx) New function. + (convert_format_to_string) Added FMT_CCA...FMT_CCE to switch. + (num_to_string) Changed `.' to set_decimal. + + * dfm.c: Comment fixes. + (dfm_close) Frees ext->line even in inline_file. + (open_inline_file) New function. + (open_file_r) When opening the inline file: now properly + recognizes `BEGIN DATA.' line, and calls open_inline_file() to + finish up. + (read_record) Calls fh_close_handle() instead of dfm_close() to + close the inline file. Makes a copy of the line getl_buf to avoid + interlock problems. + (dfm_get_record) Restructured. Now checks the return value of + open_file_r(). + (cmd_begin_data) Moved open code into open_inline_file(). Relaxed + checking for use of inline file. No longer tries to close inline + file. + + * error.c: (glob var error_already_flagged) New var. + (vmsg) Message change. Now checks max number of errors/warnings, + acts on it. + + * file-handle.q: (fh_handle_name) Now allows closing of + inline_file. + (fh_init_files) Reformatted. + + * get.c: (trim_dictionary) Checks SCOMP option instead of COMP. + + * getline.c: (getl_include) Fixed bug that popped up when called + when file queue was empty. + (read_console) Resets error_count, warning_count, + error_already_flagged to zero. + + * glob.c: Many changes to update list of variables. + (init_compat_dependent) Now this function is called whenever + `compat' changes. It now sets set_seed only if it hasn't + previously been referenced. It now calls + lex_init_compat_dependent(). + + * include.c: (cmd_include_at) Frees temporary buffer instead of + line buffer. + (cmd_include) Doesn't make copy of include file name. + + * lexer.c: Comment fixes. + (init_lex) Moved some code into new function + lex_init_compat_dependent(). + (lex_init_compat_dependent) New function. + (hex_val) Simplified. + (preprocess_line) Uses set_endcmd instead of hardcoding `.'. + + * main.c: Comment fixes. + (main) Reformatted. + + * misc.c: (formats[]) Added FMT_CCA...FMT_CCE. + (check_input_specifier) Disallows FMT_CCA...FMT_CCE. + (convert_fmt_ItoO) Detects FMT_CCA...FMT_CCE. + (setup_randomize) Sets set_seed_used. + + * set.q: Comment fixes. + (custom_results) Conditionalizes on `compat'. + (custom_log) Calls custom_journal(). + (set_ccx) New function. + (cmd_set) Calls init_compat_dependent() when `compat' changes. + Calls set_ccx() to handle CCA...CCE. Sets set_grouping + when set_decimal changes. Range-checks values for MITERATE, + MNEST. Message fixes. + + * settings.h: Comment fixes. + (struct set_cust_currency) New struct. + (set_cc[], set_grouping, set_seed_used) New global vars. + + * var.h: (FMT_CCA...FMT_CCE) New output formats. + (FCAT_OUTPUT_ONLY) New FCAT_* constant. + +Thu Nov 28 23:14:07 1996 Ben Pfaff + + * glob.c: Revised variables to correspond to settings.h. + (init_glob) Initializes variables from settings.h properly. + + * set.q: Began long-overdue major revision to correspond to new + philosophy. Most code changed. + + * settings.h: Mostly changed; reorganized, reordered, large new + comment. + +Thu Nov 28 19:46:10 1996 Ben Pfaff + + * get.c: (cmd_save_internal) No longer forces compression off. + + * sfm-read.c: (read_compressed_data) If eof is reached when + reading a new instruction octet, only signal error if we're in the + middle of a case. + + * sfm-write.c: (COMPRESSION_BIAS) New #define. + (struct sfm_fhuser_ext) New member `end'. + (write_header) Refers to COMPRESSION_BIAS instead of magic 100.0. + (ensure_buf_space) New function. + (sfm_write_case) Reimplemented in order to support compression. + (sfm_close) Writes out the remaining contents of the compression + buffer if any. + +Wed Nov 27 23:18:35 1996 Ben Pfaff + + * command.c: Defined SAVE and XSAVE commands in command table. + + * common.h: second_lowest_value is of type flt64, not double. + + * file-handle.h: Comment fix. + + * get.c: Comment fixes. + (static var `trns') New. + (save_write_case_func, save_trns_proc, save_trns_free, null_func, + cmd_save_internal, cmd_save, cmd_xsave) New functions. + (dict_delete_run) Clears the variables and frees them now. + (trim_dictionary) Sets default for compression. + On KEEP subcommand, frees deleted variables as well as clearing + them. Finally got the sense of the test for deleting all + variables correct. + [DEBUGGING] (dump_dict_variables) Message fix. + + * glob.c: (init_glob) set_compression set to 1 by default. + + * list.q: Properly #includes config.h. + + * misc.h: New macro REM_RND_UP. + + * settings.h: Comment fix. + + * sfm-read.c: (structs sysfile_header, sysfile_format, + sysfile_variable; inline function bswap_int32) Moved to new file + sfmP.h. + (corrupt_msg) [__CHECKER__] No longer induces segfault. + (sfm_read_dictionary) Fixed bug caused by failing to initialize + var_by_index. + (read_machine_flt64_info) Fixed some problems caused by confusion + between flt64 and double types. + (read_header) Message fix. + (read_variables) Fixed set of cases in which we byte-swap sv.print + and sv.write. Fixed confusion of flt64 and double. + + * sfm.h: (struct sfm_write_info) New. + + * som-high.c: (som_draw_title) Properly frees `s'. + + * temporary.c: (save_dictionary) Comment fix. + + * var.h: Comment fixes. New FMT_* enum, FMT_NUMBER_OF_FORMATS. + (struct trns_header) Formatting fix. + (struct save_trns) New. + + * vars-atr.c: (discard_variables) Comment fix. + + * sfm-write.c: New file, baseline release. + + * sfmP.h: New file, baseline release. + +Sun Nov 24 14:53:53 1996 Ben Pfaff + + * cmdline.c: (parse_command_line) `--version' output updated. + (glob var syntax_message[]) Added my e-mail address. + + * file-handle.q, lexer.c, vfm.c: Changed many instances of + `illegal' to `invalid'. + + * sfm-read.c: (struct sfm_fhuser_ext) New fields used as + uncompression buffer. + (sfm_close) Frees decompression buffer. + (sfm_read_dictionary) Initializes decompression buffer. + (buffer_input, read_compressed_data) New functions. + (sfm_read_case) Restructured; now calls read_compressed_data() to + handle compressed system file data. + + * var.h: Comment fix. + +Mon Nov 11 15:34:09 1996 Ben Pfaff + + * dfm.c: (dfm_close) Does not set h->{ext,class} because the + caller handles it. + + * get.c: New comments. New static var `get_file'. + (cmd_get) Now fully implemented. Calls discard_variables(); + initializes fv and lv for all variables; new debug code; sets + up the dictionary; sets up the input program. + (read_from_get, cancel_get) New functions. + + * sfm-read.c: Comment fixes. + (sfm_close) New static function. + (sfm_read_dictionary) Properly sets up the class of the + file_handle. No longer cares what size the data is in records of + type 7. Also, on failure, properly cleans up the file_handle and + free()s some stuff. + (read_variables) No longer thinks it knows `nval' of the + dictionary. Now sets p.get.fv, etc., instead of speculatively + setting fv itself. + (read_value_labels) Fixed off-by-one error in indexing of + var_by_index[]. + (sfm_read_case) New function. + (sfm_r_class) New static var. + + * var.h: (get_proc) New struct. + (struct variable) New member p.get. + +Thu Nov 7 20:52:28 1996 Ben Pfaff + + * get.c: Removed GTSV_OPT_MAP because of a misinterpretation of + the manual's meaning. + (rename_variables) New function. + (trim_variables) Doesn't try to parse MAP any more. Removed debug + code. Now properly reorders the dictionary on the KEEP keyword. + + * sfm-read.c: (read_value_labels) Fixed some bugs regarding + garbage collection. + + * vars-atr.c: (clear_variable) New argument `dictionary *'. + (rename_variable) New function. + (free_val_lab) Reformatted. + +Thu Nov 7 17:29:16 1996 Ben Pfaff + + * var.h: Reindented entire file. Comment fixes. + (glob vars var, var_by_name, nvar, N, nval, n_splits, splits) + Removed. + (glob var default_dict) New. + (struct indirect_dictionary) Removed. + + * Many other source files were changed to add `default_dict.' + before all references to the dictionary of the active file. + + * vars-atr.c: (make_indirect_dictionary) Removed. + + * glob.c: Reindented all variable declarations. Updated for + changed var.h. Comment fixes. + + * temporary.c: (restore_dictionary, save_dictionary) Simplified + because now we can mainly copy dictionary structs. + + * vars-prs.c: (is_dict_varname, parse_dict_variable, + parse_variables) Takes dictionary instead of indirect_dictionary + first argument. + (parse_variables) Instead of calling make_indirect_dictionary, + just sets DICT to &default_dict if DICT is NULL. Of course, lots + of `*dict.' references had to be changed to `dict->'. Removed + debug code. + +Thu Nov 7 15:48:52 1996 Ben Pfaff + + * get.c: Added GTSV_OPT_* series of enums. + (trim_dictionary, dict_delete_run) New functions. + [DEBUGGING] (dump_dict_variables) New function. + (cmd_get) Calls trim_dictionary() to get dictionary fully set-up. + [DEBUGGING] Calls dump_dict_variables() to display results. + + * glob.c: (cmp_variable) Now a public function declared in var.h. + + * sfm-read.c: Turned off debug code. Comment fixes. + (read_machine_int32_info, read_machine_flt64_info) New functions + to parse type 7 records. + (sfm_read_dictionary) Properly byteswaps several fields now. + Calls read_machine_*_info() to parse type 7 subtypes 3 and 4 + records. [DEBUGGING] Dumps dictionary. + (read_variables) Sets `index' field of variables created properly. + Constructs avl tree of variables in dictionary. [DEBUGGING] No + longer dumps dictionary. + (read_value_labels) Properly byteswaps fields. [DEBUGGING] New + debug code. + [DEBUGGING] (dump_dictionary) No longer stubbed out. + + * temporary.c: (restore_dictionary) Destroys `var_by_name' glob + var before destroying any variables just to save a little time. + + * var.h: (struct variable) Reordered in order to make name[] the + first member; this makes pointers to `variable' pointers to the + variable name, simplifying avl trees, etc. + (struct indirect_dictionary) New struct. + + * vars-atr.c: (find_variable) Rewritten for efficiency. + (make_indirect_dictionary, is_dict_varname, parse_dict_variable) + New functions. + (is_varname) Rewritten for efficiency. + (parse_variables) New argument, which is a `dictionary *'. All + references changed. This function now reads variable names from + the dictionary passed, or from the default dictionary if NULL. + +Tue Nov 5 18:34:59 1996 Ben Pfaff + + * misc.h: Added new macro DIV_RND_UP to perform integer division, + rounding up. Changed many references to ROUND_UP to use this + instead. + + * sfm-read.c: Includes avl.h. + (corrupt_msg) Induces a segfault under Checker. + (macro assertive_bufread) New. Many references to bufread() now + use this instead. + (sfm_read_dictionary) Split up into several functions. Added code + to read dictionary records following the the type 2 records. Not + quite complete. New variable `var_by_index'. + (read_header, read_variables) New functions extracted from + sfm_read_dictionary(). + (read_value_labels) New function. + (bufread) Checks ferror() if fread() doesn't return the expected + value; if ferror() is zero it's just EOF. + (dump_dictionary) Stubbed out. + + * BTW: The source code now exceeds 50000 lines! + +Mon Nov 4 22:03:28 1996 Ben Pfaff + + * command.c: Added GET to cmd_table[]. + + * list.q: Removed reference to alloca headers. + (cmd_list) Gave prototype. + + * sfm-read.c: Added DEBUGGING comments. + (sfm_read_dictionary) Checks bias correctly. Sets + dict->var_by_name to NULL. Calculates long_string_count + correctly. realloc's dict->var[] array to minimum size. + [DEBUGGING] Calls dump_dictionary. + [DEBUGGING] (dump_dictionary) New function. + + * temporary.c: (save_dictionary) Sets var_by_name to NULL. + (restore_dictionary) If the dictionary contains a non-NULL + var_by_name, uses that instead of generating one. + (free_dictionary) Destroys var_by_name. + + * var.h: (struct dictionary) Added field `var_by_name'. + + * get.c: New file, not complete. + +Sun Nov 3 12:24:36 1996 Ben Pfaff + + * mis-val.c: New enums MV_NOR_*. New struct num_or_range. + (parse_num_or_range) New function. + (parse_numeric) Reimplemented in order to support LOW THRU and + THRU HIGH missing values. + + * output.h: [__GNUC__>1 && __OPTIMIZE__] (width, height) Made + __attribute__((const)). + + * q2c.c: (get_token) Merged isdigit || isalpha into isalnum. + + * sfm-read.c: Finished reference implementation. + + * sfm.h: Includes var.h. + + * var.h: Comment fixes. + (struct `variable') Reordered some fields. + + * vars-atr.c: (is_num_user_missing) Added support for MISSING_* + constants added previously. + +Wed Oct 30 17:13:08 1996 Ben Pfaff + + * common.h: Comment fixes. Added declaration of + `second_lowest_value' as variable or macro. Made `compat_type', + `pgm_state_type' into anonymous enums. + + * display.c: Comment fix. + + * glob.c: [ENDIAN==UNKNOWN] Added definition for `endian' global + var. + [!defined SECOND_LOWEST_VALUE] Added definition for + `second_lowest_value' global var. + (compat, pgm_state global vars) Changed types to `int'. + (init_glob) Initializes `second_lowest_value'. + + * sfm-read.c: Continued work, not complete. + + * var.h: Added new MISSING_* constants to handle LOWEST and + HIGHEST. + +Sat Oct 26 23:06:06 1996 Ben Pfaff + + * sfm-read.c: New file, not complete. + + * cases.c: (vec_insert) Changed vector expansion algorithm. + (vec_delete) Fixed bug that screwed up deletion sometimes, it was + mucking up the RECODE transformation in particular. + (envector) Harmless change in notation. + + dfm is now fairly well tested again. + * dfm.c: (dfm_get_record) Only returns ext->ptr if ext is + non-NULL--duh. + (cmd_begin_data) if(ext->line) replaced by if(ext && ext->line). + + * recode.c: Comment fix. + + * sfm.h: Interface should be fairly final now, or at least for a + day or so... + + * vfm.c: [DEBUGGING] (index_to_varname) New function. + (open_active_file) [DEBUGGING] Translates ccase indices into + variable names now to make it easier to understand what's really + going on. + +Sat Oct 26 20:46:31 1996 Ben Pfaff + + * data-in.c: Comment fix. + + * data-list.c: Includes dfm.h. + (do_reading) Uses new function dfm_push_cust(). + + * data-out.c: (convert_time, convert_WKDAY, convert_MONTH) Added + `return 1;' at end. + + * file-handle.h: Completely changed. Some parts split off into + new file dfm.h. Implemented in file-handle.q. + (enum FH_*) Removed. + (struct fh_ext_class) New struct. + (struct file_handle) Retained only these fields: name, norm_fn, + fn, recform, lrecl, mode. New fields class, ext. + (get_handle_by_name, get_handle_by_filename, parse_file_handle, + close_handle, handle_name) Added `fh_' prefix to name, all + references changed. + + * dfm.h: New file, implemented in dfm.c. + (get_record, put_record, fwd_record, bkwd_record, set_record, + get_cur_col) Functions moved from file-handle.h, now prefixed with + `dfm_'. + (dfm_push_cust) New function. + + * sfm.h: New file. Incomplete. + + * dfm.c: All functions adjusted/rewritten for new dfm/fhp + interface. Functions reordered, comments changed. Not well + tested, probably full of bugs. + (struct dfm_fhuser_ext) New struct. + (dfm_close) New function. + (open_file_r) Pickier about finding `BEGIN DATA.' line. + (open_file_w) User messages changed. + (get_record) Comment fixed. + (read_record) Increments ext->ln even for inline_file. Calls + dfm_close() for inline_file when `END DATA.' encountered. + (dfm_get_record) Experimental restructuring. + (dfm_push_cust) New function. + (cmd_begin_data) Detects whether the inline file was fully read by + checking whether it is still open; detects whether it was read at + all by checking whether the line number is greater than zero. + + * file-handle.q: All functions adjust/rewritten for new dfm/fhp + interface. Functions reordered, comments changed. Not well + tested, probably full of bugs. + (init_file_handle) Removed initializers for obsolete fields, added + new fields. + (fh_close_handle) Much simpler, now mainly calls the class + function. + (fh_init_files) Renamed inline file internal filename. + + * file-type.c: Includes dfm.h. + (read_from_file_type) Doesn't use dfm internal state anymore. + + * inpt-pgm.c, print.c: Include dfm.h. + + * recode.c: (internal_cmd_recode) Casts strlen() return value to + int in comparison with other int. + + * som-high.c: (build_target) Fixed operator precedence problem in + if statement (& versus ==). + +Sat Oct 26 10:39:25 1996 Ben Pfaff + + * dfm.c: (read_record) Can now read fixed-length records; not + tested. + (put_record) Can now write fixed-length records; not tested. + + * file-handle.h: FH_* defines changed to enums. New enum series + FH_RF_*, FH_MD_*. + (struct file_handle) New members recform, lrecl, mode. + + * file-handle.q: Parser changed. + (internal_cmd_file_handle) Added support for new /RECFORM, /MODE, + /LRECL subcommands. These are compatible with Windows. + (init_file_handle) Initializes recform, mode fields. + + * q2c.c: (get_line) When outputting `!' comment lines, now + increments the output file line number so that `#line' directives + are correct. + (make_identifier) New function that converts an arbitrary string + into a valid C identifier. + (dump_vars) Calls make_identifier() in two places in order to + suppress some errors for bad identifiers. + (make_match) Allows TRUE as synonym for YES and FALSE as synonym + for NO. Allows numbers to be prefixed by underscores to make them + acceptable C identifiers but still to be parsed as numbers by the + Fiasco lexer. + +Thu Oct 24 20:13:42 1996 Ben Pfaff + + * command.c: Re-enabled RECODE, SAMPLE, SELECT IF. + + * dfm.c: Comment fixes. (get_record) Gives error if file handle + was opened for writing. + (open_file_w) New function. + (read_record) Uses strncasecmp if available. Improved error + messages, comments. + (put_record) New function. + + * file-handle.h: Moved function comments into dfm.c and + file-handle.q. Comment fixes. Removed declarations of + tilde_expand() and normalize_filename(). + (struct file_handle) Changed `open' from boolean to enumerated + field to allow for three states--closed, open for reading, open + for writing--all references changed. + + * file-handle.q: Includes filename.h. + + * print.c: (CMD_* enums) Renamed PRT_* and moved into var.h; all + references changed. + (alloc_line) Makes allowance for line terminator characters in + calculations. + (print_trns_proc) Now handles OUTFILE, WRITE differences. + (print_space_trns_proc) Handles OUTFILE differences. + + * recode.c, sample.c: Comment fixes. + + * var.h: (struct print_trns) Changed boolean field `eject' to + bitmapped field `options'; all references changed. New enums + PRT_* for use with this field. + + * exception.h, test-exception.c: Removed. + +Thu Oct 24 17:47:14 1996 Ben Pfaff + + * ascii.c: (delineate) Turned off debug output. + + * common.c: [Checker and Linux] (__assert_fail, __eprintf) Moved + to error.c. + + * data-in.c: (parse_string_as_format) Sets the entire string value + to spaces, not just the short string part of it. Is this correct + now? + + * data-out.c: (convert_date) Fixed DATETIME format problems with + decimal places, removed debug code. + + * dfm.c: (open_file_r) Fixed bug where an error would occur in the + middle of parsing BEGIN DATA that would cause the lexer to read + from a wild pointer `prog'; now calls new function + preprocess_line() in lexer.c. + + * error.c: [__CHECKER__] (hcf) Calls induce_segfault() on improper + termination. + [Checker and Linux] (__assert_fail, _eprintf) Moved from common.c. + Now call induce_segfault() to induce the segfault. + (induce_segfault) New function. + + * expr-opt.c: Comment fix. + (parse_sysvar) New function. + (parse_primary) Added system variable support--calls + parse_sysvar(). + (global var ops) Added OP_CASENUM operator. + + * expr.h: Comment fixes. + (OP_* enum) added OP_CASENUM operator. + (struct casenum_node) New struct. + (union any_union_union) New member `cas' of type `casenum_node'. + + * glob.c: (global var last_vfm_invocation) New var. + (init_glob) Initializes last_vfm_invocation. + + * lexer.c: (lookahead) Fixed reversed condition on if statement. + + * getline.c: (get_line) Split into get_line() and preprocess_line(). + (preprocess_line) New function. + + * var.h: Declares last_vfm_invocation. + + * vfm.c: (procedure) Sets last_vfm_invocation. + +Wed Oct 23 21:53:43 1996 Ben Pfaff + + * command.c: (parse_cmd) Fixed bad assertion related to + lookahead(). + + * data-in.c: (parse_month) Implemented to parse months according + to full interpretation of standard. + (to_roman) New function. + (parse_wk_delimiter) Bug fix (forgot to skip `WK' in string). + (parse_weekday) Bug fix (forgot to skip all the day name). + + * data-list.c: (read_from_data_list_fixed) Fixed bug that screwed + up parsing of multirecord data items. Also fixed user message. + + * data-out.c: Comment fix. + (year2, year4, convert_date, convert_time, convert_WKDAY, + convert_MONTH) New functions to support time & date output. + (convert_format_to_string) Calls new time & date output routines. + + * expr-prs.c: (nary_num_func) Found a bug, but didn't fix it yet. + + * lexer.c: (lookahead) Noted a previously unnoticed caveat in + comment. + + * main.c: [DEBUGGING] (dump_token) Updated to handle getline.h. + + * misc.c: (global var formats) Fixed declarations of DATETIME, + TIME, DTIME. + + * postscript.c: (text) Fixed a pair of bugs in the reallocation of + the output_char buffer. + + * vars-prs.c: (parse_DATA_LIST_vars) Fixed a failure to free + memory bug. Fixed user messages. + +Tue Oct 22 17:27:04 1996 Ben Pfaff + + * Removed #pragma argsused from lots of places. + + * data-in.c: Implemented zoned decimal and time-date formats. + Untested. This is a huge chunk of code--maybe 1000 lines and 50 + new functions. + + * data-out.c: Implemented zoned decimal format. + + * expr.h: Moved yrmoda() declaration here from exprP.h. + + * misc.c: (global var formats) Minor fixes--added + FCAT_SHIFT_DECIMAL to formats N and Z. + (convert_fmt_ItoO) Added support for format Z. + + * som-frnt.c: (som_set_value) Fixed bug regarding string values. + +Mon Oct 21 20:39:59 1996 Ben Pfaff + + * command.c: (parse_cmd) [GLOBAL_DEBUGGING] Inserted call to + som_check_workspace() that is activated between commands. + + * data-list.c: (dump_fixed_table, dump_free_table) Finished these + for good, I hope. + + * list.q: (begin_row) Changed title expansion style from + SOPT_X_VERT to SOPT_X_SHSP. + + * som-frnt.c: Now includes `somP.h'. + (som_push_workspace, som_pop_workspace) New functions that, taken + together, form a solution to the recursive table building problem + mentioned yesterday. Surrounded every table output routine + throughout the program with calls to these functions. + [GLOBAL_DEBUGGING] (som_check_workspace) New function. + (som_create_table) Checks that there's an active workspace. + (som_destroy_all_tables, som_crush) Removed. + + * som-high.c: (global var som_preserve_tables) Removed, all + references deleted. + (som_submit_table) Checks that there's an active workspace. + (dump_columnated_table) Doesn't columnate tables that would have + just one row per column. + (dump_crush_page, som_dump_crush_page) Removed debugging code. + (som_dump_crush_page) Moved row number labels from left side of + tables to right side. + (som_get_table_size) Added support for SOPT_X_SHSP. + + * som.h: New cell expansion type SOPT_X_SHSP. + + * somP.h: (global vars arena_stack, n_arena_stack, m_arena_stack) + New vars. + (global var curtab_arena) Moved from som-frnt.c. + +Sun Oct 20 13:45:28 1996 Ben Pfaff + + * ascii.c: [GLOBAL_DEBUGGING] (SUPPRESS_WARNINGS) New debug option + that causes bad location warnings to be suppressed. + (delineate) Saves current font when calling draw_text(); fixed + handling of NULLs when backing up. Also fixed line-wrapping bug. + + * command.c: Re-enabled `LEAVE', `NUMERIC', `PRINT', `PRINT EJECT', + `PRINT FORMATS', `PRINT SPACE', `STRING', `TITLE', `WRITE'. + + * common.c: Added code to cause assertion failure to dump core + when run under Checker. + + * data-list.c: (dump_fixed_table) Fixed some inconsistencies, but + there are still bugs. + + * glob.c: (__eprintf) Removed. + + * list.q: Inserted som_preserve_tables kluge that prevents tables + from being thrown away due to recursive table building through + som_output_line being called from a transformation during the LIST + procedure invocation. This is a general problem that must be + solved in a better way since it applies to all procedures in + general. + (begin_row) Changed title options to SOM_X_VERT from SOM_X_BOTH. + (flush_table) Removed SOM_TOPT_PRESERVE from submission options. + + * numeric.c: Fixed several errors in the form of msg() calls. + + * print.c: Updated for use of som. + (dump_table) Reimplemented. + (print_trns_proc) Calls som_eject_page() instead of eject_page(). + Calls som_output_text() instead of outs_line(). + + * som-frnt.c: (som_destroy_all_tables) Sets som_preserve_tables to + 0. + (som_output_text) Function moved from som-low.c. Interface + changed. + + * som-high.c: (som_preserve_tables) New global public variable + declared in som.h. + (som_submit_table) Destroys the tables only if som_preserve_tables + is 0. + (paginate_horizontally) Bugfix: sets som.mpw even if there's only + one subrow per row. Now labels subrows if there's more than one + subrow per row. + (dump_crush_table) Added wishlist comment. + (som_eject_page) New public function declared in som.h. + + * som-low.c: (som_dump_crush_page) Draws row labels if there's + more than one subrow per row. + (som_output_text) Moved to som-frnt.c. + + * som.h: (SOM_TOPT_PRESERVE) Removed. + + * title.c: (get_title) Changed interface. + (cmd_title) Changed `title' to `outp_title'. + (cmd_subtitle) Changed `subtitle' to `outp_subtitle'. + +Sun Oct 20 09:04:15 1996 Ben Pfaff + + * list.q: (flush_table) Conforms to new partial options in + som_submission_form. + + * som-high.c: (paginate_horizontally) Changed form of subrow + number labels. + (build_target) Omits spacing before table if + SOM_TOPT_PARTIAL_OMIT_TOP is selected. + (dump_crush_page) Changed interface. Only trims bottom rule if + SOM_TOPT_PARTIAL_OMIT_BTM is not selected. + (dump_crush_table) Handles partial tables. + (output_row_label) New function. + (som_dump_crush_page) Emits subrow number labels. Draws vertical + rule on the right edge of narrow subrows. + + * som.h: Changed SOM_SUB_PARTIAL_* series of submission type + constants to a series of SOM_TOPT_PARTIAL_* submission options. + All references updated. + +Fri Oct 18 19:46:49 1996 Ben Pfaff + + * misc.c: Comment fix. + + * som-high.c: (examine_table) Treats crushed tables separates for + purpose of determining header size. + (paginate_horizontally) Allots space for line numbers in crushed + tables with lots of subrows per row. Calculates the `maximum page + width', the width of the widest horizontal page. + (build_target) Removed trim argument; all references changed. + Stricter assertions. (dump_crush_page) New function. + (dump_crush_table) Reimplemented. + + * som-low.c: (som_dump_page) Uses new RULE_ROW &c. constants. + (som_dump_crush_page) Reimplemented, interface changed. + + * somP.h: Many many new helper macros for use with crushed tables. + (global var som) Removed `tv', `cum_y' members; all references + removed. New members `mpw', `digit_space'. + +Sun Sep 29 19:37:03 1996 Ben Pfaff + + * arena.c: (arena_alloc) [!DISCRETE_BLOCKS] Removed `size' + variable, changed to constant 1024. + (arena_ca_strdup) Changed `sizeof(a_string)' to + `sizeof(c_string)'. + (arena_ca_strdup) [!DISCRETE_BLOCKS] Changed bad cast from + `(c_string *)' to `(char *)'; this fixed some offset problems. + + * filename.c: (readlink_malloc) Changed initial allocation from + 100 bytes to 128. + (good_getcwd) Changed from xmalloc() to local_alloc(); removed + comment. + + * postscript.c: (read_fontmap) Fixed leak by changing &owner to + &fm->owner in several places. + + * som-high.c: (output_table) Changed interface to rest of world. + (examine_crush_table) Removed. Crushed tables are re-broken now, + in preparation for rewrite. + + * som.h: Comment fix. + +Sat Sep 28 21:28:07 1996 Ben Pfaff + + * ascii.c: (ascii_init_driver) Disposes of x->file.filename and x + itself in the cleanup stage. + + * descript.q: (display) At least temporarily, changed the table + format to a crushed table. + + * list.q: (begin_row) At least temporarily, added horizontal lines + between cases. + + * som-high.c: (examine_crush_table) Sets som.hh to the width of + the horizontal "headers," that is, to the width of the far left + and far right rules. + (justify_pagination) Sets som.th to the width of the widest row + in the crushed table. Fixed inner loop off-by-one error. + + * som-low.c: (som_dump_crush_page) Added code to draw horizontal + rules. + + * somP.h: Comment fix. + +Fri Sep 27 20:08:39 1996 Ben Pfaff + + * filename.c: (open_file_ext) Now, doesn't set f->file to NULL + before closing it; also, opens the constructed filename `s' + instead of f->filename. + + * postscript.c: Moved initialization of x->loaded, x->prop, + x->fixed, x->current, also the add_encoding() calls, into + postopen(). + (preclose) Destroys x->combos; sets x->loaded, x->combos to NULL; + sets x->last_font to NULL; sets x->next_combo to zero. + + * som-high.c: (crushed_row_height) Moved definition farther up. + (som_submit_table) Doesn't calculate line width, font size until + after calling open_page(), to accomodate changes to PostScript + driver. + (vert_headers) Removed; equivalent functionality moved to + examine_table(), examine_crush_table(). + (justify_pagination) Replaced with different algorithm. + (dump_crush_table) Bugfix that caused tables to fail to be clipped + at the bottom of the page. + +Thu Sep 26 22:20:26 1996 Ben Pfaff + + * command.c: Added cmd_list back into cmd_table. + + * freq.c, frequencies.q, repeat.c, list.q, vars-atr.c, vfm.c: + Comment fix: `#define DEBUGGING' --> `#define DEBUGGING 1'. + + * list.q: (flush_table) Updated to new som_submission_form format. + + * som-frnt.c: Comment fix. + + * som-high.c: Changed `#endif' to `#undef EXTERN'. + (output_table) Calls som_get_table_size() directly; handles + crushed tables. + (examine_crush_table) New function; calls vert_headers(). + (examine_table) Moved some code into new function, vert_headers(). + (justify_pagination) New function. + (dump_plain_table) Removed `static' from `cy'. + (dump_crush_table) New function. + + * som-low.c: (som_dump_crush_page) New function. + + * som.h: Comment fixes. + (enum SOM_TOPT_CRUSH) New. + (SOM_SUB_PARTIAL_BEG, SOM_SUB_PARTIAL_MID, SOM_SUB_PARTIAL_END) + Temporarily set to zero to make do with LIST procedure. + + * somP.h: Re-ordering. + +Wed Sep 25 19:36:11 1996 Ben Pfaff + + * som.c: Split into som-frnt.c, som-high.c, som-low.c. + + * somP.h: New file for use by som-high.c, som-low.c. + + * q2c.c: Added definition for VME. + (get_line) Now dumps `!' comment lines to the output file + verbatim. + + * crosstabs.q, descript.q, file-handle.q, frequencies.q, list.q, + set.q: Changed format of `!' comment lines. + +Tue Sep 24 18:39:09 1996 Ben Pfaff + + * All source files: Added copyright notice. + + * common.c: (xmalloc, xrealloc, xstrdup) Cast size_t's to unsigned + longs in msg() calls. + + * con32s.c: (xmalloc, xrealloc) Updated from common.c. + + * q2c.c: (xmalloc, xrealloc, xstrdup) Updated from common.c. + +Sat Sep 21 23:16:31 1996 Ben Pfaff + + * output.c: (outp_read_devices) Changed criteria for + distinguishing different types of lines. + +Fri Sep 20 22:52:28 1996 Ben Pfaff + + * cmdline.c: Changed syntax message. + + * filename.c: (good_getcwd) Bug fix (?). + (normalize_filename) [__BORLANDC__] Uses _fullpath() library + function. + (search_path) Appends DIR_SEPARATOR to directory name only if it + does not already end with one. + + * glob.c: Checks STAT_PAGER envvar before PAGER. + + * output.c: Checks environment variables instead of just local + macros. + +Tue Sep 10 21:39:00 1996 Ben Pfaff + + * arena.c: (arena_destroy) Swatted a subtle bug that cropped up + when the pointer passed to the function was within the arena + itself, so that it couldn't properly be set to NULL _after the + arena was freed_. + + * command.c: Re-enabled DISPLAY. + + * display.c: Rewritten to handle tables. Untested. + + * filename.c: (search_path) Fixed memory leak. + + * frequencies.q: (cmd_frequencies) Frees v_variables. + (postcalc) Calls cleanup_freq_tab() after displaying statistics. + (cleanup_freq_tab) New function to garbage collect. + (dump_full) Elegantized. + + * main.c: New comment. + + * output.h: New tag for tagged quotes: TAG_NEWLINE. + + * postscript.c: Comment fix. + (release_fontmap, free_font_entry) New functions. + (ps_init_driver) Sets free_font_entry() as the freefunc for + hashtable `loaded'. Calls release_fontmap() when destroying a + driver; also frees the output filename; also frees the + ps_driver_ext block. + (free_ps_encoding) Frees the filename as well as the encoding + block. + (output_encodings) Frees the line buffer and pops the msg-filename + stack. + (read_fontmap) Frees the fontmap filename and the line buffer. + (postopen, preclose) Misc. garbage collection fixes. + (ps_open_page) Destroys the `combos' hash table; sets `last_font' + to NULL; this fixes some output problems. + (text) Handles TAG_NEWLINE. Untested. + + * som.c: (cell_byte_size) Merged SCON_VALUE and SCON_TEXT cases. + (som_set_string) Removed. All references changed to + `som_set_text'. + (som_set_text) Rewritten. New interface. More general. + + * som.h: Minor format changes. + (struct som_value_cell) Removed; all references changed to + `som_text_cell'. + (enums SOT_*) Changed. + +Mon Sep 9 21:43:13 1996 Ben Pfaff + + * command.c: Re-enabled SPLIT FILE. + + * postscript.c: Comment fix. + + * som.h: Added `SOT_NONE'. + + * split-file.h: (cmd_split_file) Removed superfluous parenthesis. + + * vfm.c: (dump_splits) Reimplemented. + +Sat Sep 7 22:35:12 1996 Ben Pfaff + + * Compiled the project under gcc 2.7.2, which gave some new + warnings. This led to many additions of casts from unsigned to + int sprinkled throughout the code. + + * arena.c: Many uses of `unsigned' changed to `size_t'. + + * command.c: Added END FILE, END REPEAT to command table. + (var cmd_end_repeat) Renamed cmd_end_repeat_p. + (find_command, FILE_TYPE_okay) Not commented out anymore. + (parse_cmd) Calls FILE_TYPE_okay again. + (output_line) Added calls to som_output_text() to put the line + in the output files. + + * common.c: (macro VME) Format changes. + (xstrdup) Asserts that its argument is not NULL. + + * data-list.c: Implemented dump_fixed_table(). + + * inpt-pgm.c: Formatting changes. Comment changes. + (end_case_proc) Renamed end_case_trns_proc. + (cmd_end_file, end_file_trns_proc) New functions. + + * misc.c: Many uses of `int' and `unsigned' changed to `size_t'. + + * misc.h: (local_strdup) New macro corresponding to strdup() but + allocating its data through local_alloc() if possible--that is, if + GNU C is in use. + + * postscript.c: Comment changes. + (quote_ps_name, quote_ps_string, output_encodings) New functions. + (output_line, add_string) New macros supporting + output_encodings(). + (postopen) Fixed contents of ${fixed-font} and ${prop-font} + substitution vars. Calls output_encodings() when a line + consisting of `!encodings' is encountered. + (preclose) Some code moved into quote_ps_string(). + (dump_line) Changed into macro supporting dump_fancy_line(). + (switch_font) Now outputs DSC "%%IncludeResource: font (...)" + command when appropriate. + (write_text) Fixed `literal_char' array (I think it's fixed, at + least.) + (text) Fixed bug when width was zero. Now exits immediately on + zero height_left. Now, when executing `goto restart;', checks + that cp `if(px!=-1 || py!=-1)'. + (build_target) Only inserts spacing if SOM_TOPT_SPACING not + selected. + (som_text_table) Removed. + (som_output_text) New function. + + * som.h: (struct som_submission_form) Removed `header', `reuse', + replaced with bitmapped field `options'. + (SOM_TOPT_*) New enum set for som_submission_form.options. + (SOT_*) New enum set for som_output_text(). + + * temporary.c: (copy_variable) When copying the var label, only + calls xstrdup() if it's non-NULL. + + * var.h: (enum type `vartype') Removed; all references changed to + `int'. + + * vars-atr.c: (init_variable) Changed local var `nbytes' from + `int' to `size_t'. + +Thu Sep 5 22:05:56 1996 Ben Pfaff + + * font.h: Comment changes. + + * groff-font.c: (groff_read_font) Initializes `name' field to + NULL. Handles `encoding' field. + + * hash.c: (hsh_dump) [GLOBAL_DEBUGGING] Output formatting changes. + + * postscript.c: (struct font_entry) Removed `position' field. + (struct ps_font_combo) New struct. + (struct ps_driver_ext) Removed field `next_position'. New fields + `combos', `next_combo'. `last_font' field changed from + `font_entry *' to `ps_font_combo *'. + (ps_init_driver) Reformatted; handles new fields. When + OPO_AUTO_ENCODE is set, adds the two default fonts' encodings to + the encoding list. + (get_encoding, find_encoding_file) New functions. + (add_encoding) Some code moved out into find_encoding_file(). + (postopen) Changed value for ${title}. + (preclose) Sets `loaded' field to NULL after destroying the hash + table. + (ps_open_page) Added comment. Inits the `combos' and `next_combo' + fields. + (ps_text_set_font_by_position) Figures out the current family if + not known. + (compare_ps_combo, hash_ps_combo, free_ps_combo) New functions. + (switch_font) Implemented. + (write_text) Calls switch_font() more often. Format changes. + #undefs its macros after they're no longer useful. + (text) Changed `continue' at one point to a jump to the top of the + loop because we don't want `separate' reset to 0 at that point. + (load_font) No longer sets `position' in the font_entry created. + +Wed Sep 4 21:45:35 1996 Ben Pfaff + + * font.h: (struct font_desc) New member `encoding', which is not + properly handled yet. + + * glob.c: (init_glob) Some new i18n code, which is probably + screwed up. + + * output.c: (outp_read_devices, outp_get_paper_size) Changed + `size' local from `int' to `size_t'. + + * postscript.c: New driver configuration parameter `auto-encode'. + New enums OPO_AUTO_ENCODE, ODA_COUNT. + (struct font_entry) New member `position'. + (struct ps_driver_ext) Reordered. New hash table member + `encodings'; new members `next_position', `next_encoding', + `last_font'. Members `current', `prop', `fixed' changed from type + `font_desc *' to `font_entry *'; all references changed. + (struct ps_encoding) New struct. + (read_ps_encodings, compare_ps_encoding, hash_ps_encoding, + free_ps_encoding, add_encoding) New functions. + (ps_init_driver) Added OPO_AUTO_ENCODE to default + x->output_options. Initializes new members of ps_driver_ext. + Changed default value for prologue_fn, encoding_fn. Calls + read_ps_encodings after loading default fonts. + (option_tab[], ps_option) Handle new configuration parameter. + (switch_font) New function. + (struct output_char) `font' member changed from `font_desc *' to + `font_entry *'. New member `separate'. + (read_fontmap) Changed `size' from `int' to `size_t'. + (output_line, put_number) New macros for write_text(). + (write_text) Optimizes text output by consolidating multiple + calls to PostScript `show' operator. + (text) Keeps track of when text arguments can't be consolidated by + write_text(), and marks those spots in the output stream. + (load_font) Sets `position' of the allocated font_entry to -1, cuz + the font hasn't been switched to by switch_font(), which is where + the position is important--the PostScript is what cares about the + position. + +Sat Aug 31 23:52:38 1996 Ben Pfaff + + * hash.c: (hsh_destroy) Ignores NULL argument. Doesn't try to + call a NULL free_func. + (hsh_rehash) Elegantized. + (hsh_probe) Fix bug that manifested when the table was expanded + and thus had to change location in memory. Good thing + too--otherwise could have been much more subtle. + (hsh_find) [GLOBAL_DEBUGGING] Not stubbed out anymore. + (hsh_foreach) New function for hash table iteration. + + * hash.h: (struct hsh_iterator) New. + + * lexer.c: (parse_tagged_quote) Font and family name strings in + tags are now null-terminated. + + * output.c: (outp_evaluate_dimension) Fixed over-aggressive unit + parsing. + (internal_get_paper_size, outp_get_paper_size) Fixed; now work as + documented. (Never before tested?) + + * output.h: Comment changes. + + * postscript.c: New driver options `optimize-text-size', + `optimize-line-size', `max-fonts-simult'. New enum set for + specing cached line types. Comment fixes. + (struct line_form) New struct. + (struct ps_driver_struct) New members `text_opt', `line_opt', + `max_fonts', `lines'. + (ps_init_driver) Initializes new members of ps_driver_struct. + (user option type enum set) New member `nonneg_int_arg'. + (static var option_tab[]) Supports new options. + (ps_option) Handles new options. + (find_ps_file) Made static. No longer calls hsh_dump(). + (ps_get_var) Made static. + (preclose) Dumps out proper DSC trailer. + (ps_open_page) Elegantized. + (ps_close_page) Calls dump_lines() if appropriate. + (ps_line_horz, ps_line_vert, ps_line_intersection) Reduced to + wrappers around line(). + (int_2_compare, compare_line, dump_line, dump_fancy_line, + dump_lines, hash_line, free_line, line) New functions for support + of line caching. + (write_text, text) Made static. + (text) Added to font support, not finished. + +Thu Aug 29 21:36:41 1996 Ben Pfaff + + * font.h: (struct font_desc) New members ascent, descent. + + * groff-font.c: (groff_read_font) Calculates font ascent and + descent from the ascent and descent of the `d' and `p' characters, + respectively, as per a suggestion on comp.fonts. + + * postscript.c: (ps_open_page, ps_close_page, ps_line_horz, + ps_line_vert, ps_line_intersection) Rewritten to deal with changed + prologue. + (write_text) Handles text right-justification and centering (not + full justification). Still very inefficient. (One output line + per character?!) + (struct output_char) Added fields for font and font size. + (text) Many bugfixes. + +Sat Aug 24 23:26:00 1996 Ben Pfaff + + * cmdline.c: (usage) Calls outp_list_classes(). + + * font.h: Comment fix. + + * groff-font.c: New exported global var `space_index'. + (groff_init) New function to initialize `space_index'. + (hash_kern) Casts result to unsigned. + (font_name_to_index) Renamed font_char_name_to_index. All + references changed. Also, now returns the value of `space_index' + when passed an ASCII space character as an argument. Fixed + handling of nulls. + (font_get_kern_adjust) Changed i from `int' to `unsigned'. + Handles passed NULL pointers properly. + + * lexer.c: (parse_tagged_quote) Comment fix. Better range + checking. + + * output.c: (outp_list_drivers) Removed. Removed all references. + + * output.h: Comment fixes. + + * postscript.c: (ps_open_global) Calls groff_init(). + (output_char) New structure. + (write_text) New function. + (text) No longer stubbed out! Now the output is correct--with a + few exceptions, one of them being that the page has to be held + upside down into a mirror. + +Sun Aug 11 21:31:22 1996 Ben Pfaff + + * font.h: Comment fix. + + * font.c: (name_to_index) Renamed font_name_to_index, made extern. + All callers changed. + (number_to_index) Renamed font_number_to_index, made extern. All + callers changed. + (font_get_kern_adjust, font_get_char_metrics) New functions. + + * output.h: New constant OUTP_T_INTERNAL_DRAW. + + * postscript.c: Changed default line width back to 1/2 point. + (ps_line_horz, ps_line_vert, ps_line_intersection) Now lines are + in the center of the space allotted for them, not just a fixed + offset from the edge of the space; this fixes some bugs. + (ps_line_intersection) Now supports all command line styles. + (ps_text_get_size) Bug fix in computation of em width. + (text) New function, the meat behind ps_text_metrics and + ps_text_draw. Not complete. + (ps_text_metrics, ps_text_draw) Removed the stub taken from + ascii.c; call text(). + +Sat Aug 10 23:28:17 1996 Ben Pfaff + + * arena.c: (arena_free) Assert that the argument is non-NULL. + + * groff-font.c: (add_kern) Calls arena_free() for old_kern if and + only if old_kern is non-NULL. + + * postscript.c: (ps_init_driver) Changed default line width to 1 + point. + (postopen) New prologue variables. + (ps_line_horz, ps_line_vert, ps_line_intersection) Implements some + more of the common line styles properly, but not all. + (ps_text_metrics) Fixed problem with this stubbed out version that + kept it from taking font sizes into account. + +Thu Aug 8 22:31:11 1996 Ben Pfaff + + * arena.c: (arena_malloc) Bug fix. + (arena_dump) [GLOBAL_DEBUGGING] New function. + + * ascii.c: Comment fix. + (count_fancy_chars, delineate) Now static functions. + + * filename.c: (interp_vars) Bug fixes. + + * font.h: Comment fixes. + + * glob.c: (init_glob) Sets set_viewwidth, set_viewlength at + beginning in case we have an error message to display before + initializing the display. + + * groff-font.c: Comment fix. Changed rehash threshold from 2/3 + full to 1/2 full. + (groff_read_font) Bug fixes. + (name_to_index) Increments hash.used. Sets `name' field of hash + entry properly. + (add_kern) Sets kern_max_used after rehashing. Other bug fixes. + + * hash.c: Return type changed. + + * postscript.c: Continued development. Now marks lines on the + paper, but very buggy. + +Sat Aug 3 20:50:35 1996 Ben Pfaff + + * Changed comments in many source files from `/* xxx /* yyy */' to + `/* xxx */ /* yyy */' for cleanliness. + + * arena.c: (arena_sd_strdup) New function. + + * ascii.c: (struct ascii_driver_ext) New member `file'. + (ascii_init_driver) Fills out member `file' for initing; uses + close_file_ext for closing drivers. + (ascii_option) Changed %.*s back to %s because the a_string's are + always null-terminated. + (postopen, preclose) New functions. + (ascii_open_page) Uses new style of open_file_ext. + (ascii_option, commit_line_buf, output_lines) Use ext->file.file + instead of this->output. + (__assert_fail) Removed. + + * cmdline.c: Changed syntax_message[]. + + * error.c: #include's only if the history + library is available, not if just the readline library is + available. + + * filename.c: (expand_line) Removed alloca() support. + (interp_vars) No longer tilde-expands argument. Limit on output + length removed. + (tilde_expand) Now treats argument as path rather than filename. + [!unix] Now is a no-op function. + (search_path) Better verbose message formatting. + (open_file, close_file) Comment fixes. + (close_file) [!unix] Doesn't bother with pipes. + (open_file_ext) Completely rewritten, interface revamped. + (close_file_ext) New function. + + * font.h: Comment changes. + + * frequencies.q: Removed AIX alloca support since it doesn't use + alloca. + + * hash.c: Comment changes & additions. + (hsh_create) Initializes entire table instead of first M entries. + (hsh_probe) Stupid bug fixed. Now it works. + (hsh_dump) [GLOBAL_DEBUGGING] New function. + + * main.c: (parse) Detects EOF properly in token-eating loop. + Should the STOP token have its value changed to 0? + + * misc.c: (blp_getdelim) [HAVE_GETDELIM] Now it's a macro. + (blp_getline) Now it's a macro. + + * output.h: (struct outp_driver) Removed members output, filename. + + * output.c: (outp_init) [!NO_POSTSCRIPT] Installs PostScript + drivers in driver table. + (outp_read_devices) Frees buf. Warns if there are no active + output drivers. + (outp_configure_clear) Sets outp_configure_vec to NULL after + deleting its elements. + (configure_driver, destroy_driver) Removed references to output, + filename members of outp_driver. + (outp_evaluate_dimension, internal_get_paper_size, + outp_get_paper_size) New functions. + + * postscript.c: Continued development. Now links but doesn't make + any marks on the page. Lotsa bugs I suppose. + + * str.c: (strcasecmp) [!HAVE_STRCASECMP] New function. + + * str.h: Comment changes. + +Sat Jul 27 22:32:38 1996 Ben Pfaff + + * Removed dependencies on non-nested comments in several files. + Also removed references to (unix || __unix__) in #if's since + prefh.orig makes those two equivalent. + + * ascii.c: (ascii_open_global) Creates ascii_arena. + (ascii_close_global) Destroys ascii_arena. + (ascii_init_driver) Doesn't create ascii_arena. + (ascii_copy_driver) Removed. + (ascii_option) Possible bugfix regarding %s vs. %.*s with a_string's. + (outp_class ascii_class) Removed ascii_copy_driver reference. + + * frequencies.q: Now can display all statistics except median. + Still not finished. + + * output.c: Handles outp_class.ref_count so output class + destructors are called properly. + (add_class) Sets ref_count to 0. + (configure_driver) Initializes class if ref_count++ is 0. + (destroy_driver) Destructs class if --ref_count is 0. Frees the + class output file name. + + * output.h: (struct outp_class) Removed copy_driver, inited. + Added ref_count. + + * postscript.c: Completely replaced but not finished. + +Tue Jul 23 21:48:36 1996 Ben Pfaff + + * approx.h: #includes . + + * arena.h, arena.c: Many functions changed to take an arena ** + instead of an arena *, for consistency. All callers changed. + (arena_alloc) Now creates a new arena if passed *A that is NULL. + (arena_destroy) Sets *A to NULL. + + * ascii.c: (delineate) Implements OUTP_T_VERT correctly. Removed + assertion that `width' be positive. + + * command.c: Removed #if's from cmd_table. + (walk_cmdtable_func) [0] New function (debug code). + (init_cmd_parser) [0] Dumps out cmd_table (debug code). + (parse_cmd) Doesn't return failure for unimplemented commands. + + * common.h: (SYSMIS) Changed from DBL_MAX to -DBL_MAX. + (SYSCODE) New constant macro. + + * descript.q: Checks for positive n_variables before performing + analysis. + + * file-handle.q: (get_handle_by_filename) Bug fix: passes &f to + avl_find instead of &fp as arg 2. + + * frequencies.g, frequencies.q: Continued updating; now compiles & + works again, but not complete. + + * main.c: Changes to user messages. + + * misc.c: (reverse) [0] New function. + + * settings.h: Comment removed. #includes "common.h". + + * som.c: (som_set_null) New function. + (som_set_value, som_set_string, som_set_text) More detailing + assertions. + (som_set_float) Implemented function. + (dump_columnated_table) Bug fix regarding page breaks. + (draw_cell) Bug fix regarding text that spilled out of a cell. + (draw_intersection, draw_horz_rule, draw_vert_rule) No longer draw + null lines. + (get_cell_size) Support SCON_EMPTY cells. + (get_table_size) When calculating rules' widths and heights, mask + out SLIN_SPACING bit. Added SOPT_X_HLTL support. + + * som.h: (som_any_cell) New option SOPT_X_HTLT. Removed + SOPT_X_SHADE. + (struct som_submission_form) New member `header'; all users + changed. + + * val-labs.c: (get_label) User messages changed. + + * var.h: Changed FREQUENCIES structures. + + * vars-atr.c: (is_num_user_missing, is_str_user_missing) Made + inline. + +Fri Jul 19 19:11:13 1996 Ben Pfaff + + * approx.h: Definition of EPSILON now depends on system's + DBL_EPSILON. Removed GNU C specific code. + (cmpapx) Renamed approx_compare. + + * frequencies.g, frequencies.q: Continued updating; still doesn't + compile. + + * groff-font.c: (name_to_index) Fix bug that kept it from + compiling. + + * hash.c, hash.h: Completed work. + + * var.h: Changes to freq_tab, frequencies_proc. + +Wed Jul 17 21:23:36 1996 Ben Pfaff + + New hashing code. + * hash.c, hash.h: New files. Not completed. + * Makefile.am: Added hash.c to source file list. + * font.h: (struct font_desc) New member kern_size_p. + * groff-font.c: Uses hash.h. + (hashpjw) Moved to hash.c. + (next_prime_power) Rewrote, renamed hsh_next_prime, moved to + hash.c. + (static var hash) New member size_p. + * var.h: Includes hash.h. + (struct freq_tab) Changed AVL_TREE to hash_tab. + + * vars-prs.c: Comment, formatting fixes. + + * frequencies.g, frequencies.q: Continued updating. Not yet + working. + + * formats.c: Bug fix. + +Tue Jul 16 22:10:04 1996 Ben Pfaff + + Increasing parallelism between DESCRIPTIVES and FREQUENCIES. + * descript.g: Comment fixes. + * descript.q: Comment fixes. Moved some declarations into var.h. + Made dsc_info a static table. Updated FIXMEs. + (internal_cmd_descriptives) Beautified. + + * frequencies.q: Started updating into working order. + * frequencies.g: New file analogous to descript.g. + * var.h: Comment fixes. Added structures for FREQUENCIES. + + * som.c: Removed vestiges of crushing and partial table support. + +Sun Jul 14 15:45:31 1996 Ben Pfaff + + * Many more changes to som.c especially, but these will not be + documented as I have resolved to remove them. This patchlevel is + being released solely so that I can fall back to it if I decide + that removing the changes is not a good idea. + +Sat Jul 13 09:58:44 1996 Ben Pfaff + + * som.c: (global var som) New member `cum_y'. + (build_target) Properly handles titles for partial tables. + (dump_partial_beg, dump_partial_mid, dump_partial_end) + Merged into single new function dump_partial(). Fixed problem + with titles on partial tables. + (dump_table) Calls dump_partial() for all parts of partial tables. + (dump_page) Criteria for drawing title changed. + +Fri Jul 12 22:03:36 1996 Ben Pfaff + + * command.c: (cmd_table) Added LIST, WEIGHT. + + * command.c: (cmd_remark) No longer frees `s' since it's not + dynamically allocated. + + * data-out.c: (convert_f) Now correctly handles the case where + abs(v->f)<1 but v->f rounds to a value of 1.00 given the specified + number of decimals. + (som_destroy_all_tables) Removed argument. All callers changed. + (som_vline, som_hline) Argument validity checking corrected. + (som_set_value) Implemented half-heartedly. + (replicate_table) Copies tables piece-by-piece when using Checker. + + * som.h: New line style SLIN_1THIN, currently equivalent to + SLIN_0. New enum set SOM_SUB_*. + (struct som_submission_form) Removed `seq_no'. Added `type'. + + * list.q: Newly working file; uses partial tables. + + * som.c: (som_reduce_table) Renamed som_set_table_height(). + (som_crush) Removed argument `group'. + (global var som) Removed `nt', `seq_no'. Added `type'. + (som_submit_table) Arguments changed. + (output_table) Removed partial table code. + (build_target) New arg; partial table support added. All callers + changed. + (dump_plain_table) Removed partial table code. + (dump_partial_beg, dump_partial_mid, dump_partial_end) New functions. + (dump_table) Supports partial tables. + (dump_page) New argument to allow not drawing top and/or bottom + headers. All callers changed. Supports partial tables. + +Sat Jul 6 22:22:25 1996 Ben Pfaff + + * data-out.c: Changed `#include ' to `#include + "approx.h". + (convert_F) Comment fix. Now won't print `-.000', etc. + + * descript.q: Now Z-scores work, although there appears to + be a bug (which might actually be in data-out.c:convert_F()). + (descriptives_trns_proc, descriptives_trns_free) New functions. + (run_z_pass) Implemented. + + * var.h: Comment fixes. + (dsc_z_score, descriptives_trns) New structs. + (descriptives_trns) Added to any_trns as `dsc'. + + * error.c, error.h: New error class, IS (Installation Script + error), used in those instances where the error is in the + installation, but there is a script file or installation file that + can be usefully referred to. + + * output.c: Change many IE classes to IS classes. + + * cases.c, command.c, common.c, crosstabs.q, expr-evl.c, + frequencies.q, list.q, vars-prs.c, vfm.c: Removed reference to + HAVE_MALLOC_H because Borland C++ alloca() is broken, so why + include the corresponding header? + + * glob.c: (init_glob) Don't malloc term_buffer under Checker. + Don't bail out if termcap can't be read. + + * som.c: (som_destroy_table) Removed. + (som_reduce_table, som_destroy_all_tables) New functions. + (som_crush) New function, not implemented. + + * som.h: New table option STAB_CRUSH. Comment fix. New struct + som_submission_form. Function prototypes revised. + + Outputting huge tables (1000s of rows) a few rows at a time + is supported, though untested. May even break everything. + Actually, the code doesn't even compile right now. + * som.c: (struct som) New fields htv, nt, seq_no. + (som_submit_table) Multiple arguments changed to a single + pointer to struct submission_form. Only increments subtable_num + if seq_no is zero. Only destroys table if it's not going to + be reused. + (replicate_table) New function. + (output_table) Comment fix. + (examine_table) Changed inline code to code calling + replicate_table(). Calculates htv. Supports partial tables. + (draw_title) Removed comment. + (build_target) Only allows for title on first part of partial + tables. + (dump_plain_table) Only resets table chunk number on first part + of partial tables; FIXME: doesn't work quite right. Supports + partial tables. + (dump_page) Titles only on first part of partial tables. + +Fri Jul 5 20:16:19 1996 Ben Pfaff + + * Thanks to an unreliable IDE hard drive, I have spent the last + day reconstructing my Debian GNU/Linux installation and redoing + the previous day's changes--somehow I managed to save every file + except for output.c and output.h. So the following changes could + really be considered independent of the output.c, output.h changes + from Jul 4. + + * output.h, output.c: Moved the outp_configure_vec global var, + outp_names struct, and enum set OUTP_S_* from output.h to output.c. + outp_configure_vec is now static. + +Thu Jul 4 20:20:24 1996 Ben Pfaff + + * The entire philosophy behind configuration of the output drivers + changed. Now there is a termcap-type configuration where drivers + to be read are determined beforehand, rather than parsing the + entire output init file and storing it in memory & deciding what + to actually use later. Faster & more memory-efficient at the same + time, cool. + + * output.c: Comment fix. Removed outp_init_drivers global var. + Removed all references to synonyms. New structure outp_defn. New + global vars outp_macros, outp_configure_vec. + (search_name, delete_name, add_name, check_configure_vec, + expand_name, find_defn_value) New static functions. + (outp_configure_clear, outp_configure_add, outp_configure_macro, + outp_read_devices) New extern functions. + (outp_init) Much functionality moved into outp_read_devices. + (outp_read_devices) Format of output init file changed; name of + file is `devices' rather than `output' to avoid Makefile + conflicts. + (outp_clear) Renamed outp_done. + (outp_list_classes) Bug fix, cleaned up. + (outp_list_drivers) Not implemented anymore. + (outp_configure_driver) Now a static function; simplified; now + interpolates macros; supports new structure. + (outp_enable_driver, match_synonym) Removed; all references + removed. + (find_driver) First argument removed. + + * output.h: Global var outp_init_drivers removed; new structure + outp_names; new enum set OUTP_S_*; new global var + outp_configure_vec; function prototypes for output.c exports + updated. + + * main.c: (main) Calls outp_read_devices() after parsing the + command line. + + * cmdline.c: (parse_command_line) New option -v --verbose; + --version changed to -V. --device option changed syntax to just + take a single device name. Accepts key=value declaration of + output init file macros. Syntax message updated. + + * filename.c: (expand_line) New function. + (interp_environ_vars) Renamed interp_vars; no longer uses + fixed-size buffer. + (blp_getenv) Allows $ARCH and $VER pseudo-environment-vars to be + overridden by real environment vars. + (search_path) Uses verbose_msg() instead of #ifdef'd printf(). + * filename.h: interp_environ_vars() renamed interp_vars(). + + * error.c, error.h: Added extern variable `verbosity', message + class MM. + + * error.c: (vmsg) Support message class MM. + (verbose_msg) New function. + + * descript.q: (generate_z_varname) Bug fix in generation of + Z-score varnames. + (dump_z_table) Bug fix in column headers. + + * ascii.c: (ascii_init_driver) Changed minimum number of lines per + page from 29 to 15. Don't set a default for ops[OPS_INIT, + OPS_DONE]. Writes the uninit string when the driver is closed. + (ascii_open_page) Write the init string before the first page. + (output_shorts) Form of main loop changed from `while' to `for'. + Bug fix with overstrikes: the character is printed *after* the + backspace. Eliminated a lot of `& 0xff' modifiers. + (advance_to_left_margin) New function. + (return_carriage, output_lines) Handle left margin. + +Thu Jul 4 00:35:59 1996 Ben Pfaff + + * ascii.c: New option `carriage-return-style'. + + * ascii.c: (count_fancy_chars) New function. + (delineate, text_metrics) Use new function; bug fixes regarding + rich text strings. + (text_draw) Bug fix with rich text. + (output_string, output_shorts) Reordered. + (output_shorts) Now handles boxchars and some overstrike font + changes. + (output_char, return_carriage) New functions. + (output_lines) Now handles overstriking and font changes properly; + some code moved to output_shorts. + +Tue Jul 2 22:13:23 1996 Ben Pfaff + + [GLOBAL_DEBUGGING] + * ascii.c: New member `debug' in ascii_driver_ext. + (ascii_init_driver, delineate) Uses new member. + + Now you can set a vertical height on writing text. + * ascii.c: (delineate) Keeps track of vertical position. + (text_draw) No longer considers fully justified text an internal + error. + + * output.h: New flag OUTP_T_VERT; other OUTP_T_ values changed. + + Tables' titles are drawn; they can have variable height. + * som.c: `som' struct has new member, title_height. + (draw_title) New argument. Moved within file. All caller + changed. + (build_target) New argument, amount of space needed for first row. + Calculates height of title, takes that into account. All callers + changed. + (dump_plain_table, dump_columnated_table) Took calculation of y1, + y2 out of loop. + (dump_columnated_table) [GLOBAL_DEBUGGING] Debugging code + improved. + (dump_columnated_table) Organized for readability. + (dump_page) Makes use of som.title_height. + + * som.c: Many comment bug fixes. + + * descript.q: (try_name, generate_z_name) Bug fix regarding + generation of Z-score variable names. + * var.h: Removed num from descriptives_proc; all referents removed. + +Mon Jul 1 22:13:39 1996 Ben Pfaff + + * ascii.c: (ascii_line_horz, ascii_line_vert, + ascii_line_intersection) Added debugging code. + + Added a descriptive line above each table to describe it. + * command.c: (parse_cmd) Calls som_new_series. + + * som.c: New static vars table_num, subtable_num. New `som' + member `title'. + (dump_page) New arguments. + (som_submit_table) Handle new variables. + + * som.c, som.h: (som_submit_table) New arguments. All callers + changed. + (som_new_series) New function. + (build_target) Makes room for extra line. + (draw_title) New function. + (dump_page) Calls draw_title. Bug fix: doesn't always set + som.ext->cp to 0. + + Columnation of tables support. + * som.h: Deleted fr, lr, ri from som_table. Reorganized. + + * som.c: Deleted references to fr, lr, ri. + (som_columnate) Bux fix: sets group member of table. + (som_add_options) Function removed. + (dump_table) Split into three functions; extensively reworked. + + * descript.q: (dump_z_table) Better output table formatting; added + title support to correspond to som.h changes. + (display) Title support. + + * output.h: Added OUTP_T_NONE. + +Mon Jul 1 13:00:00 1996 Ben Pfaff + + * descript.q: Improved handling of Z scores; still not perfect. + + * output.h, ascii.c: Added hook for getting em width of current + font. + + * som.c: Uses new em-width hook. Added debugging code to + several functions. + (som_columnate) New argument. + (som_add_options) Removed. + +Jun 29 17:40:47 1996 Ben Pfaff + + * som.h, som.c, output.c, output.h, ascii.c: Updated to work with + rules as a property of the table instead of as a property of the + cells. + + * ascii.c: Added `header' to table of options. + + * descript.q: Added even shorter statistic names; modified to work + with new som interface. + + * misc.c (blp_getdelim): Bug fix. + + * version.c: includes 'conf.h'. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/src/Makefile.am b/src/Makefile.am new file mode 100644 index 00000000..87061dd8 --- /dev/null +++ b/src/Makefile.am @@ -0,0 +1,87 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +# PSPP + +bin_PROGRAMS = pspp + +INCLUDES = -I$(top_srcdir) -I$(top_srcdir)/src -I$(top_srcdir)/lib \ +-I$(top_srcdir)/intl + +DISTCLEANFILES = foo $(q_sources_c) +MAINTAINERCLEANFILES = Makefile.in +EXTRA_DIST = $(q_sources_q) q2c.c +ETAGS_ARGS = -l c $(q_sources_c) +SUFFIXES = .q + +$(q_sources_c): q2c +.q.c: + ./q2c $< $@ + +q_sources_c = correlations.c crosstabs.c descript.c file-handle.c \ +frequencies.c list.c means.c set.c t-test.c + +q_sources_q = correlations.q crosstabs.q descript.q file-handle.q \ +frequencies.q list.q means.q set.q t-test.q + +pspp_SOURCES = aggregate.c alloc.c alloc.h apply-dict.c approx.h \ +ascii.c autorecode.c avl.c avl.h bitvector.h cases.c cases.h cmdline.c \ +command.c command.def command.h compute.c correlations.c count.c \ +crosstabs.c data-in.c data-in.h data-list.c data-out.c debug-print.h \ +descript.c dfm.c dfm.h do-if.c do-ifP.h error.c error.h expr-evl.c \ +expr-opt.c expr-prs.c expr.h exprP.h file-handle.c file-handle.h \ +file-type.c filename.c filename.h flip.c font.h format.c format.def \ +format.h formats.c frequencies.c frequencies.g get.c getline.c \ +getline.h glob.c groff-font.c hash.c hash.h heap.c heap.h html.c \ +htmlP.h include.c inpt-pgm.c inpt-pgm.h lexer.c lexer.h list.c log.h \ +loop.c magic.c magic.h main.c main.h matrix-data.c matrix.c matrix.h \ +means.c mis-val.c misc.c misc.h modify-vars.c numeric.c output.c \ +output.h pfm-read.c pfm-write.c pfm.h pool.c pool.h postscript.c \ +print.c random.c random.h recode.c rename-vars.c repeat.c sample.c \ +sel-if.c set.c settings.h sfm-read.c sfm-write.c sfm.h sfmP.h som.c \ +som.h sort.c sort.h split-file.c stat.h stats.c stats.h str.c str.h \ +sysfile-info.c tab.c tab.h temporary.c title.c t-test.c val-labs.c \ +var-labs.c var.h vars-atr.c vars-prs.c vector.c vector.h version.c \ +version.h vfm.c vfm.h vfmP.h weight.c + +GMP_LIBS = ../lib/gmp/mpf/libmpf.a \ + ../lib/gmp/mpn/libmpn.a \ + ../lib/gmp/libgmp.a + +LDADD = ../lib/julcal/libjulcal.a \ + ../lib/misc/libmisc.a \ + ../lib/dcdflib/libdcdflib.a \ + @GMP_LIBS@ @INTLLIBS@ + +version.c: + echo "#include " > version.c + echo "const char bare_version[] = \"@VERSION@\";" >> version.c + echo "const char version[] = GNU_PACKAGE \" @VERSION@\";" >> version.c + echo "const char stat_version[] = GNU_PACKAGE \" @VERSION@ \ +(`date`).\";" >> version.c + echo "const char host_system[] = \"$(host_triplet)\";" >> version.c + echo "const char build_system[] = \"$(build_triplet)\";" >> version.c + echo "const char default_config_path[] =\ +\"~/.pspp:$(pkgsysconfdir)\";" >> version.c + echo "const char include_path[] =\ +\"./:~/.pspp/include:$(pkgdatadir)\";" >> version.c + echo "const char groff_font_path[] = \"~/.pspp/font:\" \\" >> version.c + echo " \"$(pkgdatadir)/font:\" \\" >> version.c + echo " \"/usr/local/lib/groff/font:\" \\" >> version.c + echo " \"/usr/lib/groff/font:\" \\" >> version.c + echo " \"/usr/local/share/groff/font:\" \\" >> version.c + echo " \"/usr/share/groff/font\";" >> version.c + echo "const char locale_dir[] = \"$(datadir)/locale\";" >> version.c + +# q2c + +LOCAL_CC = @LOCAL_CC@ +LOCAL_COMPILE = $(LOCAL_CC) -c $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) +LOCAL_LINK = $(LOCAL_CC) $(LDFLAGS) -o $@ + +q2c.o: q2c.c + $(LOCAL_COMPILE) $< -o q2c.o +q2c: q2c.o + $(LOCAL_LINK) q2c.o ../lib/misc/libmisc.a -o q2c + +CLEANFILES = q2c +MAINTAINERCLEANFILES = Makefile.in diff --git a/src/aggregate.c b/src/aggregate.c new file mode 100644 index 00000000..d49ebf9e --- /dev/null +++ b/src/aggregate.c @@ -0,0 +1,1523 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "command.h" +#include "error.h" +#include "file-handle.h" +#include "lexer.h" +#include "misc.h" +#include "settings.h" +#include "sfm.h" +#include "sort.h" +#include "stats.h" +#include "str.h" +#include "var.h" +#include "vfm.h" +#include "vfmP.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Specifies how to make an aggregate variable. */ +struct agr_var + { + struct agr_var *next; /* Next in list. */ + + /* Collected during parsing. */ + struct variable *src; /* Source variable. */ + struct variable *dest; /* Target variable. */ + int function; /* Function. */ + int include_missing; /* 1=Include user-missing values. */ + union value arg[2]; /* Arguments. */ + + /* Accumulated during AGGREGATE execution. */ + double dbl[3]; + int int1, int2; + char *string; + int missing; + }; + +/* Aggregation functions. */ +enum + { + NONE, SUM, MEAN, SD, MAX, MIN, PGT, PLT, PIN, POUT, FGT, FLT, FIN, + FOUT, N, NU, NMISS, NUMISS, FIRST, LAST, + N_AGR_FUNCS, N_NO_VARS, NU_NO_VARS, + FUNC = 0x1f, /* Function mask. */ + FSTRING = 1<<5, /* String function bit. */ + FWEIGHT = 1<<6, /* Weighted function bit. */ + FOPTIONS = FSTRING | FWEIGHT /* Function options mask. */ + }; + +/* Attributes of an aggregation function. */ +struct agr_func + { + const char *name; /* Aggregation function name. */ + int n_args; /* Number of arguments. */ + int alpha_type; /* When given ALPHA arguments, output type. */ + struct fmt_spec format; /* Format spec if alpha_type != ALPHA. */ + }; + +/* Attributes of aggregation functions. */ +static struct agr_func agr_func_tab[] = + { + {"", 0, -1, {0, 0, 0}}, + {"SUM", 0, -1, {FMT_F, 8, 2}}, + {"MEAN", 0, -1, {FMT_F, 8, 2}}, + {"SD", 0, -1, {FMT_F, 8, 2}}, + {"MAX", 0, ALPHA, {-1, -1, -1}}, + {"MIN", 0, ALPHA, {-1, -1, -1}}, + {"PGT", 1, NUMERIC, {FMT_F, 5, 1}}, + {"PLT", 1, NUMERIC, {FMT_F, 5, 1}}, + {"PIN", 2, NUMERIC, {FMT_F, 5, 1}}, + {"POUT", 2, NUMERIC, {FMT_F, 5, 1}}, + {"FGT", 1, NUMERIC, {FMT_F, 5, 3}}, + {"FLT", 1, NUMERIC, {FMT_F, 5, 3}}, + {"FIN", 2, NUMERIC, {FMT_F, 5, 3}}, + {"FOUT", 2, NUMERIC, {FMT_F, 5, 3}}, + {"N", 0, NUMERIC, {FMT_F, 7, 0}}, + {"NU", 0, NUMERIC, {FMT_F, 7, 0}}, + {"NMISS", 0, NUMERIC, {FMT_F, 7, 0}}, + {"NUMISS", 0, NUMERIC, {FMT_F, 7, 0}}, + {"FIRST", 0, ALPHA, {-1, -1, -1}}, + {"LAST", 0, ALPHA, {-1, -1, -1}}, + {NULL, 0, -1, {-1, -1, -1}}, + {"N", 0, NUMERIC, {FMT_F, 7, 0}}, + {"NU", 0, NUMERIC, {FMT_F, 7, 0}}, + }; + +/* Output file, or NULL for the active file. */ +static struct file_handle *outfile; + +/* Missing value types. */ +enum + { + ITEMWISE, /* Missing values item by item. */ + COLUMNWISE /* Missing values column by column. */ + }; + +/* ITEMWISE or COLUMNWISE. */ +static int missing; + +/* Aggregate variables. */ +static struct agr_var *agr_first, *agr_next; + +/* Aggregate dictionary. */ +static struct dictionary *agr_dict; + +/* Number of cases passed through aggregation. */ +static int case_count; + +/* Last values of the break variables. */ +static union value *prev_case; + +/* Buffers for use by the 10x transformation. */ +static flt64 *buf64_1xx; +static struct ccase *buf_1xx; + +static void initialize_aggregate_info (void); + +/* Prototypes. */ +static int parse_aggregate_functions (void); +static void free_aggregate_functions (void); +static int aggregate_single_case (struct ccase *input, struct ccase *output); +static int create_sysfile (void); + +static int agr_00x_trns_proc (struct trns_header *, struct ccase *); +static void agr_00x_end_func (void); +static int agr_10x_trns_proc (struct trns_header *, struct ccase *); +static void agr_10x_trns_free (struct trns_header *); +static void agr_10x_end_func (void); +static int agr_11x_func (void); + +#if DEBUGGING +static void debug_print (int flags); +#endif + +/* Parsing. */ + +/* Parses and executes the AGGREGATE procedure. */ +int +cmd_aggregate (void) +{ + /* From sort.c. */ + int parse_sort_variables (void); + + /* Have we seen these subcommands? */ + unsigned seen = 0; + + outfile = NULL; + missing = ITEMWISE; + v_sort = NULL; + prev_case = NULL; + + agr_dict = new_dictionary (1); + + lex_match_id ("AGGREGATE"); + + /* Read most of the subcommands. */ + for (;;) + { + lex_match('/'); + + if (lex_match_id ("OUTFILE")) + { + if (seen & 1) + { + free (v_sort); + free_dictionary (agr_dict); + msg (SE, _("OUTFILE specified multiple times.")); + return CMD_FAILURE; + } + seen |= 1; + + lex_match ('='); + if (lex_match ('*')) + outfile = NULL; + else + { + outfile = fh_parse_file_handle (); + if (outfile == NULL) + { + free (v_sort); + free_dictionary (agr_dict); + return CMD_FAILURE; + } + } + } + else if (lex_match_id ("MISSING")) + { + lex_match ('='); + if (!lex_match_id ("COLUMNWISE")) + { + free (v_sort); + free_dictionary (agr_dict); + lex_error (_("while expecting COLUMNWISE")); + return CMD_FAILURE; + } + missing = COLUMNWISE; + } + else if (lex_match_id ("DOCUMENT")) + seen |= 2; + else if (lex_match_id ("PRESORTED")) + seen |= 4; + else if (lex_match_id ("BREAK")) + { + if (seen & 8) + { + free (v_sort); + free_dictionary (agr_dict); + msg (SE, _("BREAK specified multiple times.")); + return CMD_FAILURE; + } + seen |= 8; + + lex_match ('='); + if (!parse_sort_variables ()) + { + free_dictionary (agr_dict); + return CMD_FAILURE; + } + + { + int i; + + for (i = 0; i < nv_sort; i++) + { + struct variable *v; + + v = dup_variable (agr_dict, v_sort[i], v_sort[i]->name); + assert (v != NULL); + } + } + } + else break; + } + + /* Check for proper syntax. */ + if (!(seen & 8)) + msg (SW, _("BREAK subcommand not specified.")); + + /* Read in the aggregate functions. */ + if (!parse_aggregate_functions ()) + { + free_aggregate_functions (); + free (v_sort); + return CMD_FAILURE; + } + + /* Delete documents. */ + if (!(seen & 2)) + { + free (agr_dict->documents); + agr_dict->documents = NULL; + agr_dict->n_documents = 0; + } + + /* Cancel SPLIT FILE. */ + default_dict.n_splits = 0; + free (default_dict.splits); + default_dict.splits = NULL; + +#if DEBUGGING + debug_print (seen); +#endif + + /* Initialize. */ + case_count = 0; + initialize_aggregate_info (); + + /* How to implement all this... There are three important variables: + whether output is going to the active file (0) or a separate file + (1); whether the input data is presorted (0) or needs sorting + (1); whether there is a temporary transformation (1) or not (0). + The eight cases are as follows: + + 000 (0): Pass it through an aggregate transformation that + modifies the data. + + 001 (1): Cancel the temporary transformation and handle as 000. + + 010 (2): Set up a SORT CASES and aggregate the output, writing + the results to the active file. + + 011 (3): Cancel the temporary transformation and handle as 010. + + 100 (4): Pass it through an aggregate transformation that doesn't + modify the data but merely writes it to the output file. + + 101 (5): Handled as 100. + + 110 (6): Set up a SORT CASES and capture the output, aggregate + it, write it to the output file without modifying the active + file. + + 111 (7): Handled as 110. */ + + { + unsigned type = 0; + + if (outfile != NULL) + type |= 4; + if (nv_sort != 0 && (seen & 4) == 0) + type |= 2; + if (temporary) + type |= 1; + + switch (type) + { + case 3: + cancel_temporary (); + /* fall through */ + case 2: + sort_cases (0); + goto case0; + + case 1: + cancel_temporary (); + /* fall through */ + case 0: + case0: + { + struct trns_header *t = xmalloc (sizeof *t); + t->proc = agr_00x_trns_proc; + t->free = NULL; + add_transformation (t); + + temporary = 2; + temp_dict = agr_dict; + temp_trns = n_trns; + + agr_dict = NULL; + + procedure (NULL, NULL, agr_00x_end_func); + break; + } + + case 4: + case 5: + { + if (!create_sysfile ()) + goto lossage; + + { + struct trns_header *t = xmalloc (sizeof *t); + t->proc = agr_10x_trns_proc; + t->free = agr_10x_trns_free; + add_transformation (t); + + procedure (NULL, NULL, agr_10x_end_func); + } + + break; + } + + case 6: + case 7: + sort_cases (1); + + if (!create_sysfile ()) + goto lossage; + read_sort_output (agr_11x_func); + + { + struct ccase *save_temp_case = temp_case; + temp_case = NULL; + agr_11x_func (); + temp_case = save_temp_case; + } + + break; + + default: + assert (0); + } + } + + free (buf64_1xx); + free (buf_1xx); + + /* Clean up. */ + free (v_sort); + free_aggregate_functions (); + free (prev_case); + + return CMD_SUCCESS; + +lossage: + /* Clean up. */ + free (v_sort); + free_aggregate_functions (); + free (prev_case); + + return CMD_FAILURE; +} + +/* Create a system file for use in aggregation to an external file, + and allocate temporary buffers for writing out cases. */ +static int +create_sysfile (void) +{ + struct sfm_write_info w; + w.h = outfile; + w.dict = agr_dict; + w.compress = set_scompression; + if (!sfm_write_dictionary (&w)) + { + free_aggregate_functions (); + free (v_sort); + free_dictionary (agr_dict); + return 0; + } + + buf64_1xx = xmalloc (sizeof *buf64_1xx * w.case_size); + buf_1xx = xmalloc (sizeof (struct ccase) + sizeof (union value) * (agr_dict->nval - 1)); + + return 1; +} + +/* Parse all the aggregate functions. */ +static int +parse_aggregate_functions (void) +{ + agr_first = agr_next = NULL; + + /* Anticipate weighting for optimization later. */ + update_weighting (&default_dict); + + /* Parse everything. */ + for (;;) + { + char **dest; + char **dest_label; + int n_dest; + + int include_missing; + struct agr_func *function; + int func_index; + + union value arg[2]; + + struct variable **src; + int n_src; + + int i; + + dest = NULL; + dest_label = NULL; + n_dest = 0; + src = NULL; + n_src = 0; + arg[0].c = NULL; + arg[1].c = NULL; + + /* Parse the list of target variables. */ + while (!lex_match ('=')) + { + int n_dest_prev = n_dest; + + if (!parse_DATA_LIST_vars (&dest, &n_dest, PV_APPEND | PV_SINGLE | PV_NO_SCRATCH)) + goto lossage; + + /* Assign empty labels. */ + { + int j; + + dest_label = xrealloc (dest_label, sizeof *dest_label * n_dest); + for (j = n_dest_prev; j < n_dest; j++) + dest_label[j] = NULL; + } + + if (token == T_STRING) + { + ds_truncate (&tokstr, 120); + dest_label[n_dest - 1] = xstrdup (ds_value (&tokstr)); + lex_get (); + } + } + + /* Get the name of the aggregation function. */ + if (token != T_ID) + { + lex_error (_("expecting aggregation function")); + goto lossage; + } + + include_missing = 0; + if (tokid[strlen (tokid) - 1] == '.') + { + include_missing = 1; + tokid[strlen (tokid) - 1] = 0; + } + + for (function = agr_func_tab; function->name; function++) + if (!strcmp (function->name, tokid)) + break; + if (NULL == function->name) + { + msg (SE, _("Unknown aggregation function %s."), tokid); + goto lossage; + } + func_index = function - agr_func_tab; + lex_get (); + + /* Check for leading lparen. */ + if (!lex_match ('(')) + { + if (func_index == N) + func_index = N_NO_VARS; + else if (func_index == NU) + func_index = NU_NO_VARS; + else + { + lex_error (_("expecting `('")); + goto lossage; + } + } else { + /* Parse list of source variables. */ + { + int pv_opts = PV_NO_SCRATCH; + + if (func_index == SUM || func_index == MEAN || func_index == SD) + pv_opts |= PV_NUMERIC; + else if (function->n_args) + pv_opts |= PV_SAME_TYPE; + + if (!parse_variables (&default_dict, &src, &n_src, pv_opts)) + goto lossage; + } + + /* Parse function arguments, for those functions that + require arguments. */ + if (function->n_args != 0) + for (i = 0; i < function->n_args; i++) + { + int type; + + lex_match (','); + if (token == T_STRING) + { + arg[i].c = xstrdup (ds_value (&tokstr)); + type = ALPHA; + } + else if (token == T_NUM) + { + arg[i].f = tokval; + type = NUMERIC; + } else { + msg (SE, _("Missing argument %d to %s."), i + 1, function->name); + goto lossage; + } + + lex_get (); + + if (type != src[0]->type) + { + msg (SE, _("Arguments to %s must be of same type as " + "source variables."), + function->name); + goto lossage; + } + } + + /* Trailing rparen. */ + if (!lex_match(')')) + { + lex_error (_("expecting `)'")); + goto lossage; + } + + /* Now check that the number of source variables match the + number of target variables. Do this here because if we + do it earlier then the user can get very misleading error + messages; i.e., `AGGREGATE x=SUM(y t).' will get this + error message when a proper message would be more like + `unknown variable t'. */ + if (n_src != n_dest) + { + msg (SE, _("Number of source variables (%d) does not match " + "number of target variables (%d)."), + n_src, n_dest); + goto lossage; + } + } + + /* Finally add these to the linked list of aggregation + variables. */ + for (i = 0; i < n_dest; i++) + { + struct agr_var *v = xmalloc (sizeof *v); + + /* Add variable to chain. */ + if (agr_first) + agr_next = agr_next->next = v; + else + agr_first = agr_next = v; + agr_next->next = NULL; + + /* Create the target variable in the aggregate + dictionary. */ + { + struct variable *destvar; + + agr_next->function = func_index; + + if (src) + { + int output_type; + + agr_next->src = src[i]; + + if (src[i]->type == ALPHA) + { + agr_next->function |= FSTRING; + agr_next->string = xmalloc (src[i]->width); + } + + if (default_dict.weight_index != -1) + agr_next->function |= FWEIGHT; + + if (agr_next->src->type == NUMERIC) + output_type = NUMERIC; + else + output_type = function->alpha_type; + + if (function->alpha_type == ALPHA) + destvar = dup_variable (agr_dict, agr_next->src, dest[i]); + else + { + destvar = create_variable (agr_dict, dest[i], output_type, + agr_next->src->width); + if (output_type == NUMERIC) + destvar->print = destvar->write = function->format; + if (output_type == NUMERIC && default_dict.weight_index != -1 + && (func_index == N || func_index == N_NO_VARS + || func_index == NU || func_index == NU_NO_VARS)) + { + struct fmt_spec f = {FMT_F, 8, 2}; + + destvar->print = destvar->write = f; + } + } + } else { + agr_next->src = NULL; + destvar = create_variable (agr_dict, dest[i], NUMERIC, 0); + } + + if (!destvar) + { + msg (SE, _("Variable name %s is not unique within the " + "aggregate file dictionary, which contains " + "the aggregate variables and the break " + "variables."), + dest[i]); + free (dest[i]); + goto lossage; + } + + free (dest[i]); + if (dest_label[i]) + { + destvar->label = dest_label[i]; + dest_label[i] = NULL; + } + else if (function->alpha_type == ALPHA) + destvar->print = destvar->write = function->format; + + agr_next->dest = destvar; + } + + agr_next->include_missing = include_missing; + + if (agr_next->src != NULL) + { + int j; + + if (agr_next->src->type == NUMERIC) + for (j = 0; j < function->n_args; j++) + agr_next->arg[j].f = arg[j].f; + else + for (j = 0; j < function->n_args; j++) + agr_next->arg[j].c = xstrdup (arg[j].c); + } + } + + if (src != NULL && src[0]->type == ALPHA) + for (i = 0; i < function->n_args; i++) + { + free (arg[i].c); + arg[i].c = NULL; + } + + free (src); + free (dest); + free (dest_label); + + if (!lex_match ('/')) + { + if (token == '.') + return 1; + + lex_error ("expecting end of command"); + return 0; + } + continue; + + lossage: + for (i = 0; i < n_dest; i++) + { + free (dest[i]); + free (dest_label[i]); + } + free (dest); + free (dest_label); + free (arg[0].c); + free (arg[1].c); + if (src && n_src && src[0]->type == ALPHA) + for (i = 0; i < function->n_args; i++) + { + free(arg[i].c); + arg[i].c = NULL; + } + free (src); + + return 0; + } +} + +/* Frees all the state for the AGGREGATE procedure. */ +static void +free_aggregate_functions (void) +{ + struct agr_var *iter, *next; + + if (agr_dict) + free_dictionary (agr_dict); + for (iter = agr_first; iter; iter = next) + { + next = iter->next; + + if (iter->function & FSTRING) + { + int n_args; + int i; + + n_args = agr_func_tab[iter->function & FUNC].n_args; + for (i = 0; i < n_args; i++) + free (iter->arg[i].c); + free (iter->string); + } + free (iter); + } +} + +/* Execution. */ + +static void accumulate_aggregate_info (struct ccase *input); +static void dump_aggregate_info (struct ccase *output); + +/* Processes a single case INPUT for aggregation. If output is + warranted, it is written to case OUTPUT, which may be (but need not + be) an alias to INPUT. Returns -1 when output is performed, -2 + otherwise. */ +/* The code in this function has an eerie similarity to + vfm.c:SPLIT_FILE_procfunc()... */ +static int +aggregate_single_case (struct ccase *input, struct ccase *output) +{ + /* The first case always begins a new break group. We also need to + preserve the values of the case for later comparison. */ + if (case_count++ == 0) + { + int n_elem = 0; + + { + int i; + + for (i = 0; i < nv_sort; i++) + n_elem += v_sort[i]->nv; + } + + prev_case = xmalloc (sizeof *prev_case * n_elem); + + /* Copy INPUT into prev_case. */ + { + union value *iter = prev_case; + int i; + + for (i = 0; i < nv_sort; i++) + { + struct variable *v = v_sort[i]; + + if (v->type == NUMERIC) + (iter++)->f = input->data[v->fv].f; + else + { + memcpy (iter->s, input->data[v->fv].s, v->width); + iter += v->nv; + } + } + } + + accumulate_aggregate_info (input); + + return -2; + } + + /* Compare the value of each break variable to the values on the + previous case. */ + { + union value *iter = prev_case; + int i; + + for (i = 0; i < nv_sort; i++) + { + struct variable *v = v_sort[i]; + + switch (v->type) + { + case NUMERIC: + if (approx_ne (input->data[v->fv].f, iter->f)) + goto not_equal; + iter++; + break; + case ALPHA: + if (memcmp (input->data[v->fv].s, iter->s, v->width)) + goto not_equal; + iter += v->nv; + break; + default: + assert (0); + } + } + } + + accumulate_aggregate_info (input); + + return -2; + +not_equal: + /* The values of the break variable are different from the values on + the previous case. That means that it's time to dump aggregate + info. */ + dump_aggregate_info (output); + initialize_aggregate_info (); + accumulate_aggregate_info (input); + + /* Copy INPUT into prev_case. */ + { + union value *iter = prev_case; + int i; + + for (i = 0; i < nv_sort; i++) + { + struct variable *v = v_sort[i]; + + if (v->type == NUMERIC) + (iter++)->f = input->data[v->fv].f; + else + { + memcpy (iter->s, input->data[v->fv].s, v->width); + iter += v->nv; + } + } + } + + return -1; +} + +/* Accumulates aggregation data from the case INPUT. */ +static void +accumulate_aggregate_info (struct ccase *input) +{ + struct agr_var *iter; + +#define WEIGHT (input->data[default_dict.weight_index].f) + + for (iter = agr_first; iter; iter = iter->next) + if (iter->src) + { + union value *v = &input->data[iter->src->fv]; + + if ((!iter->include_missing && is_missing (v, iter->src)) + || (iter->include_missing && iter->src->type == NUMERIC + && v->f == SYSMIS)) + { + switch (iter->function) + { + case NMISS | FWEIGHT: + iter->dbl[0] += WEIGHT; + break; + case NMISS: + case NUMISS: + case NUMISS | FWEIGHT: + iter->int1++; + break; + } + iter->missing = 1; + continue; + } + + /* This is horrible. There are too many possibilities. */ + switch (iter->function) + { + case SUM: + case SUM | FWEIGHT: + iter->dbl[0] += v->f; + break; + case MEAN: + iter->dbl[0] += v->f; + iter->int1++; + break; + case MEAN | FWEIGHT: + { + double w = WEIGHT; + iter->dbl[0] += v->f * w; + iter->dbl[1] += w; + break; + } + case SD: + iter->dbl[0] += v->f; + iter->dbl[1] += v->f * v->f; + iter->int1++; + break; + case SD | FWEIGHT: + { + double w = WEIGHT; + double product = v->f * w; + iter->dbl[0] += product; + iter->dbl[1] += product * v->f; + iter->dbl[2] += w; + break; + } + case MAX: + case MAX | FWEIGHT: + iter->dbl[0] = max (iter->dbl[0], v->f); + iter->int1 = 1; + break; + case MAX | FSTRING: + case MAX | FSTRING | FWEIGHT: + if (memcmp (iter->string, v->s, iter->src->width) < 0) + memcpy (iter->string, v->s, iter->src->width); + iter->int1 = 1; + break; + case MIN: + case MIN | FWEIGHT: + iter->dbl[0] = min (iter->dbl[0], v->f); + iter->int1 = 1; + break; + case MIN | FSTRING: + case MIN | FSTRING | FWEIGHT: + if (memcmp (iter->string, v->s, iter->src->width) > 0) + memcpy (iter->string, v->s, iter->src->width); + iter->int1 = 1; + break; + case FGT: + case PGT: + if (approx_gt (v->f, iter->arg[0].f)) + iter->int1++; + iter->int2++; + break; + case FGT | FWEIGHT: + case PGT | FWEIGHT: + { + double w = WEIGHT; + if (approx_gt (v->f, iter->arg[0].f)) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FGT | FSTRING: + case PGT | FSTRING: + if (memcmp (iter->arg[0].c, v->s, iter->src->width) < 0) + iter->int1++; + iter->int2++; + break; + case FGT | FSTRING | FWEIGHT: + case PGT | FSTRING | FWEIGHT: + { + double w = WEIGHT; + if (memcmp (iter->arg[0].c, v->s, iter->src->width) < 0) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FLT: + case PLT: + if (approx_lt (v->f, iter->arg[0].f)) + iter->int1++; + iter->int2++; + break; + case FLT | FWEIGHT: + case PLT | FWEIGHT: + { + double w = WEIGHT; + if (approx_lt (v->f, iter->arg[0].f)) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FLT | FSTRING: + case PLT | FSTRING: + if (memcmp (iter->arg[0].c, v->s, iter->src->width) > 0) + iter->int1++; + iter->int2++; + break; + case FLT | FSTRING | FWEIGHT: + case PLT | FSTRING | FWEIGHT: + { + double w = WEIGHT; + if (memcmp (iter->arg[0].c, v->s, iter->src->width) > 0) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FIN: + case PIN: + if (approx_in_range (v->f, iter->arg[0].f, iter->arg[1].f)) + iter->int1++; + iter->int2++; + break; + case FIN | FWEIGHT: + case PIN | FWEIGHT: + { + double w = WEIGHT; + if (approx_in_range (v->f, iter->arg[0].f, iter->arg[1].f)) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FIN | FSTRING: + case PIN | FSTRING: + if (memcmp (iter->arg[0].c, v->s, iter->src->width) <= 0 + && memcmp (iter->arg[1].c, v->s, iter->src->width) >= 0) + iter->int1++; + iter->int2++; + break; + case FIN | FSTRING | FWEIGHT: + case PIN | FSTRING | FWEIGHT: + { + double w = WEIGHT; + if (memcmp (iter->arg[0].c, v->s, iter->src->width) <= 0 + && memcmp (iter->arg[1].c, v->s, iter->src->width) >= 0) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FOUT: + case POUT: + if (!approx_in_range (v->f, iter->arg[0].f, iter->arg[1].f)) + iter->int1++; + iter->int2++; + break; + case FOUT | FWEIGHT: + case POUT | FWEIGHT: + { + double w = WEIGHT; + if (!approx_in_range (v->f, iter->arg[0].f, iter->arg[1].f)) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case FOUT | FSTRING: + case POUT | FSTRING: + if (memcmp (iter->arg[0].c, v->s, iter->src->width) > 0 + && memcmp (iter->arg[1].c, v->s, iter->src->width) < 0) + iter->int1++; + iter->int2++; + break; + case FOUT | FSTRING | FWEIGHT: + case POUT | FSTRING | FWEIGHT: + { + double w = WEIGHT; + if (memcmp (iter->arg[0].c, v->s, iter->src->width) > 0 + && memcmp (iter->arg[1].c, v->s, iter->src->width) < 0) + iter->dbl[0] += w; + iter->dbl[1] += w; + break; + } + case N | FWEIGHT: + iter->dbl[0] += WEIGHT; + break; + case N: + case NU: + case NU | FWEIGHT: + iter->int1++; + break; + case FIRST: + case FIRST | FWEIGHT: + if (iter->int1 == 0) + { + iter->dbl[0] = v->f; + iter->int1 = 1; + } + break; + case FIRST | FSTRING: + case FIRST | FSTRING | FWEIGHT: + if (iter->int1 == 0) + { + memcpy (iter->string, v->s, iter->src->width); + iter->int1 = 1; + } + break; + case LAST: + case LAST | FWEIGHT: + iter->dbl[0] = v->f; + iter->int1 = 1; + break; + case LAST | FSTRING: + case LAST | FSTRING | FWEIGHT: + memcpy (iter->string, v->s, iter->src->width); + iter->int1 = 1; + break; + default: + assert (0); + } + } else { + switch (iter->function) + { + case N_NO_VARS | FWEIGHT: + iter->dbl[0] += WEIGHT; + break; + case N_NO_VARS: + case NU_NO_VARS: + case NU_NO_VARS | FWEIGHT: + iter->int1++; + break; + default: + assert (0); + } + } +} + +/* We've come to a record that differs from the previous in one or + more of the break variables. Make an output record from the + accumulated statistics in the OUTPUT case. */ +static void +dump_aggregate_info (struct ccase *output) +{ + debug_printf (("(dumping ")); + + { + int n_elem = 0; + + { + int i; + + for (i = 0; i < nv_sort; i++) + n_elem += v_sort[i]->nv; + } + debug_printf (("n_elem=%d:", n_elem)); + memcpy (output->data, prev_case, sizeof (union value) * n_elem); + } + + { + struct agr_var *i; + + for (i = agr_first; i; i = i->next) + { + union value *v = &output->data[i->dest->fv]; + + debug_printf ((" %d,%d", i->dest->fv, i->dest->nv)); + + if (missing == COLUMNWISE && i->missing != 0 + && (i->function & FUNC) != N && (i->function & FUNC) != NU + && (i->function & FUNC) != NMISS && (i->function & FUNC) != NUMISS) + { + if (i->function & FSTRING) + memset (v->s, ' ', i->dest->width); + else + v->f = SYSMIS; + continue; + } + + switch (i->function) + { + case SUM: + case SUM | FWEIGHT: + v->f = i->dbl[0]; + break; + case MEAN: + v->f = i->int1 ? i->dbl[0] / i->int1 : SYSMIS; + break; + case MEAN | FWEIGHT: + v->f = i->dbl[1] != 0.0 ? i->dbl[0] / i->dbl[1] : SYSMIS; + break; + case SD: + v->f = ((i->int1 > 1) + ? calc_stddev (calc_variance (i->dbl, i->int1)) + : SYSMIS); + break; + case SD | FWEIGHT: + v->f = ((i->dbl[2] > 1.0) + ? calc_stddev (calc_variance (i->dbl, i->dbl[2])) + : SYSMIS); + break; + case MAX: + case MAX | FWEIGHT: + case MIN: + case MIN | FWEIGHT: + v->f = i->int1 ? i->dbl[0] : SYSMIS; + break; + case MAX | FSTRING: + case MAX | FSTRING | FWEIGHT: + case MIN | FSTRING: + case MIN | FSTRING | FWEIGHT: + if (i->int1) + memcpy (v->s, i->string, i->dest->width); + else + memset (v->s, ' ', i->dest->width); + break; + case FGT: + case FGT | FSTRING: + case FLT: + case FLT | FSTRING: + case FIN: + case FIN | FSTRING: + case FOUT: + case FOUT | FSTRING: + v->f = i->int2 ? (double) i->int1 / (double) i->int2 : SYSMIS; + break; + case FGT | FWEIGHT: + case FGT | FSTRING | FWEIGHT: + case FLT | FWEIGHT: + case FLT | FSTRING | FWEIGHT: + case FIN | FWEIGHT: + case FIN | FSTRING | FWEIGHT: + case FOUT | FWEIGHT: + case FOUT | FSTRING | FWEIGHT: + v->f = i->dbl[1] ? i->dbl[0] / i->dbl[1] : SYSMIS; + break; + case PGT: + case PGT | FSTRING: + case PLT: + case PLT | FSTRING: + case PIN: + case PIN | FSTRING: + case POUT: + case POUT | FSTRING: + v->f = (i->int2 + ? (double) i->int1 / (double) i->int2 * 100.0 + : SYSMIS); + break; + case PGT | FWEIGHT: + case PGT | FSTRING | FWEIGHT: + case PLT | FWEIGHT: + case PLT | FSTRING | FWEIGHT: + case PIN | FWEIGHT: + case PIN | FSTRING | FWEIGHT: + case POUT | FWEIGHT: + case POUT | FSTRING | FWEIGHT: + v->f = i->dbl[1] ? i->dbl[0] / i->dbl[1] * 100.0 : SYSMIS; + break; + case N | FWEIGHT: + v->f = i->dbl[0]; + case N: + case NU: + case NU | FWEIGHT: + v->f = i->int1; + break; + case FIRST: + case FIRST | FWEIGHT: + case LAST: + case LAST | FWEIGHT: + v->f = i->int1 ? i->dbl[0] : SYSMIS; + break; + case FIRST | FSTRING: + case FIRST | FSTRING | FWEIGHT: + case LAST | FSTRING: + case LAST | FSTRING | FWEIGHT: + if (i->int1) + memcpy (v->s, i->string, i->dest->width); + else + memset (v->s, ' ', i->dest->width); + break; + case N_NO_VARS | FWEIGHT: + v->f = i->dbl[0]; + break; + case N_NO_VARS: + case NU_NO_VARS: + case NU_NO_VARS | FWEIGHT: + v->f = i->int1; + break; + case NMISS | FWEIGHT: + v->f = i->dbl[0]; + break; + case NMISS: + case NUMISS: + case NUMISS | FWEIGHT: + v->f = i->int1; + break; + default: + assert (0); + } + } + } + debug_printf ((") ")); +} + +/* Resets the state for all the aggregate functions. */ +static void +initialize_aggregate_info (void) +{ + struct agr_var *iter; + + for (iter = agr_first; iter; iter = iter->next) + { + int plain_function = iter->function & ~FWEIGHT; + + iter->missing = 0; + switch (plain_function) + { + case MIN: + iter->dbl[0] = DBL_MAX; + break; + case MIN | FSTRING: + memset (iter->string, 255, iter->src->width); + break; + case MAX: + iter->dbl[0] = -DBL_MAX; + break; + case MAX | FSTRING: + memset (iter->string, 0, iter->src->width); + break; + default: + iter->dbl[0] = iter->dbl[1] = iter->dbl[2] = 0.0; + iter->int1 = iter->int2 = 0; + break; + } + } +} + +/* Aggregate each case as it comes through. Cases which aren't needed + are dropped. */ +static int +agr_00x_trns_proc (struct trns_header *h unused, struct ccase *c) +{ + int code = aggregate_single_case (c, compaction_case); + debug_printf (("%d ", code)); + return code; +} + +/* Output the last aggregate case. It's okay to call the vfm_sink's + write() method here because end_func is called so soon after all + the cases have been output; very little has been cleaned up at this + point. */ +static void +agr_00x_end_func (void) +{ + /* Ensure that info for the last break group gets written to the + active file. */ + dump_aggregate_info (compaction_case); + vfm_sink_info.ncases++; + vfm_sink->write (); +} + +/* Transform the aggregate case buf_1xx, in internal format, to system + file format, in buf64_1xx, and write the resultant case to the + system file. */ +static void +write_case_to_sfm (void) +{ + flt64 *p = buf64_1xx; + int i; + + for (i = 0; i < agr_dict->nvar; i++) + { + struct variable *v = agr_dict->var[i]; + + if (v->type == NUMERIC) + { + double src = buf_1xx->data[v->fv].f; + if (src == SYSMIS) + *p++ = -FLT64_MAX; + else + *p++ = src; + } + else + { + memcpy (p, buf_1xx->data[v->fv].s, v->width); + memset (&((char *) p)[v->width], ' ', + REM_RND_UP (v->width, sizeof (flt64))); + p += DIV_RND_UP (v->width, sizeof (flt64)); + } + } + + sfm_write_case (outfile, buf64_1xx, p - buf64_1xx); +} + +/* Aggregate the current case and output it if we passed a + breakpoint. */ +static int +agr_10x_trns_proc (struct trns_header *h unused, struct ccase *c) +{ + int code = aggregate_single_case (c, buf_1xx); + + assert (code == -2 || code == -1); + if (code == -1) + write_case_to_sfm (); + return -1; +} + +/* Close the system file now that we're done with it. */ +static void +agr_10x_trns_free (struct trns_header *h unused) +{ + fh_close_handle (outfile); +} + +/* Ensure that info for the last break group gets written to the + system file. */ +static void +agr_10x_end_func (void) +{ + dump_aggregate_info (buf_1xx); + write_case_to_sfm (); +} + +/* When called with temp_case non-NULL (the normal case), runs the + case through the aggregater and outputs it to the system file if + appropriate. If temp_case is NULL, finishes up writing the last + case if necessary. */ +static int +agr_11x_func (void) +{ + if (temp_case != NULL) + { + int code = aggregate_single_case (temp_case, buf_1xx); + + assert (code == -2 || code == -1); + if (code == -1) + write_case_to_sfm (); + } + else + { + if (case_count) + { + dump_aggregate_info (buf_1xx); + write_case_to_sfm (); + } + fh_close_handle (outfile); + } + return 1; +} + +/* Debugging. */ +#if DEBUGGING +/* Print out useful debugging information. */ +static void +debug_print (int flags) +{ + printf ("AGGREGATE\n /OUTFILE=%s\n", + outfile ? fh_handle_filename (outfile) : "*"); + + if (missing == COLUMNWISE) + puts (" /MISSING=COLUMNWISE"); + + if (flags & 2) + puts (" /DOCUMENT"); + if (flags & 4) + puts (" /PRESORTED"); + + { + int i; + + printf (" /BREAK="); + for (i = 0; i < nv_sort; i++) + printf ("%s(%c) ", v_sort[i]->name, + v_sort[i]->p.srt.order == SRT_ASCEND ? 'A' : 'D'); + putc ('\n', stdout); + } + + { + struct agr_var *iter; + + for (iter = agr_first; iter; iter = iter->next) + { + struct agr_func *f = &agr_func_tab[iter->function & FUNC]; + + printf (" /%s", iter->dest->name); + if (iter->dest->label) + printf ("'%s'", iter->dest->label); + printf ("=%s(%s", f->name, iter->src->name); + if (f->n_args) + { + int i; + + for (i = 0; i < f->n_args; i++) + { + putc (',', stdout); + if (iter->src->type == NUMERIC) + printf ("%g", iter->arg[i].f); + else + printf ("%.*s", iter->src->width, iter->arg[i].c); + } + } + printf (")\n"); + } + } +} + +#endif /* DEBUGGING */ diff --git a/src/alloc.c b/src/alloc.c new file mode 100644 index 00000000..763dab3d --- /dev/null +++ b/src/alloc.c @@ -0,0 +1,122 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "str.h" + +static void out_of_memory (void); + +/* Public functions. */ + +/* Allocates a block of SIZE bytes and returns it. + If SIZE is 0, returns a null pointer. + Aborts if unsuccessful. */ +void * +xmalloc (size_t size) +{ + void *vp; + if (size == 0) + return NULL; + + vp = malloc (size); + if (!vp) + out_of_memory (); + + return vp; +} + +/* Allocates a block of SIZE bytes, fill it with all-bits-0, and + returns it. + If SIZE is 0, returns a null pointer. + Aborts if unsuccessful. */ +void * +xcalloc (size_t size) +{ + void *vp = xmalloc (size); + memset (vp, 0, size); + return vp; +} + +/* If SIZE is 0, then block PTR is freed and a null pointer is + returned. + Otherwise, if PTR is a null pointer, then a new block is allocated + and returned. + Otherwise, block PTR is reallocated to be SIZE bytes in size and + the new location of the block is returned. + Aborts if unsuccessful. */ +void * +xrealloc (void *ptr, size_t size) +{ + void *vp; + if (!size) + { + if (ptr) + free (ptr); + + return NULL; + } + + if (ptr) + vp = realloc (ptr, size); + else + vp = malloc (size); + + if (!vp) + out_of_memory (); + + return vp; +} + +/* Makes a copy of string S in malloc()'d memory and returns the copy. + S must not be a null pointer. */ +char * +xstrdup (const char *s) +{ + size_t size; + char *t; + + assert (s != NULL); + + size = strlen (s) + 1; + + t = malloc (size); + if (!t) + out_of_memory (); + + memcpy (t, s, size); + return t; +} + +/* Private functions. */ + +/* Report an out-of-memory condition and abort execution. */ +static void +out_of_memory (void) +{ +#if __CHECKER__ + fprintf (stderr, "Out of memory: inducing segfault\n"); + *((int *) 0) = 0; +#else + fprintf (stderr, "virtual memory exhausted\n"); + exit (EXIT_FAILURE); +#endif +} diff --git a/src/alloc.h b/src/alloc.h new file mode 100644 index 00000000..50e7ab1f --- /dev/null +++ b/src/alloc.h @@ -0,0 +1,31 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !alloc_h +#define alloc_h 1 + +#include + +/* Functions. */ +void *xmalloc (size_t size); +void *xcalloc (size_t size); +void *xrealloc (void *ptr, size_t size); +char *xstrdup (const char *s); + +#endif /* alloc.h */ diff --git a/src/apply-dict.c b/src/apply-dict.c new file mode 100644 index 00000000..f4674531 --- /dev/null +++ b/src/apply-dict.c @@ -0,0 +1,184 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "avl.h" +#include "command.h" +#include "error.h" +#include "file-handle.h" +#include "lexer.h" +#include "sfm.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Parses and executes APPLY DICTIONARY. */ +int +cmd_apply_dictionary (void) +{ + struct file_handle *handle; + struct dictionary *dict; + + int n_matched = 0; + + int i; + + lex_match_id ("APPLY"); + lex_match_id ("DICTIONARY"); + + lex_match_id ("FROM"); + lex_match ('='); + handle = fh_parse_file_handle (); + if (!handle) + return CMD_FAILURE; + + dict = sfm_read_dictionary (handle, NULL); + if (dict == NULL) + return CMD_FAILURE; + + for (i = 0; i < dict->nvar; i++) + { + struct variable *s = dict->var[i]; + struct variable *t = find_variable (s->name); + if (t == NULL) + continue; + + n_matched++; + if (s->type != t->type) + { + msg (SW, _("Variable %s is %s in target file, but %s in " + "source file."), + s->name, + t->type == ALPHA ? _("string") : _("numeric"), + s->type == ALPHA ? _("string") : _("numeric")); + continue; + } + + if (s->label && strcspn (s->label, " ") != strlen (s->label)) + { + free (t->label); + t->label = s->label; + s->label = NULL; + } + + if (s->val_lab && t->width > MAX_SHORT_STRING) + msg (SW, _("Cannot add value labels from source file to " + "long string variable %s."), + s->name); + else if (s->val_lab) + { + if (t->width < s->width) + { + avl_traverser iter; + struct value_label *lab; + + avl_traverser_init (iter); + while ((lab = avl_traverse (s->val_lab, &iter)) != NULL) + { + int j; + + /* If the truncated characters aren't all blanks + anyway, then don't apply the value labels. */ + for (j = t->width; j < s->width; j++) + if (lab->v.s[j] != ' ') + goto skip_value_labels; + } + } + else + { + /* Fortunately, we follow the convention that all value + label values are right-padded with spaces, so it is + unnecessary to bother padding values here. */ + } + + avl_destroy (t->val_lab, free_val_lab); + t->val_lab = s->val_lab; + s->val_lab = NULL; + } + skip_value_labels: ; + + if (s->miss_type != MISSING_NONE && t->width > MAX_SHORT_STRING) + msg (SW, _("Cannot apply missing values from source file to " + "long string variable %s."), + s->name); + else if (s->miss_type != MISSING_NONE) + { + if (t->width < s->width) + { + static const int miss_count[MISSING_COUNT] = + { + 0, 1, 2, 3, 2, 1, 1, 3, 2, 2, + }; + + int j, k; + + for (j = 0; j < miss_count[s->miss_type]; j++) + for (k = t->width; k < s->width; k++) + if (s->missing[j].s[k] != ' ') + goto skip_missing_values; + } + + t->miss_type = s->miss_type; + memcpy (t->missing, s->missing, sizeof s->missing); + } + + if (s->type == NUMERIC) + { + t->print = s->print; + t->write = s->write; + } + } + + if (!n_matched) + msg (SW, _("No matching variables found between the source " + "and target files.")); + + /* Weighting. */ + { + const int tfw = find_variable (default_dict.weight_var) != 0; + const int sfw = dict->weight_var[0] != 0; + struct variable *w; + + switch (10 * tfw + sfw) + { + case 10: + /* The working file retains its weighting variable. */ + break; + + case 00: + case 01: + /* Fall through to case 11. */ + + case 11: + w = find_variable (dict->weight_var); + if (w) + strcpy (default_dict.weight_var, dict->weight_var); + break; + } + } + skip_missing_values: ; + + sfm_maybe_close (handle); + + return lex_end_of_command (); +} diff --git a/src/approx.h b/src/approx.h new file mode 100644 index 00000000..8dda9d2f --- /dev/null +++ b/src/approx.h @@ -0,0 +1,59 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !approx_h +#define approx_h 1 + +#include +#include + +/* Minimum difference to consider values to be distinct. */ +#define EPSILON (DBL_EPSILON*10) + +/* The boundary at EPSILON is considered to be equal. */ +/* Possible modification: insert frexp() into all these expressions. */ + +#define approx_eq(A, B) \ + (fabs((A)-(B))<=EPSILON) + +#define approx_ne(A, B) \ + (fabs((A)-(B))>EPSILON) + +#define approx_ge(A, B) \ + ((A) >= (B)-EPSILON) + +#define approx_gt(A, B) \ + ((A) > (B)+EPSILON) + +#define approx_le(A, B) \ + ((A) <= (B)+EPSILON) + +#define approx_lt(A, B) \ + ((A) < (B)-EPSILON) + +#define approx_floor(x) \ + (floor((x)+EPSILON)) + +#define approx_in_range(V, L, H) \ + (((V) >= (L)-EPSILON) && ((V) <= (H)+EPSILON)) + +#define approx_compare(A, B) \ + (approx_gt(A,B) ? 1 : (approx_lt(A,B) ? -1 : 0)) + +#endif /* !approx_h */ diff --git a/src/ascii.c b/src/ascii.c new file mode 100644 index 00000000..c6f48f00 --- /dev/null +++ b/src/ascii.c @@ -0,0 +1,1631 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "main.h" +#include "misc.h" +#include "output.h" +#include "pool.h" +#include "version.h" + +/* ASCII driver options: (defaults listed first) + + output-file="pspp.list" + char-set=ascii|latin1 + form-feed-string="\f" Written as a formfeed. + newline-string=default|"\r\n"|"\n" + Written as a newline. + paginate=on|off Formfeeds are desired? + tab-width=8 Width of a tab; 0 to not use tabs. + init="" Written at beginning of output. + done="" Written at end of output. + + headers=on|off Put headers at top of page? + length=66 + width=130 + lpi=6 Only used to determine font size. + cpi=10 + + left-margin=0 + right-margin=0 + top-margin=2 + bottom-margin=2 + + box[x]="strng" Sets box character X (X in base 4: 0-3333). + italic-on=overstrike|"strng" Turns on italic (underline). + italic-off=""|"strng" Turns off italic; ignored for overstrike. + bold-on=overstrike|"strng" Turns on bold. + bold-off=""|"strng" Turns off bold; ignored for overstrike. + bold-italic-on=overstrike|"strng" Turns on bold-italic. + bold-italic-off=""|"strng" Turns off bold-italic; ignored for overstrike. + overstrike-style=single|line Can we print a whole line then BS over it, or + must we go char by char, as on a terminal? + carriage-return-style=bs|cr Must we return the carriage with a sequence of + BSes, or will a single CR do it? + */ + +/* Disable messages by failed range checks. */ +/*#define SUPPRESS_WARNINGS 1 */ + +/* Character set. */ +enum + { + CHS_ASCII, /* 7-bit ASCII */ + CHS_LATIN1 /* Latin 1; not really supported at the moment */ + }; + +/* Overstrike style. */ +enum + { + OVS_SINGLE, /* Overstrike each character: "a\b_b\b_c\b_" */ + OVS_LINE /* Overstrike lines: "abc\b\b\b___" (or if + newline is "\r\n", then "abc\r___"). Easier + on the printer, doesn't work on a tty. */ + }; + +/* Basic output strings. */ +enum + { + OPS_INIT, /* Document initialization string. */ + OPS_DONE, /* Document uninit string. */ + OPS_FORMFEED, /* Formfeed string. */ + OPS_NEWLINE, /* Newline string. */ + + OPS_COUNT /* Number of output strings. */ + }; + +/* Line styles bit shifts. */ +enum + { + LNS_TOP = 0, + LNS_LEFT = 2, + LNS_BOTTOM = 4, + LNS_RIGHT = 6, + + LNS_COUNT = 256 + }; + +/* Carriage return style. */ +enum + { + CRS_BS, /* Multiple backspaces. */ + CRS_CR /* Single carriage return. */ + }; + +/* Assembles a byte from four taystes. */ +#define TAYSTE2BYTE(T, L, B, R) \ + (((T) << LNS_TOP) \ + | ((L) << LNS_LEFT) \ + | ((B) << LNS_BOTTOM) \ + | ((R) << LNS_RIGHT)) + +/* Extract tayste with shift value S from byte B. */ +#define BYTE2TAYSTE(B, S) \ + (((B) >> (S)) & 3) + +/* Font style; take one of the first group |'d with one of the second group. */ +enum + { + FSTY_ON = 000, /* Turn font on. */ + FSTY_OFF = 001, /* Turn font off. */ + + FSTY_ITALIC = 0, /* Italic font. */ + FSTY_BOLD = 2, /* Bold font. */ + FSTY_BOLD_ITALIC = 4, /* Bold-italic font. */ + + FSTY_COUNT = 6 /* Number of font styles. */ + }; + +/* ASCII output driver extension record. */ +struct ascii_driver_ext + { + /* User parameters. */ + int char_set; /* CHS_ASCII/CHS_LATIN1; no-op right now. */ + int headers; /* 1=print headers at top of page. */ + int page_length; /* Page length in lines. */ + int page_width; /* Page width in characters. */ + int lpi; /* Lines per inch. */ + int cpi; /* Characters per inch. */ + int left_margin; /* Left margin in characters. */ + int right_margin; /* Right margin in characters. */ + int top_margin; /* Top margin in lines. */ + int bottom_margin; /* Bottom margin in lines. */ + int paginate; /* 1=insert formfeeds. */ + int tab_width; /* Width of a tab; 0 not to use tabs. */ + struct len_string ops[OPS_COUNT]; /* Basic output strings. */ + struct len_string box[LNS_COUNT]; /* Line & box drawing characters. */ + struct len_string fonts[FSTY_COUNT]; /* Font styles; NULL=overstrike. */ + int overstrike_style; /* OVS_SINGLE or OVS_LINE. */ + int carriage_return_style; /* Carriage return style. */ + + /* Internal state. */ + struct file_ext file; /* Output file. */ + int page_number; /* Current page number. */ + unsigned short *page; /* Page content. */ + int page_size; /* Number of bytes allocated for page, attr. */ + int *line_len; /* Length of each line in page, attr. */ + int line_len_size; /* Number of ints allocated for line_len. */ + int w, l; /* Actual width & length w/o margins, etc. */ + int n_output; /* Number of lines output so far. */ + int cur_font; /* Current font by OUTP_F_*. */ +#if GLOBAL_DEBUGGING + int debug; /* Set by som_text_draw(). */ +#endif + }; + +static struct pool *ascii_pool; + +static int postopen (struct file_ext *); +static int preclose (struct file_ext *); + +int +ascii_open_global (struct outp_class *this unused) +{ + ascii_pool = pool_create (); + return 1; +} + +int +ascii_close_global (struct outp_class *this unused) +{ + pool_destroy (ascii_pool); + return 1; +} + +int * +ascii_font_sizes (struct outp_class *this unused, int *n_valid_sizes) +{ + static int valid_sizes[] = {12, 12, 0, 0}; + + assert (n_valid_sizes); + *n_valid_sizes = 1; + return valid_sizes; +} + +int +ascii_preopen_driver (struct outp_driver *this) +{ + struct ascii_driver_ext *x; + int i; + + assert (this->driver_open == 0); + msg (VM (1), _("ASCII driver initializing as `%s'..."), this->name); + this->ext = x = xmalloc (sizeof (struct ascii_driver_ext)); + x->char_set = CHS_ASCII; + x->headers = 1; + x->page_length = 66; + x->page_width = 79; + x->lpi = 6; + x->cpi = 10; + x->left_margin = 0; + x->right_margin = 0; + x->top_margin = 2; + x->bottom_margin = 2; + x->paginate = 1; + x->tab_width = 8; + for (i = 0; i < OPS_COUNT; i++) + ls_null (&x->ops[i]); + for (i = 0; i < LNS_COUNT; i++) + ls_null (&x->box[i]); + for (i = 0; i < FSTY_COUNT; i++) + ls_null (&x->fonts[i]); + x->overstrike_style = OVS_SINGLE; + x->carriage_return_style = CRS_BS; + x->file.filename = NULL; + x->file.mode = "wb"; + x->file.file = NULL; + x->file.sequence_no = &x->page_number; + x->file.param = x; + x->file.postopen = postopen; + x->file.preclose = preclose; + x->page_number = 0; + x->page = NULL; + x->page_size = 0; + x->line_len = NULL; + x->line_len_size = 0; + x->n_output = 0; + x->cur_font = OUTP_F_R; +#if GLOBAL_DEBUGGING + x->debug = 0; +#endif + return 1; +} + +int +ascii_postopen_driver (struct outp_driver *this) +{ + struct ascii_driver_ext *x = this->ext; + + assert (this->driver_open == 0); + + if (NULL == x->file.filename) + x->file.filename = xstrdup ("pspp.list"); + + x->w = x->page_width - x->left_margin - x->right_margin; + x->l = (x->page_length - (x->headers ? 3 : 0) - x->top_margin + - x->bottom_margin - 1); + if (x->w < 59 || x->l < 15) + { + msg (SE, _("ascii driver: Area of page excluding margins and headers " + "must be at least 59 characters wide by 15 lines long. Page as " + "configured is only %d characters by %d lines."), x->w, x->l); + return 0; + } + + this->res = x->lpi * x->cpi; + this->horiz = x->lpi; + this->vert = x->cpi; + this->width = x->w * this->horiz; + this->length = x->l * this->vert; + + if (ls_null_p (&x->ops[OPS_FORMFEED])) + ls_create (ascii_pool, &x->ops[OPS_FORMFEED], "\f"); + if (ls_null_p (&x->ops[OPS_NEWLINE]) + || !strcmp (ls_value (&x->ops[OPS_NEWLINE]), "default")) + { + ls_create (ascii_pool, &x->ops[OPS_NEWLINE], "\n"); + x->file.mode = "wt"; + } + + { + int i; + + for (i = 0; i < LNS_COUNT; i++) + { + char c[2]; + c[1] = 0; + if (!ls_null_p (&x->box[i])) + continue; + switch (i) + { + case TAYSTE2BYTE (0, 0, 0, 0): + c[0] = ' '; + break; + + case TAYSTE2BYTE (0, 1, 0, 0): + case TAYSTE2BYTE (0, 1, 0, 1): + case TAYSTE2BYTE (0, 0, 0, 1): + c[0] = '-'; + break; + + case TAYSTE2BYTE (1, 0, 0, 0): + case TAYSTE2BYTE (1, 0, 1, 0): + case TAYSTE2BYTE (0, 0, 1, 0): + c[0] = '|'; + break; + + case TAYSTE2BYTE (0, 3, 0, 0): + case TAYSTE2BYTE (0, 3, 0, 3): + case TAYSTE2BYTE (0, 0, 0, 3): + case TAYSTE2BYTE (0, 2, 0, 0): + case TAYSTE2BYTE (0, 2, 0, 2): + case TAYSTE2BYTE (0, 0, 0, 2): + c[0] = '='; + break; + + case TAYSTE2BYTE (3, 0, 0, 0): + case TAYSTE2BYTE (3, 0, 3, 0): + case TAYSTE2BYTE (0, 0, 3, 0): + case TAYSTE2BYTE (2, 0, 0, 0): + case TAYSTE2BYTE (2, 0, 2, 0): + case TAYSTE2BYTE (0, 0, 2, 0): + c[0] = '#'; + break; + + default: + if (BYTE2TAYSTE (i, LNS_LEFT) > 1 + || BYTE2TAYSTE (i, LNS_TOP) > 1 + || BYTE2TAYSTE (i, LNS_RIGHT) > 1 + || BYTE2TAYSTE (i, LNS_BOTTOM) > 1) + c[0] = '#'; + else + c[0] = '+'; + break; + } + ls_create (ascii_pool, &x->box[i], c); + } + } + + { + int i; + + this->cp_x = this->cp_y = 0; + this->font_height = this->vert; + this->prop_em_width = this->horiz; + this->fixed_width = this->horiz; + + this->horiz_line_width[0] = 0; + this->vert_line_width[0] = 0; + + for (i = 1; i < OUTP_L_COUNT; i++) + { + this->horiz_line_width[i] = this->vert; + this->vert_line_width[i] = this->horiz; + } + + for (i = 0; i < (1 << OUTP_L_COUNT); i++) + { + this->horiz_line_spacing[i] = (i & ~1) ? this->vert : 0; + this->vert_line_spacing[i] = (i & ~1) ? this->horiz : 0; + } + } + + this->driver_open = 1; + msg (VM (2), _("%s: Initialization complete."), this->name); + + return 1; +} + +int +ascii_close_driver (struct outp_driver *this) +{ + struct ascii_driver_ext *x = this->ext; + + assert (this->driver_open == 1); + msg (VM (2), _("%s: Beginning closing..."), this->name); + + x = this->ext; + free (x->page); + free (x->line_len); + fn_close_ext (&x->file); + free (x->file.filename); + free (x); + + this->driver_open = 0; + msg (VM (3), _("%s: Finished closing."), this->name); + + return 1; +} + +/* Generic option types. */ +enum + { + pos_int_arg = -10, + nonneg_int_arg, + string_arg, + font_string_arg, + boolean_arg + }; + +static struct outp_option option_tab[] = + { + {"headers", boolean_arg, 0}, + {"output-file", 1, 0}, + {"char-set", 2, 0}, + {"length", pos_int_arg, 0}, + {"width", pos_int_arg, 1}, + {"lpi", pos_int_arg, 2}, + {"cpi", pos_int_arg, 3}, + {"init", string_arg, 0}, + {"done", string_arg, 1}, + {"left-margin", nonneg_int_arg, 0}, + {"right-margin", nonneg_int_arg, 1}, + {"top-margin", nonneg_int_arg, 2}, + {"bottom-margin", nonneg_int_arg, 3}, + {"paginate", boolean_arg, 1}, + {"form-feed-string", string_arg, 2}, + {"newline-string", string_arg, 3}, + {"italic-on", font_string_arg, 0}, + {"italic-off", font_string_arg, 1}, + {"bold-on", font_string_arg, 2}, + {"bold-off", font_string_arg, 3}, + {"bold-italic-on", font_string_arg, 4}, + {"bold-italic-off", font_string_arg, 5}, + {"overstrike-style", 3, 0}, + {"tab-width", nonneg_int_arg, 4}, + {"carriage-return-style", 4, 0}, + {"", 0, 0}, + }; +static struct outp_option_info option_info; + +void +ascii_option (struct outp_driver *this, const char *key, + const struct string *val) +{ + struct ascii_driver_ext *x = this->ext; + int cat, subcat; + const char *value; + + value = ds_value (val); + if (!strncmp (key, "box[", 4)) + { + char *tail; + int indx = strtol (&key[4], &tail, 4); + if (*tail != ']' || indx < 0 || indx > LNS_COUNT) + { + msg (SE, _("Bad index value for `box' key: syntax is box[INDEX], " + "0 <= INDEX < %d decimal, with INDEX expressed in base 4."), + LNS_COUNT); + return; + } + if (!ls_null_p (&x->box[indx])) + msg (SW, _("Duplicate value for key `%s'."), key); + ls_create (ascii_pool, &x->box[indx], value); + return; + } + + cat = outp_match_keyword (key, option_tab, &option_info, &subcat); + + switch (cat) + { + case 0: + msg (SE, _("Unknown configuration parameter `%s' for ascii device driver."), + key); + break; + case 1: + free (x->file.filename); + x->file.filename = xstrdup (value); + break; + case 2: + if (!strcmp (value, "ascii")) + x->char_set = CHS_ASCII; + else if (!strcmp (value, "latin1")) + x->char_set = CHS_LATIN1; + else + msg (SE, _("Unknown character set `%s'. Valid character sets are " + "`ascii' and `latin1'."), value); + break; + case 3: + if (!strcmp (value, "single")) + x->overstrike_style = OVS_SINGLE; + else if (!strcmp (value, "line")) + x->overstrike_style = OVS_LINE; + else + msg (SE, _("Unknown overstrike style `%s'. Valid overstrike styles " + "are `single' and `line'."), value); + break; + case 4: + if (!strcmp (value, "bs")) + x->carriage_return_style = CRS_BS; + else if (!strcmp (value, "cr")) + x->carriage_return_style = CRS_CR; + else + msg (SE, _("Unknown carriage return style `%s'. Valid carriage " + "return styles are `cr' and `bs'."), value); + break; + case pos_int_arg: + { + char *tail; + int arg; + + errno = 0; + arg = strtol (value, &tail, 0); + if (arg < 1 || errno == ERANGE || *tail) + { + msg (SE, _("Positive integer required as value for `%s'."), key); + break; + } + switch (subcat) + { + case 0: + x->page_length = arg; + break; + case 1: + x->page_width = arg; + break; + case 2: + x->lpi = arg; + break; + case 3: + x->cpi = arg; + break; + default: + assert (0); + } + } + break; + case nonneg_int_arg: + { + char *tail; + int arg; + + errno = 0; + arg = strtol (value, &tail, 0); + if (arg < 0 || errno == ERANGE || *tail) + { + msg (SE, _("Zero or positive integer required as value for `%s'."), + key); + break; + } + switch (subcat) + { + case 0: + x->left_margin = arg; + break; + case 1: + x->right_margin = arg; + break; + case 2: + x->top_margin = arg; + break; + case 3: + x->bottom_margin = arg; + break; + case 4: + x->tab_width = arg; + break; + default: + assert (0); + } + } + break; + case string_arg: + { + struct len_string *s; + switch (subcat) + { + case 0: + s = &x->ops[OPS_INIT]; + break; + case 1: + s = &x->ops[OPS_DONE]; + break; + case 2: + s = &x->ops[OPS_FORMFEED]; + break; + case 3: + s = &x->ops[OPS_NEWLINE]; + break; + default: + assert (0); + } + ls_create (ascii_pool, s, value); + } + break; + case font_string_arg: + { + if (!strcmp (value, "overstrike")) + { + ls_destroy (ascii_pool, &x->fonts[subcat]); + return; + } + ls_create (ascii_pool, &x->fonts[subcat], value); + } + break; + case boolean_arg: + { + int setting; + if (!strcmp (value, "on") || !strcmp (value, "true") + || !strcmp (value, "yes") || atoi (value)) + setting = 1; + else if (!strcmp (value, "off") || !strcmp (value, "false") + || !strcmp (value, "no") || !strcmp (value, "0")) + setting = 0; + else + { + msg (SE, _("Boolean value expected for %s."), key); + return; + } + switch (subcat) + { + case 0: + x->headers = 0; + break; + case 1: + x->paginate = setting; + break; + default: + assert (0); + } + } + break; + default: + assert (0); + } +} + +int +postopen (struct file_ext *f) +{ + struct ascii_driver_ext *x = f->param; + struct len_string *s = &x->ops[OPS_INIT]; + + if (!ls_empty_p (s) && fwrite (ls_value (s), ls_length (s), 1, f->file) < 1) + { + msg (ME, _("ASCII output driver: %s: %s"), + f->filename, strerror (errno)); + return 0; + } + return 1; +} + +int +preclose (struct file_ext *f) +{ + struct ascii_driver_ext *x = f->param; + struct len_string *d = &x->ops[OPS_DONE]; + + if (!ls_empty_p (d) && fwrite (ls_value (d), ls_length (d), 1, f->file) < 1) + { + msg (ME, _("ASCII output driver: %s: %s"), + f->filename, strerror (errno)); + return 0; + } + return 1; +} + +int +ascii_open_page (struct outp_driver *this) +{ + struct ascii_driver_ext *x = this->ext; + int req_page_size; + + assert (this->driver_open && !this->page_open); + x->page_number++; + if (!fn_open_ext (&x->file)) + { + msg (ME, _("ASCII output driver: %s: %s"), x->file.filename, + strerror (errno)); + return 0; + } + + req_page_size = x->w * x->l; + if (req_page_size > x->page_size || req_page_size / 2 < x->page_size) + { + x->page_size = req_page_size; + x->page = xrealloc (x->page, sizeof *x->page * req_page_size); + } + + if (x->l > x->line_len_size) + { + x->line_len_size = x->l; + x->line_len = xrealloc (x->line_len, + sizeof *x->line_len * x->line_len_size); + } + + memset (x->line_len, 0, sizeof *x->line_len * x->l); + + this->page_open = 1; + return 1; +} + +/* Ensures that at least the first L characters of line I in the + driver identified by struct ascii_driver_ext *X have been cleared out. */ +static inline void +expand_line (struct ascii_driver_ext *x, int i, int l) +{ + int limit = i * x->w + l; + int j; + + for (j = i * x->w + x->line_len[i]; j < limit; j++) + x->page[j] = ' '; + x->line_len[i] = l; +} + +/* Puts line L at (H,K) in the current output page. Assumes + struct ascii_driver_ext named `ext'. */ +#define draw_line(H, K, L) \ + ext->page[ext->w * (K) + (H)] = (L) | 0x800 + +/* Line styles for each position. */ +#define T(STYLE) (STYLE<ext; + int x1 = r->x1 / this->horiz; + int x2 = r->x2 / this->horiz; + int y1 = r->y1 / this->vert; + int x; + + assert (this->driver_open && this->page_open); + if (x1 == x2) + return; +#if GLOBAL_DEBUGGING + if (x1 > x2 + || x1 < 0 || x1 >= ext->w + || x2 <= 0 || x2 > ext->w + || y1 < 0 || y1 >= ext->l) + { +#if !SUPPRESS_WARNINGS + printf (_("ascii_line_horz: bad hline (%d,%d),%d out of (%d,%d)\n"), + x1, x2, y1, ext->w, ext->l); +#endif + return; + } +#endif + + if (ext->line_len[y1] < x2) + expand_line (ext, y1, x2); + + for (x = x1; x < x2; x++) + draw_line (x, y1, (style << LNS_LEFT) | (style << LNS_RIGHT)); +} + +void +ascii_line_vert (struct outp_driver *this, const struct rect *r, + const struct color *c unused, int style) +{ + struct ascii_driver_ext *ext = this->ext; + int x1 = r->x1 / this->horiz; + int y1 = r->y1 / this->vert; + int y2 = r->y2 / this->vert; + int y; + + assert (this->driver_open && this->page_open); + if (y1 == y2) + return; +#if GLOBAL_DEBUGGING + if (y1 > y2 + || x1 < 0 || x1 >= ext->w + || y1 < 0 || y1 >= ext->l + || y2 < 0 || y2 > ext->l) + { +#if !SUPPRESS_WARNINGS + printf (_("ascii_line_vert: bad vline %d,(%d,%d) out of (%d,%d)\n"), + x1, y1, y2, ext->w, ext->l); +#endif + return; + } +#endif + + for (y = y1; y < y2; y++) + if (ext->line_len[y] <= x1) + expand_line (ext, y, x1 + 1); + + for (y = y1; y < y2; y++) + draw_line (x1, y, (style << LNS_TOP) | (style << LNS_BOTTOM)); +} + +void +ascii_line_intersection (struct outp_driver *this, const struct rect *r, + const struct color *c unused, + const struct outp_styles *style) +{ + struct ascii_driver_ext *ext = this->ext; + int x = r->x1 / this->horiz; + int y = r->y1 / this->vert; + int l; + + assert (this->driver_open && this->page_open); +#if GLOBAL_DEBUGGING + if (x < 0 || x >= ext->w || y < 0 || y >= ext->l) + { +#if !SUPPRESS_WARNINGS + printf (_("ascii_line_intersection: bad intsct (%d,%d) out of (%d,%d)\n"), + x, y, ext->w, ext->l); +#endif + return; + } +#endif + + l = ((style->l << LNS_LEFT) | (style->r << LNS_RIGHT) + | (style->t << LNS_TOP) | (style->b << LNS_BOTTOM)); + + if (ext->line_len[y] <= x) + expand_line (ext, y, x + 1); + draw_line (x, y, l); +} + +void +ascii_line_width (struct outp_driver *this, int *width, int *height) +{ + int i; + + assert (this->driver_open && this->page_open); + width[0] = height[0] = 0; + for (i = 1; i < OUTP_L_COUNT; i++) + { + width[i] = this->horiz; + height[i] = this->vert; + } +} + +/* FIXME: Later we could set this up so that for certain devices it + performs shading? */ +void +ascii_box (struct outp_driver *this unused, const struct rect *r unused, + const struct color *bord unused, const struct color *fill unused) +{ + assert (this->driver_open && this->page_open); +} + +/* Polylines not supported. */ +void +ascii_polyline_begin (struct outp_driver *this unused, const struct color *c unused) +{ + assert (this->driver_open && this->page_open); +} +void +ascii_polyline_point (struct outp_driver *this unused, int x unused, int y unused) +{ + assert (this->driver_open && this->page_open); +} +void +ascii_polyline_end (struct outp_driver *this unused) +{ + assert (this->driver_open && this->page_open); +} + +void +ascii_text_set_font_by_name (struct outp_driver * this, const char *s) +{ + struct ascii_driver_ext *x = this->ext; + int len = strlen (s); + + assert (this->driver_open && this->page_open); + x->cur_font = OUTP_F_R; + if (len == 0) + return; + if (s[len - 1] == 'I') + { + if (len > 1 && s[len - 2] == 'B') + x->cur_font = OUTP_F_BI; + else + x->cur_font = OUTP_F_I; + } + else if (s[len - 1] == 'B') + x->cur_font = OUTP_F_B; +} + +void +ascii_text_set_font_by_position (struct outp_driver *this, int pos) +{ + struct ascii_driver_ext *x = this->ext; + assert (this->driver_open && this->page_open); + x->cur_font = pos >= 0 && pos < 4 ? pos : 0; +} + +void +ascii_text_set_font_by_family (struct outp_driver *this unused, const char *s unused) +{ + assert (this->driver_open && this->page_open); +} + +const char * +ascii_text_get_font_name (struct outp_driver *this) +{ + struct ascii_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + switch (x->cur_font) + { + case OUTP_F_R: + return "R"; + case OUTP_F_I: + return "I"; + case OUTP_F_B: + return "B"; + case OUTP_F_BI: + return "BI"; + default: + assert (0); + } + abort (); +} + +const char * +ascii_text_get_font_family (struct outp_driver *this unused) +{ + assert (this->driver_open && this->page_open); + return ""; +} + +int +ascii_text_set_size (struct outp_driver *this, int size) +{ + assert (this->driver_open && this->page_open); + return size == this->vert; +} + +int +ascii_text_get_size (struct outp_driver *this, int *em_width) +{ + assert (this->driver_open && this->page_open); + if (em_width) + *em_width = this->horiz; + return this->vert; +} + +static void text_draw (struct outp_driver *this, struct outp_text *t); + +/* Divides the text T->S into lines of width T->H. Sets T->V to the + number of lines necessary. Actually draws the text if DRAW is + nonzero. + + You probably don't want to look at this code. */ +static void +delineate (struct outp_driver *this, struct outp_text *t, int draw) +{ + /* Width we're fitting everything into. */ + int width = t->h / this->horiz; + + /* Maximum `y' position we can write to. */ + int max_y; + + /* Current position in string, character following end of string. */ + const char *s = ls_value (&t->s); + const char *end = ls_end (&t->s); + + /* Temporary struct outp_text to pass to low-level function. */ + struct outp_text temp; + +#if GLOBAL_DEBUGGING && 0 + if (!ext->debug) + { + ext->debug = 1; + printf (_("%s: horiz=%d, vert=%d\n"), this->name, this->horiz, this->vert); + } +#endif + + if (!width) + { + t->h = t->v = 0; + return; + } + + if (draw) + { + temp.options = t->options; + ls_shallow_copy (&temp.s, &t->s); + temp.h = t->h / this->horiz; + temp.x = t->x / this->horiz; + } + else + t->y = 0; + temp.y = t->y / this->vert; + + if (t->options & OUTP_T_VERT) + max_y = (t->v / this->vert) + temp.y - 1; + else + max_y = INT_MAX; + + while (end - s > width) + { + const char *beg = s; + const char *space; + + /* Find first space before &s[width]. */ + space = &s[width]; + for (;;) + { + if (space > s) + { + if (!isspace ((unsigned char) space[-1])) + { + space--; + continue; + } + else + s = space; + } + else + s = space = &s[width]; + break; + } + + /* Draw text. */ + if (draw) + { + ls_init (&temp.s, beg, space - beg); + temp.w = space - beg; + text_draw (this, &temp); + } + if (++temp.y > max_y) + return; + + /* Find first nonspace after space. */ + while (s < end && isspace ((unsigned char) *s)) + s++; + } + if (s < end) + { + if (draw) + { + ls_init (&temp.s, s, end - s); + temp.w = end - s; + text_draw (this, &temp); + } + temp.y++; + } + + t->v = (temp.y * this->vert) - t->y; +} + +void +ascii_text_metrics (struct outp_driver *this, struct outp_text *t) +{ + assert (this->driver_open && this->page_open); + if (!(t->options & OUTP_T_HORZ)) + { + t->v = this->vert; + t->h = ls_length (&t->s) * this->horiz; + } + else + delineate (this, t, 0); +} + +void +ascii_text_draw (struct outp_driver *this, struct outp_text *t) +{ + /* FIXME: orientations not supported. */ + assert (this->driver_open && this->page_open); + if (!(t->options & OUTP_T_HORZ)) + { + struct outp_text temp; + + temp.options = t->options; + temp.s = t->s; + temp.h = temp.v = 0; + temp.x = t->x / this->horiz; + temp.y = t->y / this->vert; + text_draw (this, &temp); + ascii_text_metrics (this, t); + + return; + } + delineate (this, t, 1); +} + +static void +text_draw (struct outp_driver *this, struct outp_text *t) +{ + struct ascii_driver_ext *ext = this->ext; + unsigned attr = ext->cur_font << 8; + + int x = t->x; + int y = t->y * ext->w; + + char *s = ls_value (&t->s); + + /* Expand the line with the assumption that S takes up LEN character + spaces (sometimes it takes up less). */ + int min_len; + + assert (this->driver_open && this->page_open); + switch (t->options & OUTP_T_JUST_MASK) + { + case OUTP_T_JUST_LEFT: + break; + case OUTP_T_JUST_CENTER: + x -= (t->h - t->w) / 2; /* fall through */ + case OUTP_T_JUST_RIGHT: + x += (t->h - t->w); + break; + default: + assert (0); + } + + if (!(t->y < ext->l && x < ext->w)) + return; + min_len = min (x + ls_length (&t->s), ext->w); + if (ext->line_len[t->y] < min_len) + expand_line (ext, t->y, min_len); + + { + int len = ls_length (&t->s); + + if (len + x > ext->w) + len = ext->w - x; + while (len--) + ext->page[y + x++] = *s++ | attr; + } +} + +/* ascii_close_page () and support routines. */ + +#define LINE_BUF_SIZE 1024 +static unsigned char *line_buf; +static unsigned char *line_p; + +static inline int +commit_line_buf (struct outp_driver *this) +{ + struct ascii_driver_ext *x = this->ext; + + if ((int) fwrite (line_buf, 1, line_p - line_buf, x->file.file) + < line_p - line_buf) + { + msg (ME, _("Writing `%s': %s"), x->file.filename, strerror (errno)); + return 0; + } + + line_p = line_buf; + return 1; +} + +/* Writes everything from BP to EP exclusive into line_buf, or to + THIS->output if line_buf overflows. */ +static inline void +output_string (struct outp_driver *this, const char *bp, const char *ep) +{ + if (LINE_BUF_SIZE - (line_p - line_buf) >= ep - bp) + { + memcpy (line_p, bp, ep - bp); + line_p += ep - bp; + } + else + while (bp < ep) + { + if (LINE_BUF_SIZE - (line_p - line_buf) <= 1 && !commit_line_buf (this)) + return; + *line_p++ = *bp++; + } +} + +/* Writes everything from BP to EP exclusive into line_buf, or to + THIS->output if line_buf overflows. Returns 1 if additional passes + over the line are required. FIXME: probably could do a lot of + optimization here. */ +static inline int +output_shorts (struct outp_driver *this, + const unsigned short *bp, const unsigned short *ep) +{ + struct ascii_driver_ext *ext = this->ext; + size_t remaining = LINE_BUF_SIZE - (line_p - line_buf); + int result = 0; + + for (; bp < ep; bp++) + { + if (*bp & 0x800) + { + struct len_string *box = &ext->box[*bp & 0xff]; + size_t len = ls_length (box); + + if (remaining >= len) + { + memcpy (line_p, ls_value (box), len); + line_p += len; + remaining -= len; + } + else + { + if (!commit_line_buf (this)) + return 0; + output_string (this, ls_value (box), ls_end (box)); + remaining = LINE_BUF_SIZE - (line_p - line_buf); + } + } + else if (*bp & 0x0300) + { + struct len_string *on; + char buf[5]; + int len; + + switch (*bp & 0x0300) + { + case OUTP_F_I << 8: + on = &ext->fonts[FSTY_ON | FSTY_ITALIC]; + break; + case OUTP_F_B << 8: + on = &ext->fonts[FSTY_ON | FSTY_BOLD]; + break; + case OUTP_F_BI << 8: + on = &ext->fonts[FSTY_ON | FSTY_BOLD_ITALIC]; + break; + default: + assert (0); + } + if (!on) + { + if (ext->overstrike_style == OVS_SINGLE) + switch (*bp & 0x0300) + { + case OUTP_F_I << 8: + buf[0] = '_'; + buf[1] = '\b'; + buf[2] = *bp; + len = 3; + break; + case OUTP_F_B << 8: + buf[0] = *bp; + buf[1] = '\b'; + buf[2] = *bp; + len = 3; + break; + case OUTP_F_BI << 8: + buf[0] = '_'; + buf[1] = '\b'; + buf[2] = *bp; + buf[3] = '\b'; + buf[4] = *bp; + len = 5; + break; + default: + assert (0); + } + else + { + buf[0] = *bp; + result = len = 1; + } + } + else + { + buf[0] = *bp; + len = 1; + } + output_string (this, buf, &buf[len]); + } + else if (remaining) + { + *line_p++ = *bp; + remaining--; + } + else + { + if (!commit_line_buf (this)) + return 0; + remaining = LINE_BUF_SIZE - (line_p - line_buf); + *line_p++ = *bp; + } + } + + return result; +} + +/* Writes CH into line_buf N times, or to THIS->output if line_buf + overflows. */ +static inline void +output_char (struct outp_driver *this, int n, int ch) +{ + if (LINE_BUF_SIZE - (line_p - line_buf) >= n) + { + memset (line_p, ch, n); + line_p += n; + } + else + while (n--) + { + if (LINE_BUF_SIZE - (line_p - line_buf) <= 1 && !commit_line_buf (this)) + return; + *line_p++ = ch; + } +} + +/* Advance the carriage from column 0 to the left margin. */ +static void +advance_to_left_margin (struct outp_driver *this) +{ + struct ascii_driver_ext *ext = this->ext; + int margin; + + margin = ext->left_margin; + if (margin == 0) + return; + if (ext->tab_width && margin >= ext->tab_width) + { + output_char (this, margin / ext->tab_width, '\t'); + margin %= ext->tab_width; + } + if (margin) + output_char (this, margin, ' '); +} + +/* Move the output file carriage N_CHARS left, to the left margin. */ +static void +return_carriage (struct outp_driver *this, int n_chars) +{ + struct ascii_driver_ext *ext = this->ext; + + switch (ext->carriage_return_style) + { + case CRS_BS: + output_char (this, n_chars, '\b'); + break; + case CRS_CR: + output_char (this, 1, '\r'); + advance_to_left_margin (this); + break; + default: + assert (0); + } +} + +/* Writes COUNT lines from the line buffer in THIS, starting at line + number FIRST. */ +static void +output_lines (struct outp_driver *this, int first, int count) +{ + struct ascii_driver_ext *ext = this->ext; + + unsigned short *p = &ext->page[ext->w * first]; + int *len = &ext->line_len[first]; + struct len_string *newline = &ext->ops[OPS_NEWLINE]; + + int n_chars; + int n_passes; + + if (NULL == ext->file.file) + return; + + while (count--) /* Iterate over all the lines to be output. */ + { + unsigned short *end_p; + unsigned short *bp, *ep; + unsigned short attr = 0; + + end_p = p + *len++; + assert (end_p >= p); + + /* Output every character in the line in the appropriate + manner. */ + n_passes = 1; + bp = ep = p; + n_chars = 0; + advance_to_left_margin (this); + for (;;) + { + while (ep < end_p && attr == (*ep & 0x0300)) + ep++; + if (output_shorts (this, bp, ep)) + n_passes = 2; + n_chars += ep - bp; + bp = ep; + + if (bp >= end_p) + break; + + /* Turn off old font. */ + if (attr != (OUTP_F_R << 8)) + { + struct len_string *off; + + switch (attr) + { + case OUTP_F_I << 8: + off = &ext->fonts[FSTY_OFF | FSTY_ITALIC]; + break; + case OUTP_F_B << 8: + off = &ext->fonts[FSTY_OFF | FSTY_BOLD]; + break; + case OUTP_F_BI << 8: + off = &ext->fonts[FSTY_OFF | FSTY_BOLD_ITALIC]; + break; + default: + assert (0); + } + if (off) + output_string (this, ls_value (off), ls_end (off)); + } + + /* Turn on new font. */ + attr = (*bp & 0x0300); + if (attr != (OUTP_F_R << 8)) + { + struct len_string *on; + + switch (attr) + { + case OUTP_F_I << 8: + on = &ext->fonts[FSTY_ON | FSTY_ITALIC]; + break; + case OUTP_F_B << 8: + on = &ext->fonts[FSTY_ON | FSTY_BOLD]; + break; + case OUTP_F_BI << 8: + on = &ext->fonts[FSTY_ON | FSTY_BOLD_ITALIC]; + break; + default: + assert (0); + } + if (on) + output_string (this, ls_value (on), ls_end (on)); + } + + ep = bp + 1; + } + if (n_passes > 1) + { + unsigned char ch; + + return_carriage (this, n_chars); + n_chars = 0; + bp = ep = p; + for (;;) + { + while (ep < end_p && (*ep & 0x0300) == (OUTP_F_R << 8)) + ep++; + if (ep >= end_p) + break; + output_char (this, ep - bp, ' '); + + switch (*ep & 0x0300) + { + case OUTP_F_I << 8: + ch = '_'; + break; + case OUTP_F_B << 8: + ch = *ep; + break; + case OUTP_F_BI << 8: + ch = *ep; + n_passes = 3; + break; + } + output_char (this, 1, ch); + n_chars += ep - bp + 1; + bp = ep + 1; + ep = bp; + } + } + if (n_passes > 2) + { + return_carriage (this, n_chars); + bp = ep = p; + for (;;) + { + while (ep < end_p && (*ep & 0x0300) != (OUTP_F_BI << 8)) + ep++; + if (ep >= end_p) + break; + output_char (this, ep - bp, ' '); + output_char (this, 1, '_'); + bp = ep + 1; + ep = bp; + } + } + p += ext->w; + + output_string (this, ls_value (newline), ls_end (newline)); + } +} + +int +ascii_close_page (struct outp_driver *this) +{ + static unsigned char *s; + static int s_len; + + struct ascii_driver_ext *x = this->ext; + int nl_len, ff_len, total_len; + unsigned char *cp; + int i; + + assert (this->driver_open && this->page_open); + + if (!line_buf) + line_buf = xmalloc (LINE_BUF_SIZE); + line_p = line_buf; + + nl_len = ls_length (&x->ops[OPS_NEWLINE]); + if (x->top_margin) + { + total_len = x->top_margin * nl_len; + if (s_len < total_len) + { + s_len = total_len; + s = xrealloc (s, s_len); + } + for (cp = s, i = 0; i < x->top_margin; i++) + { + memcpy (cp, ls_value (&x->ops[OPS_NEWLINE]), nl_len); + cp += nl_len; + } + output_string (this, s, &s[total_len]); + } + if (x->headers) + { + int len; + + total_len = nl_len + x->w; + if (s_len < total_len + 1) + { + s_len = total_len + 1; + s = xrealloc (s, s_len); + } + + memset (s, ' ', x->w); + + { + char temp[40]; + + snprintf (temp, 80, _("%s - Page %d"), curdate, x->page_number); + memcpy (&s[x->w - strlen (temp)], temp, strlen (temp)); + } + + if (outp_title && outp_subtitle) + { + len = min ((int) strlen (outp_title), x->w); + memcpy (s, outp_title, len); + } + memcpy (&s[x->w], ls_value (&x->ops[OPS_NEWLINE]), nl_len); + output_string (this, s, &s[total_len]); + + memset (s, ' ', x->w); + len = strlen (version) + 3 + strlen (host_system); + if (len < x->w) + sprintf (&s[x->w - len], "%s - %s" , version, host_system); + if (outp_subtitle || outp_title) + { + char *string = outp_subtitle ? outp_subtitle : outp_title; + len = min ((int) strlen (string), x->w); + memcpy (s, string, len); + } + memcpy (&s[x->w], ls_value (&x->ops[OPS_NEWLINE]), nl_len); + output_string (this, s, &s[total_len]); + output_string (this, &s[x->w], &s[total_len]); + } + if (line_p != line_buf && !commit_line_buf (this)) + return 0; + + output_lines (this, x->n_output, x->l - x->n_output); + + ff_len = ls_length (&x->ops[OPS_FORMFEED]); + total_len = x->bottom_margin * nl_len + ff_len; + if (s_len < total_len) + s = xrealloc (s, total_len); + for (cp = s, i = 0; i < x->bottom_margin; i++) + { + memcpy (cp, ls_value (&x->ops[OPS_NEWLINE]), nl_len); + cp += nl_len; + } + memcpy (cp, ls_value (&x->ops[OPS_FORMFEED]), ff_len); + output_string (this, s, &s[total_len]); + if (line_p != line_buf && !commit_line_buf (this)) + return 0; + + x->n_output = 0; + + this->page_open = 0; + return 1; +} + +struct outp_class ascii_class = +{ + "ascii", + 0, + 0, + + ascii_open_global, + ascii_close_global, + ascii_font_sizes, + + ascii_preopen_driver, + ascii_option, + ascii_postopen_driver, + ascii_close_driver, + + ascii_open_page, + ascii_close_page, + + NULL, + + ascii_line_horz, + ascii_line_vert, + ascii_line_intersection, + + ascii_box, + ascii_polyline_begin, + ascii_polyline_point, + ascii_polyline_end, + + ascii_text_set_font_by_name, + ascii_text_set_font_by_position, + ascii_text_set_font_by_family, + ascii_text_get_font_name, + ascii_text_get_font_family, + ascii_text_set_size, + ascii_text_get_size, + ascii_text_metrics, + ascii_text_draw, +}; diff --git a/src/autorecode.c b/src/autorecode.c new file mode 100644 index 00000000..5ae1e7f6 --- /dev/null +++ b/src/autorecode.c @@ -0,0 +1,342 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "hash.h" +#include "lexer.h" +#include "pool.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* FIXME: This module is less than ideally efficient, both in space + and time. If anyone cares, it would be a good project. */ + +/* FIXME: Implement PRINT subcommand. */ + +/* Explains how to recode one value. `from' must be first element. */ +struct arc_item + { + union value from; /* Original value. */ + double to; /* Recoded value. */ + }; + +/* Explains how to recode an AUTORECODE variable. */ +struct arc_spec + { + struct variable *src; /* Source variable. */ + struct variable *dest; /* Target variable. */ + struct hsh_table *items; /* Hash table of `freq's. */ + }; + +/* AUTORECODE transformation. */ +struct autorecode_trns + { + struct trns_header h; + struct pool *owner; /* Contains AUTORECODE specs. */ + struct arc_spec *arc; /* AUTORECODE specifications. */ + int n_arc; /* Number of specifications. */ + }; + +/* Source and target variables, hash table translator. */ +static struct variable **v_src; +static struct variable **v_dest; +static struct hsh_table **h_trans; +static int nv_src; + +/* Pool for allocation of hash table entries. */ +static struct pool *hash_pool; + +/* Options. */ +static int descend; +static int print; + +static int autorecode_trns_proc (struct trns_header *, struct ccase *); +static void autorecode_trns_free (struct trns_header *); +static int autorecode_proc_func (struct ccase *); +static int compare_alpha_value (const void *, const void *, void *); +static unsigned hash_alpha_value (const void *, void *); +static int compare_numeric_value (const void *, const void *, void *); +static unsigned hash_numeric_value (const void *, void *); +static void recode (void); + +/* Performs the AUTORECODE procedure. */ +int +cmd_autorecode (void) +{ + /* Dest var names. */ + char **n_dest = NULL; + int nv_dest = 0; + + int i; + + v_src = NULL; + descend = print = 0; + h_trans = NULL; + + lex_match_id ("AUTORECODE"); + lex_match_id ("VARIABLES"); + lex_match ('='); + if (!parse_variables (&default_dict, &v_src, &nv_src, PV_NO_DUPLICATE)) + return CMD_FAILURE; + if (!lex_force_match_id ("INTO")) + return CMD_FAILURE; + lex_match ('='); + if (!parse_DATA_LIST_vars (&n_dest, &nv_dest, PV_NONE)) + goto lossage; + if (nv_dest != nv_src) + { + msg (SE, _("Number of source variables (%d) does not match number " + "of target variables (%d)."), nv_src, nv_dest); + goto lossage; + } + while (lex_match ('/')) + if (lex_match_id ("DESCENDING")) + descend = 1; + else if (lex_match_id ("PRINT")) + print = 1; + if (token != '.') + { + lex_error (_("expecting end of command")); + goto lossage; + } + + for (i = 0; i < nv_dest; i++) + { + int j; + + if (is_varname (n_dest[i])) + { + msg (SE, _("Target variable %s duplicates existing variable %s."), + n_dest[i], n_dest[i]); + goto lossage; + } + for (j = 0; j < i; j++) + if (!strcmp (n_dest[i], n_dest[j])) + { + msg (SE, _("Duplicate variable name %s among target variables."), + n_dest[i]); + goto lossage; + } + } + + hash_pool = pool_create (); + + v_dest = xmalloc (sizeof *v_dest * nv_dest); + h_trans = xmalloc (sizeof *h_trans * nv_dest); + for (i = 0; i < nv_dest; i++) + if (v_src[i]->type == ALPHA) + h_trans[i] = hsh_create (10, compare_alpha_value, + hash_alpha_value, NULL, + (void *) v_src[i]->width); + else + h_trans[i] = hsh_create (10, compare_numeric_value, + hash_numeric_value, NULL, NULL); + + procedure (NULL, autorecode_proc_func, NULL); + + for (i = 0; i < nv_dest; i++) + { + v_dest[i] = force_create_variable (&default_dict, n_dest[i], NUMERIC, 0); + free (n_dest[i]); + } + free (n_dest); + + recode (); + + free (v_src); + free (v_dest); + + return CMD_SUCCESS; + +lossage: + if (h_trans != NULL) + for (i = 0; i < nv_src; i++) + hsh_destroy (h_trans[i]); + for (i = 0; i < nv_dest; i++) + free (n_dest[i]); + free (n_dest); + free (v_src); + return CMD_FAILURE; +} + +/* AUTORECODE transformation. */ + +static void +recode (void) +{ + struct autorecode_trns *t; + struct pool *arc_pool; + int i; + + arc_pool = pool_create (); + t = xmalloc (sizeof *t); + t->h.proc = autorecode_trns_proc; + t->h.free = autorecode_trns_free; + t->owner = arc_pool; + t->arc = pool_alloc (arc_pool, sizeof *t->arc * nv_src); + t->n_arc = nv_src; + for (i = 0; i < nv_src; i++) + { + struct arc_spec *spec = &t->arc[i]; + void **p = hsh_sort (h_trans[i], NULL); + int count = hsh_count (h_trans[i]); + int j; + + spec->src = v_src[i]; + spec->dest = v_dest[i]; + + if (v_src[i]->type == ALPHA) + spec->items = hsh_create (2 * count, compare_alpha_value, + hash_alpha_value, NULL, + (void *) v_src[i]->width); + else + spec->items = hsh_create (2 * count, compare_numeric_value, + hash_numeric_value, NULL, NULL); + + for (j = 0; *p; p++, j++) + { + struct arc_item *item = pool_alloc (arc_pool, sizeof *item); + + memcpy (&item->from, *p, sizeof (union value)); + if (v_src[i]->type == ALPHA) + item->from.c = pool_strdup (arc_pool, item->from.c); + item->to = !descend ? j + 1 : count - j; + force_hsh_insert (spec->items, item); + } + + hsh_destroy (h_trans[i]); + } + free (h_trans); + pool_destroy (hash_pool); + add_transformation ((struct trns_header *) t); +} + +static int +autorecode_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct autorecode_trns *t = (struct autorecode_trns *) trns; + int i; + + for (i = 0; i < t->n_arc; i++) + { + struct arc_spec *spec = &t->arc[i]; + struct arc_item *item; + + if (spec->src->type == NUMERIC) + item = force_hsh_find (spec->items, &c->data[spec->src->fv].f); + else + { + union value v; + v.c = c->data[spec->src->fv].s; + item = force_hsh_find (spec->items, &v); + } + + c->data[spec->dest->fv].f = item->to; + } + return -1; +} + +static void +autorecode_trns_free (struct trns_header * trns) +{ + struct autorecode_trns *t = (struct autorecode_trns *) trns; + int i; + + for (i = 0; i < t->n_arc; i++) + hsh_destroy (t->arc[i].items); + pool_destroy (t->owner); +} + +/* AUTORECODE procedure. */ + +static int +compare_alpha_value (const void *a, const void *b, void *len) +{ + return memcmp (((union value *) a)->c, ((union value *) b)->c, (int) len); +} + +static unsigned +hash_alpha_value (const void *a, void *len) +{ + return hashpjw_d (((union value *) a)->c, &((union value *) a)->c[(int) len]); +} + +static int +compare_numeric_value (const void *pa, const void *pb, void *foobar unused) +{ + double a = ((union value *) pa)->f, b = ((union value *) pb)->f; + return a > b ? 1 : (a < b ? -1 : 0); +} + +static unsigned +hash_numeric_value (const void *a, void *len unused) +{ + return hashpjw_d ((char *) &((union value *) a)->f, + (char *) &(&((union value *) a)->f)[1]); +} + +static int +autorecode_proc_func (struct ccase * c) +{ + int i; + + for (i = 0; i < nv_src; i++) + { + union value v; + union value *vp; + union value **vpp; + + if (v_src[i]->type == NUMERIC) + { + v.f = c->data[v_src[i]->fv].f; + vpp = (union value **) hsh_probe (h_trans[i], &v); + if (NULL == *vpp) + { + vp = pool_alloc (hash_pool, sizeof (union value)); + vp->f = v.f; + *vpp = vp; + } + } + else + { + v.c = c->data[v_src[i]->fv].s; + vpp = (union value **) hsh_probe (h_trans[i], &v); + if (NULL == *vpp) + { + vp = pool_alloc (hash_pool, sizeof (union value)); +#if __CHECKER__ + memset (vp, 0, sizeof (union value)); +#endif + vp->c = pool_strdup (hash_pool, v.c); + *vpp = vp; + } + } + } + return 1; +} diff --git a/src/avl.c b/src/avl.c new file mode 100644 index 00000000..75d9b2e7 --- /dev/null +++ b/src/avl.c @@ -0,0 +1,1122 @@ +/* libavl - manipulates AVL trees. + Copyright (C) 1998-9, 2000 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. + + The author may be contacted at on the + Internet, or as Ben Pfaff, 12167 Airport Rd, DeWitt MI 48820, USA + through more mundane means. */ + +/* This is file avl.c in libavl. */ + +#if HAVE_CONFIG_H +#include +#endif +#if PSPP +#include "pool.h" +#define HAVE_XMALLOC 1 +#endif +#if SELF_TEST +#include +#include +#endif +#include +#include +#include +#include "avl.h" + +#if !PSPP && !__GCC__ +#define inline +#endif + +#if !PSPP +#if __GNUC__ >= 2 +#define unused __attribute__ ((unused)) +#else +#define unused +#endif +#endif + +#ifdef HAVE_XMALLOC +void *xmalloc (size_t); +#else /* !HAVE_XMALLOC */ +/* Allocates SIZE bytes of space using malloc(). Aborts if out of + memory. */ +static void * +xmalloc (size_t size) +{ + void *vp; + + if (size == 0) + return NULL; + vp = malloc (size); + + assert (vp != NULL); + if (vp == NULL) + { + fprintf (stderr, "virtual memory exhausted\n"); + exit (EXIT_FAILURE); + } + return vp; +} +#endif /* !HAVE_XMALLOC */ + +/* Creates an AVL tree in POOL (which can be NULL). POOL is owned by + the caller, not by the AVL tree. CMP is a order function for the + data to be stored in the tree. PARAM is arbitrary data that + becomes an argument to the comparison function. */ +avl_tree * +avl_create (MAYBE_POOL avl_comparison_func cmp, void *param) +{ + avl_tree *tree; + + assert (cmp != NULL); +#if PSPP + if (pool) + tree = pool_alloc (pool, sizeof *tree); + else +#endif + tree = xmalloc (sizeof *tree); + +#if PSPP + tree->pool = pool; +#endif + tree->root.link[0] = NULL; + tree->root.link[1] = NULL; + tree->cmp = cmp; + tree->count = 0; + tree->param = param; + + return tree; +} + +/* Destroy tree TREE. Function FREE_FUNC is called for every node in + the tree as it is destroyed. + + No effect if the tree has an pool owner and free_func is NULL. + The caller owns the pool and must destroy it itself. + + Do not attempt to reuse the tree after it has been freed. Create a + new one. */ +void +avl_destroy (avl_tree *tree, avl_node_func free_func) +{ + assert (tree != NULL); + +#if PSPP + if (free_func || tree->pool == NULL) +#endif + { + /* Uses Knuth's Algorithm 2.3.1T as modified in exercise 13 + (postorder traversal). */ + + /* T1. */ + avl_node *an[AVL_MAX_HEIGHT]; /* Stack A: nodes. */ + char ab[AVL_MAX_HEIGHT]; /* Stack A: bits. */ + int ap = 0; /* Stack A: height. */ + avl_node *p = tree->root.link[0]; + + for (;;) + { + /* T2. */ + while (p != NULL) + { + /* T3. */ + ab[ap] = 0; + an[ap++] = p; + p = p->link[0]; + } + + /* T4. */ + for (;;) + { + if (ap == 0) + goto done; + + p = an[--ap]; + if (ab[ap] == 0) + { + ab[ap++] = 1; + p = p->link[1]; + break; + } + + if (free_func) + free_func (p->data, tree->param); +#if PSPP + if (tree->pool == NULL) +#endif + free (p); + } + } + } + + done: +#if PSPP + if (tree->pool == NULL) +#endif + free (tree); +} + +/* avl_destroy() with FREE_FUNC hardcoded as free(). */ +void +avl_free (avl_tree *tree) +{ + avl_destroy (tree, (avl_node_func) free); +} + +/* Return the number of nodes in TREE. */ +int +avl_count (const avl_tree *tree) +{ + assert (tree != NULL); + return tree->count; +} + +/* Allocates room for a new avl_node in POOL, or using xmalloc() if + POOL is NULL. */ +#if PSPP +static inline avl_node * +new_node (struct pool *pool) +{ + if (pool != NULL) + return pool_alloc (pool, sizeof (avl_node)); + else + return xmalloc (sizeof (avl_node)); +} +#else +static inline avl_node * +new_node (void) +{ + return xmalloc (sizeof (avl_node)); +} + +#define new_node(POOL) \ + new_node () +#endif + +/* Copy the contents of TREE to a new tree in POOL. If COPY is + non-NULL, then each data item is passed to function COPY, and the + return values are inserted into the new tree; otherwise, the items + are copied verbatim from the old tree to the new tree. Returns the + new tree. */ +avl_tree * +avl_copy (MAYBE_POOL const avl_tree *tree, avl_copy_func copy) +{ + /* This is a combination of Knuth's Algorithm 2.3.1C (copying a + binary tree) and Algorithm 2.3.1T as modified by exercise 12 + (preorder traversal). */ + + avl_tree *new_tree; + + /* PT1. */ + const avl_node *pa[AVL_MAX_HEIGHT]; /* Stack PA: nodes. */ + const avl_node **pp = pa; /* Stack PA: stack pointer. */ + const avl_node *p = &tree->root; + + /* QT1. */ + avl_node *qa[AVL_MAX_HEIGHT]; /* Stack QA: nodes. */ + avl_node **qp = qa; /* Stack QA: stack pointer. */ + avl_node *q; + + assert (tree != NULL); +#if PSPP + new_tree = avl_create (pool, tree->cmp, tree->param); +#else + new_tree = avl_create (tree->cmp, tree->param); +#endif + new_tree->count = tree->count; + q = &new_tree->root; + + for (;;) + { + /* C4. */ + if (p->link[0] != NULL) + { + avl_node *r = new_node (pool); + r->link[0] = r->link[1] = NULL; + q->link[0] = r; + } + + /* C5: Find preorder successors of P and Q. */ + goto start; + for (;;) + { + /* PT2. */ + while (p != NULL) + { + goto escape; + start: + /* PT3. */ + *pp++ = p; + *qp++ = q; + p = p->link[0]; + q = q->link[0]; + } + + /* PT4. */ + if (pp == pa) + { + assert (qp == qa); + return new_tree; + } + + p = *--pp; + q = *--qp; + + /* PT5. */ + p = p->link[1]; + q = q->link[1]; + } + escape: + + /* C2. */ + if (p->link[1]) + { + avl_node *r = new_node (pool); + r->link[0] = r->link[1] = NULL; + q->link[1] = r; + } + + /* C3. */ + q->bal = p->bal; + if (copy == NULL) + q->data = p->data; + else + q->data = copy (p->data, tree->param); + } +} + +/* Walk tree TREE in inorder, calling WALK_FUNC at each node. Passes + PARAM to WALK_FUNC. */ +void +avl_walk (const avl_tree *tree, avl_node_func walk_func, void *param) +{ + /* Uses Knuth's algorithm 2.3.1T (inorder traversal). */ + assert (tree && walk_func); + + { + /* T1. */ + const avl_node *an[AVL_MAX_HEIGHT]; /* Stack A: nodes. */ + const avl_node **ap = an; /* Stack A: stack pointer. */ + const avl_node *p = tree->root.link[0]; + + for (;;) + { + /* T2. */ + while (p != NULL) + { + /* T3. */ + *ap++ = p; + p = p->link[0]; + } + + /* T4. */ + if (ap == an) + return; + p = *--ap; + + /* T5. */ + walk_func (p->data, param); + p = p->link[1]; + } + } +} + +/* Each call to this function for a given TREE and TRAV return the + next item in the tree in inorder. Initialize the first element of + TRAV (init) to 0 before calling the first time. Returns NULL when + out of elements. */ +void * +avl_traverse (const avl_tree *tree, avl_traverser *trav) +{ + assert (tree && trav); + + /* Uses Knuth's algorithm 2.3.1T (inorder traversal). */ + if (trav->init == 0) + { + /* T1. */ + trav->init = 1; + trav->nstack = 0; + trav->p = tree->root.link[0]; + } + else + /* T5. */ + trav->p = trav->p->link[1]; + + for (;;) + { + /* T2. */ + while (trav->p != NULL) + { + /* T3. */ + trav->stack[trav->nstack++] = trav->p; + trav->p = trav->p->link[0]; + } + + /* T4. */ + if (trav->nstack == 0) + { + trav->init = 0; + return NULL; + } + trav->p = trav->stack[--trav->nstack]; + + /* T5. */ + return trav->p->data; + } +} + +/* Search TREE for an item matching ITEM. If found, returns a pointer + to the address of the item. If none is found, ITEM is inserted + into the tree, and a pointer to the address of ITEM is returned. + In either case, the pointer returned can be changed by the caller, + or the returned data item can be directly edited, but the key data + in the item must not be changed. */ +void ** +avl_probe (avl_tree *tree, void *item) +{ + /* Uses Knuth's Algorithm 6.2.3A (balanced tree search and + insertion), but caches results of comparisons. In empirical + tests this eliminates about 25% of the comparisons seen under + random insertions. */ + + /* A1. */ + avl_node *t; + avl_node *s, *p, *q, *r; + + assert (tree != NULL); + t = &tree->root; + s = p = t->link[0]; + + if (s == NULL) + { + tree->count++; + assert (tree->count == 1); + q = t->link[0] = new_node (tree->pool); + q->data = item; + q->link[0] = q->link[1] = NULL; + q->bal = 0; + return &q->data; + } + + for (;;) + { + /* A2. */ + int diff = tree->cmp (item, p->data, tree->param); + + /* A3. */ + if (diff < 0) + { + p->cache = 0; + q = p->link[0]; + if (q == NULL) + { + p->link[0] = q = new_node (tree->pool); + break; + } + } + /* A4. */ + else if (diff > 0) + { + p->cache = 1; + q = p->link[1]; + if (q == NULL) + { + p->link[1] = q = new_node (tree->pool); + break; + } + } + else + /* A2. */ + return &p->data; + + /* A3, A4. */ + if (q->bal != 0) + t = p, s = q; + p = q; + } + + /* A5. */ + tree->count++; + q->data = item; + q->link[0] = q->link[1] = NULL; + q->bal = 0; + + /* A6. */ + r = p = s->link[(int) s->cache]; + while (p != q) + { + p->bal = p->cache * 2 - 1; + p = p->link[(int) p->cache]; + } + + /* A7. */ + if (s->cache == 0) + { + /* a = -1. */ + if (s->bal == 0) + { + s->bal = -1; + return &q->data; + } + else if (s->bal == +1) + { + s->bal = 0; + return &q->data; + } + + assert (s->bal == -1); + if (r->bal == -1) + { + /* A8. */ + p = r; + s->link[0] = r->link[1]; + r->link[1] = s; + s->bal = r->bal = 0; + } + else + { + /* A9. */ + assert (r->bal == +1); + p = r->link[1]; + r->link[1] = p->link[0]; + p->link[0] = r; + s->link[0] = p->link[1]; + p->link[1] = s; + if (p->bal == -1) + s->bal = 1, r->bal = 0; + else if (p->bal == 0) + s->bal = r->bal = 0; + else + { + assert (p->bal == +1); + s->bal = 0, r->bal = -1; + } + p->bal = 0; + } + } + else + { + /* a == +1. */ + if (s->bal == 0) + { + s->bal = 1; + return &q->data; + } + else if (s->bal == -1) + { + s->bal = 0; + return &q->data; + } + + assert (s->bal == +1); + if (r->bal == +1) + { + /* A8. */ + p = r; + s->link[1] = r->link[0]; + r->link[0] = s; + s->bal = r->bal = 0; + } + else + { + /* A9. */ + assert (r->bal == -1); + p = r->link[0]; + r->link[0] = p->link[1]; + p->link[1] = r; + s->link[1] = p->link[0]; + p->link[0] = s; + if (p->bal == +1) + s->bal = -1, r->bal = 0; + else if (p->bal == 0) + s->bal = r->bal = 0; + else + { + assert (p->bal == -1); + s->bal = 0, r->bal = 1; + } + p->bal = 0; + } + } + + /* A10. */ + if (t != &tree->root && s == t->link[1]) + t->link[1] = p; + else + t->link[0] = p; + + return &q->data; +} + +/* Search TREE for an item matching ITEM, and return it if found. */ +void * +avl_find (const avl_tree *tree, const void *item) +{ + const avl_node *p; + + assert (tree != NULL); + for (p = tree->root.link[0]; p; ) + { + int diff = tree->cmp (item, p->data, tree->param); + + if (diff < 0) + p = p->link[0]; + else if (diff > 0) + p = p->link[1]; + else + return p->data; + } + + return NULL; +} + +/* Searches AVL tree TREE for an item matching ITEM. If found, the + item is removed from the tree and the actual item found is returned + to the caller. If no item matching ITEM exists in the tree, + returns NULL. */ +void * +avl_delete (avl_tree *tree, const void *item) +{ + /* Uses my Algorithm D, which can be found at + http://www.msu.edu/user/pfaffben/avl. Algorithm D is based on + Knuth's Algorithm 6.2.2D (Tree deletion) and 6.2.3A (Balanced + tree search and insertion), as well as the notes on pages 465-466 + of Vol. 3. */ + + /* D1. */ + avl_node *pa[AVL_MAX_HEIGHT]; /* Stack P: Nodes. */ + char a[AVL_MAX_HEIGHT]; /* Stack P: Bits. */ + int k = 1; /* Stack P: Pointer. */ + + avl_node **q; + avl_node *p; + + assert (tree != NULL); + + a[0] = 0; + pa[0] = &tree->root; + p = tree->root.link[0]; + for (;;) + { + /* D2. */ + int diff; + + if (p == NULL) + return NULL; + + diff = tree->cmp (item, p->data, tree->param); + if (diff == 0) + break; + + /* D3, D4. */ + pa[k] = p; + if (diff < 0) + { + p = p->link[0]; + a[k] = 0; + } + else if (diff > 0) + { + p = p->link[1]; + a[k] = 1; + } + k++; + } + tree->count--; + + item = p->data; + + /* D5. */ + q = &pa[k - 1]->link[(int) a[k - 1]]; + if (p->link[1] == NULL) + { + *q = p->link[0]; + if (*q) + (*q)->bal = 0; + } + else + { + /* D6. */ + avl_node *r = p->link[1]; + if (r->link[0] == NULL) + { + r->link[0] = p->link[0]; + *q = r; + r->bal = p->bal; + a[k] = 1; + pa[k++] = r; + } + else + { + /* D7. */ + avl_node *s = r->link[0]; + int l = k++; + + a[k] = 0; + pa[k++] = r; + + /* D8. */ + while (s->link[0] != NULL) + { + r = s; + s = r->link[0]; + a[k] = 0; + pa[k++] = r; + } + + /* D9. */ + a[l] = 1; + pa[l] = s; + s->link[0] = p->link[0]; + r->link[0] = s->link[1]; + s->link[1] = p->link[1]; + s->bal = p->bal; + *q = s; + } + } + +#if PSPP + if (tree->pool == NULL) +#endif + free (p); + + assert (k > 0); + /* D10. */ + while (--k) + { + avl_node *s = pa[k], *r; + + if (a[k] == 0) + { + /* D10. */ + if (s->bal == -1) + { + s->bal = 0; + continue; + } + else if (s->bal == 0) + { + s->bal = 1; + break; + } + + assert (s->bal == +1); + r = s->link[1]; + + assert (r != NULL); + if (r->bal == 0) + { + /* D11. */ + s->link[1] = r->link[0]; + r->link[0] = s; + r->bal = -1; + pa[k - 1]->link[(int) a[k - 1]] = r; + break; + } + else if (r->bal == +1) + { + /* D12. */ + s->link[1] = r->link[0]; + r->link[0] = s; + s->bal = r->bal = 0; + pa[k - 1]->link[(int) a[k - 1]] = r; + } + else + { + /* D13. */ + assert (r->bal == -1); + p = r->link[0]; + r->link[0] = p->link[1]; + p->link[1] = r; + s->link[1] = p->link[0]; + p->link[0] = s; + if (p->bal == +1) + s->bal = -1, r->bal = 0; + else if (p->bal == 0) + s->bal = r->bal = 0; + else + { + assert (p->bal == -1); + s->bal = 0, r->bal = +1; + } + p->bal = 0; + pa[k - 1]->link[(int) a[k - 1]] = p; + } + } + else + { + assert (a[k] == 1); + + /* D10. */ + if (s->bal == +1) + { + s->bal = 0; + continue; + } + else if (s->bal == 0) + { + s->bal = -1; + break; + } + + assert (s->bal == -1); + r = s->link[0]; + + if (r == NULL || r->bal == 0) + { + /* D11. */ + s->link[0] = r->link[1]; + r->link[1] = s; + r->bal = 1; + pa[k - 1]->link[(int) a[k - 1]] = r; + break; + } + else if (r->bal == -1) + { + /* D12. */ + s->link[0] = r->link[1]; + r->link[1] = s; + s->bal = r->bal = 0; + pa[k - 1]->link[(int) a[k - 1]] = r; + } + else if (r->bal == +1) + { + /* D13. */ + p = r->link[1]; + r->link[1] = p->link[0]; + p->link[0] = r; + s->link[0] = p->link[1]; + p->link[1] = s; + if (p->bal == -1) + s->bal = 1, r->bal = 0; + else if (p->bal == 0) + s->bal = r->bal = 0; + else + { + assert (p->bal == 1); + s->bal = 0, r->bal = -1; + } + p->bal = 0; + pa[k - 1]->link[(int) a[k - 1]] = p; + } + } + } + + return (void *) item; +} + +/* Inserts ITEM into TREE. Returns NULL if the item was inserted, + otherwise a pointer to the duplicate item. */ +void * +avl_insert (avl_tree *tree, void *item) +{ + void **p; + + assert (tree != NULL); + + p = avl_probe (tree, item); + return (*p == item) ? NULL : *p; +} + +/* If ITEM does not exist in TREE, inserts it and returns NULL. If a + matching item does exist, it is replaced by ITEM and the item + replaced is returned. The caller is responsible for freeing the + item returned. */ +void * +avl_replace (avl_tree *tree, void *item) +{ + void **p; + + assert (tree != NULL); + + p = avl_probe (tree, item); + if (*p == item) + return NULL; + else + { + void *r = *p; + *p = item; + return r; + } +} + +/* Delete ITEM from TREE when you know that ITEM must be in TREE. For + debugging purposes. */ +void * +(avl_force_delete) (avl_tree *tree, void *item) +{ + void *found = avl_delete (tree, item); + assert (found != NULL); + return found; +} + +#if SELF_TEST + +/* Used to flag delayed aborting. */ +int done = 0; + +/* Print the structure of node NODE of an avl tree, which is LEVEL + levels from the top of the tree. Uses different delimiters to + visually distinguish levels. */ +void +print_structure (avl_node *node, int level) +{ + char lc[] = "([{`/"; + char rc[] = ")]}'\\"; + + assert (level <= 10); + + if (node == NULL) + { + printf (" nil"); + return; + } + printf (" %c%d", lc[level % 5], (int) node->data); + if (node->link[0] || node->link[1]) + print_structure (node->link[0], level + 1); + if (node->link[1]) + print_structure (node->link[1], level + 1); + printf ("%c", rc[level % 5]); +} + +/* Compare two integers A and B and return a strcmp()-type result. */ +int +compare_ints (const void *a, const void *b, void *param unused) +{ + return ((int) a) - ((int) b); +} + +/* Print the value of integer A. */ +void +print_int (void *a, void *param unused) +{ + printf (" %d", (int) a); +} + +/* Linearly print contents of TREE. */ +void +print_contents (avl_tree *tree) +{ + avl_walk (tree, print_int, NULL); + printf ("\n"); +} + +/* Examine NODE in a avl tree. *COUNT is increased by the number of + nodes in the tree, including the current one. If the node is the + root of the tree, PARENT should be INT_MIN, otherwise it should be + the parent node value. DIR is the direction that the current node + is linked from the parent: -1 for left child, +1 for right child; + it is not used if PARENT is INT_MIN. Returns the height of the + tree rooted at NODE. */ +int +recurse_tree (avl_node *node, int *count, int parent, int dir) +{ + if (node) + { + int d = (int) node->data; + int nl = node->link[0] ? recurse_tree (node->link[0], count, d, -1) : 0; + int nr = node->link[1] ? recurse_tree (node->link[1], count, d, 1) : 0; + (*count)++; + + if (nr - nl != node->bal) + { + printf (" Node %d is unbalanced: right height=%d, left height=%d, " + "difference=%d, but balance factor=%d.\n", + d, nr, nl, nr - nl, node->bal); + done = 1; + } + + if (parent != INT_MIN) + { + assert (dir == -1 || dir == +1); + if (dir == -1 && d > parent) + { + printf (" Node %d is smaller than its left child %d.\n", + parent, d); + done = 1; + } + else if (dir == +1 && d < parent) + { + printf (" Node %d is larger than its right child %d.\n", + parent, d); + done = 1; + } + } + assert (node->bal >= -1 && node->bal <= 1); + return 1 + (nl > nr ? nl : nr); + } + else return 0; +} + +/* Check that everything about TREE is kosher. */ +void +verify_tree (avl_tree *tree) +{ + int count = 0; + recurse_tree (tree->root.link[0], &count, INT_MIN, 0); + if (count != tree->count) + { + printf (" Tree has %d nodes, but tree count is %d.\n", + count, tree->count); + done = 1; + } + if (done) + abort (); +} + +/* Arrange the N elements of ARRAY in random order. */ +void +shuffle (int *array, int n) +{ + int i; + + for (i = 0; i < n; i++) + { + int j = i + rand () % (n - i); + int t = array[j]; + array[j] = array[i]; + array[i] = t; + } +} + +/* Compares avl trees rooted at A and B, making sure that they are + identical. */ +void +compare_trees (avl_node *a, avl_node *b) +{ + if (a == NULL || b == NULL) + { + assert (a == NULL && b == NULL); + return; + } + if (a->data != b->data || a->bal != b->bal + || ((a->link[0] != NULL) ^ (b->link[0] != NULL)) + || ((a->link[1] != NULL) ^ (b->link[1] != NULL))) + { + printf (" Copied nodes differ: %d b=%d a->bal=%d b->bal=%d a:", + (int) a->data, (int) b->data, a->bal, b->bal); + if (a->link[0]) + printf ("l"); + if (a->link[1]) + printf ("r"); + printf (" b:"); + if (b->link[0]) + printf ("l"); + if (b->link[1]) + printf ("r"); + printf ("\n"); + abort (); + } + if (a->link[0] != NULL) + compare_trees (a->link[0], b->link[0]); + if (a->link[1] != NULL) + compare_trees (a->link[1], b->link[1]); +} + +/* Simple stress test procedure for the AVL tree routines. Does the + following: + + * Generate a random number seed. By default this is generated from + the current time. You can also pass a seed value on the command + line if you want to test the same case. The seed value is + displayed. + + * Create a tree and insert the integers from 0 up to TREE_SIZE - 1 + into it, in random order. Verify the tree structure after each + insertion. + + * Remove each integer from the tree, in a different random order. + After each deletion, verify the tree structure; also, make a copy + of the tree into a new tree, verify the copy and compare it to the + original, then destroy the copy. + + * Destroy the tree, increment the random seed value, and start over. + + If you make any modifications to the avl tree routines, then you + might want to insert some calls to print_structure() at strategic + places in order to be able to see what's really going on. Also, + memory debuggers like Checker or Purify are very handy. */ +#define TREE_SIZE 1024 +#define N_ITERATIONS 16 +int +main (int argc, char **argv) +{ + int array[TREE_SIZE]; + int seed; + int iteration; + + if (argc == 2) + seed = atoi (argv[1]); + else + seed = time (0) * 257 % 32768; + + fputs ("Testing avl...\n", stdout); + + for (iteration = 1; iteration <= N_ITERATIONS; iteration++) + { + avl_tree *tree; + int i; + + printf ("Iteration %4d/%4d: seed=%5d", iteration, N_ITERATIONS, seed); + fflush (stdout); + + srand (seed++); + + for (i = 0; i < TREE_SIZE; i++) + array[i] = i; + shuffle (array, TREE_SIZE); + + tree = avl_create (compare_ints, NULL); + for (i = 0; i < TREE_SIZE; i++) + avl_force_insert (tree, (void *) (array[i])); + verify_tree (tree); + + shuffle (array, TREE_SIZE); + for (i = 0; i < TREE_SIZE; i++) + { + avl_tree *copy; + + avl_delete (tree, (void *) (array[i])); + verify_tree (tree); + + copy = avl_copy (tree, NULL); + verify_tree (copy); + compare_trees (tree->root.link[0], copy->root.link[0]); + avl_destroy (copy, NULL); + + if (i % 128 == 0) + { + putchar ('.'); + fflush (stdout); + } + } + fputs (" good.\n", stdout); + + avl_destroy (tree, NULL); + } + + return 0; +} +#endif /* SELF_TEST */ + +/* + Local variables: + compile-command: "gcc -DSELF_TEST=1 -W -Wall -I. -o ./avl-test avl.c" + End: +*/ + diff --git a/src/avl.h b/src/avl.h new file mode 100644 index 00000000..8835f179 --- /dev/null +++ b/src/avl.h @@ -0,0 +1,142 @@ +/* libavl - manipulates AVL trees. + Copyright (C) 1998-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* This is file avl.h in libavl, version 1.1.0. */ + +#if !avl_h +#define avl_h 1 + +/* This stack size allows for AVL trees for between 5,704,880 and + 4,294,967,295 nodes, depending on order of insertion. If you + increase this it will require recoding some functions that assume + one long is big enough for a bitmap. */ +#ifndef AVL_MAX_HEIGHT +#define AVL_MAX_HEIGHT 32 +#endif + +/* Structure for a node in an AVL tree. */ +typedef struct avl_node + { + void *data; /* Pointer to data. */ + struct avl_node *link[2]; /* Subtrees. */ + signed char bal; /* Balance factor. */ + char cache; /* Used during insertion. */ + signed char pad[2]; /* Unused. Reserved for threaded trees. */ + } +avl_node; + +/* Used for traversing an AVL tree. */ +typedef struct avl_traverser + { + int init; /* Initialized? */ + int nstack; /* Top of stack. */ + const avl_node *p; /* Used for traversal. */ + const avl_node *stack[AVL_MAX_HEIGHT];/* Descended trees. */ + } +avl_traverser; + +#define avl_traverser_init(TRAVERSER) (TRAVERSER).init = 0 + +/* Function types. */ +#if !AVL_FUNC_TYPES +#define AVL_FUNC_TYPES 1 +typedef int (*avl_comparison_func) (const void *a, const void *b, void *param); +typedef void (*avl_node_func) (void *data, void *param); +typedef void *(*avl_copy_func) (void *data, void *param); +#endif + +/* Structure which holds information about an AVL tree. */ +typedef struct avl_tree + { +#if PSPP + struct pool *pool; /* Pool to store nodes. */ +#endif + avl_node root; /* Tree root node. */ + avl_comparison_func cmp; /* Used to compare keys. */ + int count; /* Number of nodes in the tree. */ + void *param; /* Arbitary user data. */ + } +avl_tree; + +#if PSPP +#define MAYBE_POOL struct pool *pool, +#else +#define MAYBE_POOL /* nothing */ +#endif + +/* General functions. */ +avl_tree *avl_create (MAYBE_POOL avl_comparison_func, void *param); +void avl_destroy (avl_tree *, avl_node_func); +void avl_free (avl_tree *); +int avl_count (const avl_tree *); +avl_tree *avl_copy (MAYBE_POOL const avl_tree *, avl_copy_func); + +/* Walk the tree. */ +void avl_walk (const avl_tree *, avl_node_func, void *param); +void *avl_traverse (const avl_tree *, avl_traverser *); + +/* Search for a given item. */ +void **avl_probe (avl_tree *, void *); +void *avl_delete (avl_tree *, const void *); +void *avl_find (const avl_tree *, const void *); + +#if __GCC__ >= 2 +extern inline void * +avl_insert (avl_tree *tree, void *item) +{ + void **p = avl_probe (tree, item); + return (*p == item) ? NULL : *p; +} + +extern inline void * +avl_replace (avl_tree *tree, void *item) +{ + void **p = avl_probe (tree, item); + if (*p == item) + return NULL; + else + { + void *r = *p; + *p = item; + return r; + } +} +#else /* not gcc */ +void *avl_insert (avl_tree *tree, void *item); +void *avl_replace (avl_tree *tree, void *item); +#endif /* not gcc */ + +/* Easy assertions on insertion & deletion. */ +#ifndef NDEBUG +#define avl_force_insert(A, B) \ + do \ + { \ + void *r = avl_insert (A, B); \ + assert (r == NULL); \ + } \ + while (0) +void *avl_force_delete (avl_tree *, void *); +#else +#define avl_force_insert(A, B) \ + avl_insert (A, B) +#define avl_force_delete(A, B) \ + avl_delete (A, B) +#endif + +#endif /* avl_h */ diff --git a/src/bitvector.h b/src/bitvector.h new file mode 100644 index 00000000..6c3a878b --- /dev/null +++ b/src/bitvector.h @@ -0,0 +1,45 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !bitvector_h +#define bitvector_h 1 + +#include + +/* Sets bit Y starting at address X. */ +#define SET_BIT(X, Y) \ + (((unsigned char *) X)[(Y) / CHAR_BIT] |= 1 << ((Y) % CHAR_BIT)) + +/* Clears bit Y starting at address X. */ +#define CLEAR_BIT(X, Y) \ + (((unsigned char *) X)[(Y) / CHAR_BIT] &= ~(1 << ((Y) % CHAR_BIT))) + +/* Sets bit Y starting at address X to Z, which is zero/nonzero */ +#define SET_BIT_TO(X, Y, Z) \ + ((Z) ? SET_BIT(X, Y) : CLEAR_BIT(X, Y)) + +/* Nonzero if bit Y starting at address X is set. */ +#define TEST_BIT(X, Y) \ + (((unsigned char *) X)[(Y) / CHAR_BIT] & (1 << ((Y) % CHAR_BIT))) + +/* Returns 2**X, 0 <= X < 32. */ +#define BIT_INDEX(X) \ + (1ul << (X)) + +#endif /* bitvector.h */ diff --git a/src/cases.c b/src/cases.c new file mode 100644 index 00000000..814a8726 --- /dev/null +++ b/src/cases.c @@ -0,0 +1,129 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include "alloc.h" +#include "cases.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Initializes V. */ +void +vec_init (struct long_vec * v) +{ + v->vec = NULL; + v->n = v->m = 0; +} + +/* Deletes the contents of V. */ +void +vec_clear (struct long_vec * v) +{ + free (v->vec); + v->vec = NULL; + v->n = v->m = 0; +} + +/* Inserts ELEM into V. */ +void +vec_insert (struct long_vec * v, long elem) +{ + if (v->n >= v->m) + { + v->m = (v->m == 0 ? 16 : 2 * v->m); + v->vec = xrealloc (v->vec, v->m * sizeof *v->vec); + } + v->vec[v->n++] = elem; +} + +/* Deletes all occurrences of values A through B exclusive from V. */ +void +vec_delete (struct long_vec * v, long a, long b) +{ + int i; + + for (i = v->n - 1; i >= 0; i--) + if (v->vec[i] >= a && v->vec[i] < b) + v->vec[i] = v->vec[--v->n]; +} + +/* Sticks V->FV in the proper vector. */ +void +envector (const struct variable *v) +{ + if (v->type == NUMERIC) + { + if (v->left) + vec_insert (&init_zero, v->fv); + else + vec_insert (&reinit_sysmis, v->fv); + } + else + { + int i; + + if (v->left) + for (i = v->fv; i < v->fv + v->nv; i++) + vec_insert (&init_blanks, i); + else + for (i = v->fv; i < v->fv + v->nv; i++) + vec_insert (&reinit_blanks, i); + } +} + +/* Removes V->FV from the proper vector. */ +void +devector (const struct variable *v) +{ + if (v->type == NUMERIC) + { + if (v->left) + vec_delete (&init_zero, v->fv, v->fv + 1); + else + vec_delete (&reinit_sysmis, v->fv, v->fv + 1); + } + else if (v->left) + vec_delete (&init_blanks, v->fv, v->fv + v->nv); + else + vec_delete (&reinit_blanks, v->fv, v->fv + v->nv); +} diff --git a/src/cases.h b/src/cases.h new file mode 100644 index 00000000..b7867232 --- /dev/null +++ b/src/cases.h @@ -0,0 +1,42 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !cases_h +#define cases_h 1 + +/* Vectors. */ + +/* A vector of longs. */ +struct long_vec + { + long *vec; /* Contents. */ + int n; /* Number of elements. */ + int m; /* Number of elements room is allocated for. */ + }; + +struct variable; + +void vec_init (struct long_vec *); +void vec_clear (struct long_vec *); +void vec_insert (struct long_vec *, long); +void vec_delete (struct long_vec *, long a, long b); +void devector (const struct variable *); +void envector (const struct variable *); + +#endif /* !cases_h */ diff --git a/src/cmdline.c b/src/cmdline.c new file mode 100644 index 00000000..bb9b9bab --- /dev/null +++ b/src/cmdline.c @@ -0,0 +1,257 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "getline.h" +#include "main.h" +#include "output.h" +#include "settings.h" +#include "str.h" +#include "var.h" +#include "version.h" + +void welcome (void); +static void usage (void); + +char *subst_vars (char *); + +/* Parses the command line specified by ARGC and ARGV as received by + main(). */ +void +parse_command_line (int argc, char **argv) +{ + static struct option long_options[] = + { + {"command", required_argument, NULL, 'c'}, + {"config-directory", required_argument, NULL, 'B'}, + {"device", required_argument, NULL, 'o'}, + {"dry-run", no_argument, NULL, 'n'}, + {"edit", no_argument, NULL, 'n'}, + {"help", no_argument, NULL, 'h'}, + {"include-directory", required_argument, NULL, 'I'}, + {"interactive", no_argument, NULL, 'i'}, + {"just-print", no_argument, NULL, 'n'}, + {"list", no_argument, NULL, 'l'}, + {"no-include", no_argument, NULL, 'I'}, + {"no-statrc", no_argument, NULL, 'r'}, + {"out-file", required_argument, NULL, 'f'}, + {"pipe", no_argument, NULL, 'p'}, + {"recon", no_argument, NULL, 'n'}, + {"safer", no_argument, NULL, 's'}, + {"testing-mode", no_argument, &set_testing_mode, 1}, + {"verbose", no_argument, NULL, 'v'}, + {"version", no_argument, NULL, 'V'}, + {0, 0, 0, 0}, + }; + + int c, i; + + int cleared_device_defaults = 0; + + int no_statrc = 0; + + for (;;) + { + c = getopt_long (argc, argv, "B:c:f:hiI:lno:prsvV", long_options, NULL); + if (c == -1) + break; + + switch (c) + { + case 'c': + { + static int n_cmds; + + struct getl_script *script = xmalloc (sizeof *script); + + { + struct getl_line_list *line; + + script->first_line = line = xmalloc (sizeof *line); + line->line = xstrdup ("commandline"); + line->len = --n_cmds; + line = line->next = xmalloc (sizeof *line); + line->line = xstrdup (optarg); + line->len = strlen (optarg); + line->next = NULL; + } + + getl_add_virtual_file (script); + } + break; + case 'B': + config_path = optarg; + break; + case 'f': + printf (_("-f not yet implemented\n")); + break; + case 'h': + usage (); + assert (0); + case 'i': + getl_interactive = 2; + break; + case 'I': + if (optarg == NULL || !strcmp (optarg, "-")) + getl_clear_include_path (); + else + getl_add_include_dir (optarg); + break; + case 'l': + outp_list_classes (); + err_hcf (1); + case 'n': + printf (_("-n not yet implemented\n")); + break; + case 'o': + if (!cleared_device_defaults) + { + outp_configure_clear (); + cleared_device_defaults = 1; + } + outp_configure_add (optarg); + break; + case 'p': + printf (_("-p not yet implemented\n")); + break; + case 'r': + no_statrc = 1; + break; + case 's': + set_safer = 1; + break; + case 'v': + err_verbosity++; + break; + case 'V': + puts (version); + puts (_("\nCopyright (C) 1997-9, 2000 Free Software Foundation, " + "Inc.\n" + "This is free software; see the source for copying " + "conditions. There is NO\n" + "WARRANTY; not even for MERCHANTABILITY or FITNESS " + "FOR A PARTICULAR PURPOSE.\n\n" + "Written by Ben Pfaff .")); + err_hcf (1); + case '?': + usage (); + assert (0); + case 0: + break; + default: + assert (0); + } + } + + if (set_testing_mode) + { + /* FIXME: Later this option should do some other things, too. */ + set_viewwidth = 79; + } + + for (i = optind; i < argc; i++) + { + int separate = 1; + + if (!strcmp (argv[i], "+")) + { + separate = 0; + if (++i >= argc) + usage (); + } + else if (strchr (argv[i], '=')) + { + outp_configure_macro (argv[i]); + continue; + } + getl_add_file (argv[i], separate, 0); + } + if (getl_head) + getl_head->separate = 0; + + if (getl_am_interactive) + getl_interactive = 1; + + if (!no_statrc) + { + char *pspprc_fn = fn_search_path ("rc", config_path, NULL); + + if (pspprc_fn) + getl_add_file (pspprc_fn, 0, 1); + + free (pspprc_fn); + } +} + +/* Message that describes PSPP command-line syntax. */ +static const char pre_syntax_message[] = +N_("PSPP, a program for statistical analysis of sample data.\n" +"\nUsage: %s [OPTION]... FILE...\n" +"\nIf a long option shows an argument as mandatory, then it is mandatory\n" +"for the equivalent short option also. Similarly for optional arguments.\n" +"\nConfiguration:\n" +" -B, --config-dir=DIR set configuration directory to DIR\n" +" -o, --device=DEVICE select output driver DEVICE and disable defaults\n" +" -d, --define=VAR[=VALUE] set environment variable VAR to VALUE, or empty\n" +" -u, --undef=VAR undefine environment variable VAR\n" +"\nInput and output:\n" +" -f, --out-file=FILE send output to FILE (overwritten)\n" +" -p, --pipe read script from stdin, send output to stdout\n" +" -I-, --no-include clear include path\n" +" -I, --include=DIR append DIR to include path\n" +" -c, --command=COMMAND execute COMMAND before .pspp/rc at startup\n" +"\nLanguage modifiers:\n" +" -i, --interactive interpret scripts in interactive mode\n" +" -n, --edit just check syntax; don't actually run the code\n" +" -r, --no-statrc disable execution of .pspp/rc at startup\n" +" -s, --safer don't allow some unsafe operations\n" +"\nInformative output:\n" +" -h, --help print this help, then exit\n" +" -l, --list print a list of known driver classes, then exit\n" +" -V, --version show PSPP version, then exit\n" +" -v, --verbose increments verbosity level\n" +"\nNon-option arguments:\n" +" FILE1 FILE2 run FILE1, clear the dictionary, run FILE2\n" +" FILE1 + FILE2 run FILE1 then FILE2 without clearing dictionary\n" +" KEY=VALUE overrides macros in output initialization file\n" +"\n"); + +/* Message that describes PSPP command-line syntax, continued. */ +static const char post_syntax_message[] = +N_("\nReport bugs to .\n"); + +/* Writes a syntax description to stdout and terminates. */ +static void +usage (void) +{ + printf (gettext (pre_syntax_message), pgmname); + outp_list_classes (); + printf (gettext (post_syntax_message)); + + err_hcf (1); +} diff --git a/src/command.c b/src/command.c new file mode 100644 index 00000000..40c186ef --- /dev/null +++ b/src/command.c @@ -0,0 +1,791 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "getline.h" +#include "lexer.h" +#include "main.h" +#include "settings.h" +#include "som.h" +#include "str.h" +#include "tab.h" +#include "var.h" +#include "vfm.h" + +#if HAVE_UNISTD_H +#include +#endif + +#if HAVE_SYS_WAIT_H +#include +#endif + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Global variables. */ + +/* A STATE_* constant giving the current program state. */ +int pgm_state; + +/* The name of the procedure currently executing, if any. */ +const char *cur_proc; + +/* Static variables. */ + +/* A single command. */ +struct command + { + /* Initialized statically. */ + char cmd[22]; /* Command name. */ + int transition[4]; /* Transitions to make from each state. */ + int (*func) (void); /* Function to call. */ + + /* Calculated at startup time. */ + char *word[3]; /* cmd[], divided into individual words. */ + struct command *next; /* Next command with same word[0]. */ + }; + +/* Prototype all the command functions. */ +#define DEFCMD(NAME, T1, T2, T3, T4, FUNC) \ + int FUNC (void); +#define UNIMPL(NAME, T1, T2, T3, T4) +#include "command.def" +#undef DEFCMD +#undef UNIMPL + +/* Define the command array. */ +#define DEFCMD(NAME, T1, T2, T3, T4, FUNC) \ + {NAME, {T1, T2, T3, T4}, FUNC, {NULL, NULL, NULL}, NULL}, +#define UNIMPL(NAME, T1, T2, T3, T4) \ + {NAME, {T1, T2, T3, T4}, NULL, {NULL, NULL, NULL}, NULL}, +static struct command cmd_table[] = + { +#include "command.def" + {"", {ERRO, ERRO, ERRO, ERRO}, NULL, {NULL, NULL, NULL}, NULL}, + }; +#undef DEFCMD +#undef UNIMPL + +/* Command parser. */ + +static struct command *figure_out_command (void); + +/* Breaks the `cmd' member of C into individual words and sets C's + word[] member appropriately. */ +static void +split_words (struct command *c) +{ + char *cmd, *save; + int i; + + cmd = xstrdup (c->cmd); + for (i = 0; i < 3; i++) + cmd = c->word[i] = strtok_r (i == 0 ? cmd : NULL, " -", &save); +} + +/* Initializes the command parser. */ +void +cmd_init (void) +{ + struct command *c; + + /* Break up command names into words. */ + for (c = cmd_table; c->cmd[0]; c++) + split_words (c); + + /* Make chains of commands having the same first word. */ + for (c = cmd_table; c->cmd[0]; c++) + { + struct command *first; + for (first = c; c[1].word[0] && !strcmp (c[0].word[0], c[1].word[0]); c++) + c->next = c + 1; + + c->next = NULL; + } +} + +/* Determines whether command C is appropriate to call in this + part of a FILE TYPE structure. */ +static int +FILE_TYPE_okay (struct command *c) +{ + int okay = 0; + + if (c->func != cmd_record_type + && c->func != cmd_data_list + && c->func != cmd_repeating_data + && c->func != cmd_end_file_type) + msg (SE, _("%s not allowed inside FILE TYPE/END FILE TYPE."), c->cmd); +#if 0 + /* FIXME */ + else if (c->func == cmd_repeating_data && fty.type == FTY_GROUPED) + msg (SE, _("%s not allowed inside FILE TYPE GROUPED/END FILE TYPE."), + c->cmd); + else if (!fty.had_rec_type && c->func != cmd_record_type) + msg (SE, _("RECORD TYPE must be the first command inside a " + "FILE TYPE structure.")); +#endif + else + okay = 1; + +#if 0 + if (c->func == cmd_record_type) + fty.had_rec_type = 1; +#endif + + return okay; +} + +/* Parses an entire PSPP command. This includes everything from the + command name to the terminating dot. Does most of its work by + passing it off to the respective command dispatchers. Only called + by parse() in main.c. */ +int +cmd_parse (void) +{ + struct command *cp; /* Iterator used to find the proper command. */ + +#if C_ALLOCA + /* The generic alloca package performs garbage collection when it is + called with an argument of zero. */ + alloca (0); +#endif /* C_ALLOCA */ + + /* Null commands can result from extra empty lines. */ + if (token == '.') + return CMD_SUCCESS; + + /* Parse comments. */ + if ((token == T_ID && !strcmp (tokid, "COMMENT")) + || token == T_EXP || token == '*' || token == '[') + { + lex_skip_comment (); + return CMD_SUCCESS; + } + + /* Otherwise the line must begin with a command name, which is + always an ID token. */ + if (token != T_ID) + { + msg (SE, _("This line does not begin with a valid command name.")); + return CMD_FAILURE; + } + + /* Parse the command name. */ + cp = figure_out_command (); + if (cp == NULL) + return CMD_FAILURE; + if (cp->func == NULL) + { + msg (SE, _("%s is not yet implemented."), cp->cmd); + while (token && token != '.') + lex_get (); + return CMD_SUCCESS; + } + + /* If we're in a FILE TYPE structure, only certain commands can be + allowed. */ + if (pgm_state == STATE_INPUT && vfm_source == &file_type_source + && !FILE_TYPE_okay (cp)) + return CMD_FAILURE; + + /* Certain state transitions are not allowed. Check for these. */ + assert (pgm_state >= 0 && pgm_state < STATE_ERROR); + if (cp->transition[pgm_state] == STATE_ERROR) + { + static const char *state_name[4] = + { + N_("%s is not allowed (1) before a command to specify the " + "input program, such as DATA LIST, (2) between FILE TYPE " + "and END FILE TYPE, (3) between INPUT PROGRAM and END " + "INPUT PROGRAM."), + N_("%s is not allowed within an input program."), + N_("%s is only allowed within an input program."), + N_("%s is only allowed within an input program."), + }; + + msg (SE, gettext (state_name[pgm_state]), cp->cmd); + return CMD_FAILURE; + } + +#if DEBUGGING + if (cp->func != cmd_remark) + printf (_("%s command beginning\n"), cp->cmd); +#endif + + /* The structured output manager numbers all its tables. Increment + the major table number for each separate procedure. */ + som_new_series (); + + { + int result; + + /* Call the command dispatcher. Save and restore the name of + the current command around this call. */ + { + const char *prev_proc; + + prev_proc = cur_proc; + cur_proc = cp->cmd; + result = cp->func (); + cur_proc = prev_proc; + } + + /* Perform the state transition if the command completed + successfully (at least in part). */ + if (result != 0) + { + pgm_state = cp->transition[pgm_state]; + + if (pgm_state == STATE_ERROR) + { + discard_variables (); + pgm_state = STATE_INIT; + } + } + +#if DEBUGGING + if (cp->func != cmd_remark) + printf (_("%s command completed\n\n"), cp->cmd); +#endif + + /* Pass the command's success value up to the caller. */ + return result; + } +} + +/* Parse the command name and return a pointer to the corresponding + struct command if successful. + If not successful, return a null pointer. */ +static struct command * +figure_out_command (void) +{ + static const char *unk = + N_("The identifier(s) specified do not form a valid command name:"); + + static const char *inc = + N_("The identifier(s) specified do not form a complete command name:"); + + struct command *cp; + + /* Parse the INCLUDE short form. + Note that `@' is a valid character in identifiers. */ + if (tokid[0] == '@') + return &cmd_table[0]; + + /* Find a command whose first word matches this identifier. + If it is the only command that begins with this word, return + it. */ + for (cp = cmd_table; cp->cmd[0]; cp++) + if (lex_id_match (cp->word[0], tokid)) + break; + + if (cp->cmd[0] == '\0') + { + msg (SE, "%s %s.", gettext (unk), ds_value (&tokstr)); + return NULL; + } + + if (cp->next == NULL) + return cp; + + /* We know that there is more than one command starting with this + word. Read the next word in the command name. */ + { + struct command *ocp = cp; + + /* Verify that the next token is an identifier, because we + must disambiguate this command name. */ + lex_get (); + if (token != T_ID) + { + /* If there's a command whose name is the first word only, + return it. This happens with, i.e., PRINT vs. PRINT + SPACE. */ + if (ocp->word[1] == NULL) + return ocp; + + msg (SE, "%s %s.", gettext (inc), ds_value (&tokstr)); + return NULL; + } + + for (; cp; cp = cp->next) + if (cp->word[1] && lex_id_match (cp->word[1], tokid)) + break; + + if (cp == NULL) + { + /* No match. If there's a command whose name is the first + word only, return it. This happens with, i.e., PRINT + vs. PRINT SPACE. */ + if (ocp->word[1] == NULL) + return ocp; + + msg (SE, "%s %s %s.", gettext (unk), ocp->word[0], tokid); + return NULL; + } + + /* Check whether the next token is an identifier. + If not, bail. */ + if (!isalpha ((unsigned char) (lex_look_ahead ()))) + { + /* Check whether there is an unambiguous interpretation. + If not, give an error. */ + if (cp->word[2] + && cp->next + && !strcmp (cp->word[1], cp->next->word[1])) + { + msg (SE, "%s %s %s.", gettext (inc), ocp->word[0], ocp->word[1]); + return NULL; + } + else + return cp; + } + } + + /* If this command can have a third word, disambiguate based on it. */ + if (cp->word[2] + || (cp->next + && cp->next->word[2] + && !strcmp (cp->word[1], cp->next->word[1]))) + { + struct command *ocp = cp; + + lex_get (); + assert (token == T_ID); + + /* Try to find a command with this third word. + If found, bail. */ + for (; cp; cp = cp->next) + if (cp->word[2] + && !strcmp (cp->word[1], ocp->word[1]) + && lex_id_match (cp->word[2], tokid)) + break; + + if (cp != NULL) + return cp; + + /* If no command with this third word found, make sure that + there's a command with those first two words but without a + third word. */ + cp = ocp; + if (cp->word[2]) + { + msg (SE, "%s %s %s %s.", + gettext (unk), ocp->word[0], ocp->word[1], ds_value (&tokstr)); + return 0; + } + } + + return cp; +} + +/* Simple commands. */ + +/* Parse and execute EXIT command. */ +int +cmd_exit (void) +{ + if (getl_reading_script) + { + msg (SE, _("This command is not accepted in a syntax file. " + "Instead, use FINISH to terminate a syntax file.")); + lex_get (); + } + else + finished = 1; + + return CMD_SUCCESS; +} + +/* Parse and execute FINISH command. */ +int +cmd_finish (void) +{ + /* Do not check for `.' + Do not fetch any extra tokens. */ + if (getl_interactive) + { + msg (SM, _("This command is not executed " + "in interactive mode. Instead, PSPP drops " + "down to the command prompt. Use EXIT if you really want " + "to quit.")); + getl_close_all (); + } + else + finished = 1; + + return CMD_SUCCESS; +} + +/* Extracts a null-terminated 8-or-fewer-character PREFIX from STRING. + PREFIX is converted to lowercase. Removes trailing spaces from + STRING as a side effect. */ +static void +extract_prefix (char *string, char *prefix) +{ + /* Length of STRING. */ + int len; + + /* Points to the null terminator in STRING (`end pointer'). */ + char *ep; + + /* Strip spaces from end of STRING. */ + len = strlen (string); + while (len && isspace ((unsigned char) string[len - 1])) + string[--len] = 0; + + /* Find null terminator. */ + ep = memchr (string, '\0', 8); + if (!ep) + ep = &string[8]; + + /* Copy prefix, converting to lowercase. */ + while (string < ep) + *prefix++ = tolower ((unsigned char) (*string++)); + *prefix = 0; +} + +/* Prints STRING on the console and to the listing file, replacing \n + by newline. */ +static void +output_line (char *string) +{ + /* Location of \n in line read in. */ + char *cp; + + cp = strstr (string, "\\n"); + while (cp) + { + *cp = 0; + tab_output_text (TAB_LEFT | TAT_NOWRAP, string); + string = &cp[2]; + cp = strstr (string, "\\n"); + } + tab_output_text (TAB_LEFT | TAT_NOWRAP, string); +} + +/* Parse and execute REMARK command. */ +int +cmd_remark () +{ + /* Points to the line read in. */ + char *s; + + /* Index into s. */ + char *cp; + + /* 8-character sentinel used to terminate remark. */ + char sentinel[9]; + + /* Beginning of line used to compare with SENTINEL. */ + char prefix[9]; + + som_blank_line (); + + s = lex_rest_of_line (NULL); + if (*s == '-') + { + output_line (&s[1]); + return CMD_SUCCESS; + } + + /* Read in SENTINEL from end of current line. */ + cp = s; + while (isspace ((unsigned char) *cp)) + cp++; + extract_prefix (cp, sentinel); + if (sentinel[0] == 0) + { + msg (SE, _("The sentinel may not be the empty string.")); + return CMD_FAILURE; + } + + /* Read in other lines until we encounter the sentinel. */ + while (getl_read_line ()) + { + extract_prefix (ds_value (&getl_buf), prefix); + if (!strcmp (sentinel, prefix)) + break; + + /* Output the line. */ + output_line (ds_value (&getl_buf)); + } + + /* Calling lex_entire_line() forces the sentinel line to be + discarded. */ + getl_prompt = GETL_PRPT_STANDARD; + lex_entire_line (); + + return CMD_SUCCESS; +} + +/* Parses the N command. */ +int +cmd_n_of_cases (void) +{ + /* Value for N. */ + int x; + + lex_match_id ("N"); + lex_match_id ("OF"); + lex_match_id ("CASES"); + if (!lex_force_int ()) + return CMD_FAILURE; + x = lex_integer (); + lex_get (); + if (!lex_match_id ("ESTIMATED")) + default_dict.N = x; + + return lex_end_of_command (); +} + +/* Parses, performs the EXECUTE procedure. */ +int +cmd_execute (void) +{ + lex_match_id ("EXECUTE"); + procedure (NULL, NULL, NULL); + return lex_end_of_command (); +} + +/* Parses, performs the ERASE command. */ +int +cmd_erase (void) +{ + if (set_safer) + { + msg (SE, _("This command not allowed when the SAFER option is set.")); + return CMD_FAILURE; + } + + lex_match_id ("ERASE"); + if (!lex_force_match_id ("FILE")) + return CMD_FAILURE; + lex_match ('='); + if (!lex_force_string ()) + return CMD_FAILURE; + + if (remove (ds_value (&tokstr)) == -1) + { + msg (SW, _("Error removing `%s': %s."), + ds_value (&tokstr), strerror (errno)); + return CMD_FAILURE; + } + + return lex_end_of_command (); +} + +#if unix +/* Spawn a shell process. */ +static int +shell (void) +{ + int pid; + + pid = fork (); + switch (pid) + { + case 0: + { + const char *shell_fn; + char *shell_process; + + { + int i; + + for (i = 3; i < 20; i++) + close (i); + } + + shell_fn = getenv ("SHELL"); + if (shell_fn == NULL) + shell_fn = "/bin/sh"; + + { + const char *cp = strrchr (shell_fn, '/'); + cp = cp ? &cp[1] : shell_fn; + shell_process = local_alloc (strlen (cp) + 8); + strcpy (shell_process, "-"); + strcat (shell_process, cp); + if (strcmp (cp, "sh")) + shell_process[0] = '+'; + } + + execl (shell_fn, shell_process, NULL); + + err_hcf (1); + } + + case -1: + msg (SE, _("Couldn't fork: %s."), strerror (errno)); + return 0; + + default: + assert (pid > 0); + while (wait (NULL) != pid) + ; + return 1; + } +} +#endif /* unix */ + +/* Parses the HOST command argument and executes the specified + command. Returns a suitable command return code. */ +static int +run_command (void) +{ + char *cmd; + int string; + + /* Handle either a string argument or a full-line argument. */ + { + int c = lex_look_ahead (); + + if (c == '\'' || c == '"') + { + lex_get (); + if (!lex_force_string ()) + return CMD_FAILURE; + cmd = ds_value (&tokstr); + string = 1; + } + else + { + cmd = lex_rest_of_line (NULL); + string = 0; + } + } + + /* Execute the command. */ + if (system (cmd) == -1) + msg (SE, _("Error executing command: %s."), strerror (errno)); + + /* Finish parsing. */ + if (string) + { + lex_get (); + + if (token != '.') + { + lex_error (_("expecting end of command")); + return CMD_TRAILING_GARBAGE; + } + } + else + token = '.'; + + return CMD_SUCCESS; +} + +/* Parses, performs the HOST command. */ +int +cmd_host (void) +{ + int code; + + if (set_safer) + { + msg (SE, _("This command not allowed when the SAFER option is set.")); + return CMD_FAILURE; + } + + lex_match_id ("HOST"); + +#if unix + /* Figure out whether to invoke an interactive shell or to execute a + single shell command. */ + if (lex_look_ahead () == '.') + { + lex_get (); + code = shell () ? CMD_PART_SUCCESS_MAYBE : CMD_SUCCESS; + } + else + code = run_command (); +#else /* !unix */ + /* Make sure that the system has a command interpreter, then run a + command. */ + if (system (NULL) != 0) + success = run_command (); + else + { + msg (SE, _("No operating system support for this command.")); + success = CMD_FAILURE; + } +#endif /* !unix */ + + return code ? CMD_FAILURE : CMD_SUCCESS; +} + +/* Parses, performs the NEW FILE command. */ +int +cmd_new_file (void) +{ + lex_match_id ("NEW"); + lex_match_id ("FILE"); + + discard_variables (); + + return lex_end_of_command (); +} + +/* Parses, performs the CLEAR TRANSFORMATIONS command. */ +int +cmd_clear_transformations (void) +{ + lex_match_id ("CLEAR"); + lex_match_id ("TRANSFORMATIONS"); + + if (getl_reading_script) + { + msg (SW, _("This command is not valid in a syntax file.")); + return CMD_FAILURE; + } + + cancel_transformations (); + + return CMD_SUCCESS; +} diff --git a/src/command.def b/src/command.def new file mode 100644 index 00000000..beaf7741 --- /dev/null +++ b/src/command.def @@ -0,0 +1,134 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* State abbreviations. */ +#define INIT STATE_INIT +#define INPU STATE_INPUT +#define TRAN STATE_TRANS +#define PROC STATE_PROC +#define ERRO STATE_ERROR + +DEFCMD ("@", INIT, INPU, TRAN, PROC, cmd_include_at) +UNIMPL ("ADD FILES", TRAN, ERRO, TRAN, TRAN) +DEFCMD ("ADD VALUE LABELS", ERRO, INPU, TRAN, TRAN, cmd_add_value_labels) +DEFCMD ("AGGREGATE", ERRO, ERRO, PROC, TRAN, cmd_aggregate) +DEFCMD ("APPLY DICTIONARY", ERRO, ERRO, TRAN, TRAN, cmd_apply_dictionary) +DEFCMD ("AUTORECODE", ERRO, ERRO, PROC, PROC, cmd_autorecode) +DEFCMD ("BEGIN DATA", ERRO, ERRO, PROC, PROC, cmd_begin_data) +DEFCMD ("BREAK", ERRO, INPU, TRAN, TRAN, cmd_break) +DEFCMD ("CLEAR TRANSFORMATIONS", ERRO, INPU, TRAN, TRAN, cmd_clear_transformations) +DEFCMD ("COMPUTE", ERRO, INPU, TRAN, TRAN, cmd_compute) +DEFCMD ("CORRELATIONS", ERRO, ERRO, PROC, PROC, cmd_correlations) +DEFCMD ("CONDESCRIPTIVES", ERRO, ERRO, PROC, PROC, cmd_descriptives) +DEFCMD ("COUNT", ERRO, INPU, TRAN, TRAN, cmd_count) +DEFCMD ("CROSSTABS", ERRO, ERRO, PROC, PROC, cmd_crosstabs) +DEFCMD ("DATA LIST", TRAN, INPU, TRAN, TRAN, cmd_data_list) +DEFCMD ("DESCRIPTIVES", ERRO, ERRO, PROC, PROC, cmd_descriptives) +DEFCMD ("DISPLAY", ERRO, INPU, TRAN, PROC, cmd_display) +DEFCMD ("DO IF", ERRO, INPU, TRAN, TRAN, cmd_do_if) +DEFCMD ("DO REPEAT", ERRO, INPU, TRAN, TRAN, cmd_do_repeat) +DEFCMD ("DOCUMENT", ERRO, INPU, TRAN, TRAN, cmd_document) +DEFCMD ("DROP DOCUMENTS", INIT, INPU, TRAN, PROC, cmd_drop_documents) +UNIMPL ("EDIT", INIT, INPU, TRAN, PROC) +DEFCMD ("ELSE", ERRO, INPU, TRAN, TRAN, cmd_else) +DEFCMD ("ELSE IF", ERRO, INPU, TRAN, TRAN, cmd_else_if) +DEFCMD ("END CASE", ERRO, INPU, ERRO, ERRO, cmd_end_case) +DEFCMD ("END FILE", ERRO, INPU, ERRO, ERRO, cmd_end_file) +DEFCMD ("END FILE TYPE", ERRO, TRAN, ERRO, ERRO, cmd_end_file_type) +DEFCMD ("END IF", ERRO, INPU, TRAN, TRAN, cmd_end_if) +DEFCMD ("END INPUT PROGRAM", ERRO, TRAN, ERRO, ERRO, cmd_end_input_program) +DEFCMD ("END LOOP", ERRO, INPU, TRAN, TRAN, cmd_end_loop) +DEFCMD ("END REPEAT", ERRO, INPU, TRAN, TRAN, cmd_end_repeat) +DEFCMD ("ERASE", INIT, INPU, TRAN, PROC, cmd_erase) +#if GLOBAL_DEBUGGING +DEFCMD ("EVALUATE", INIT, INPU, TRAN, PROC, cmd_evaluate) +#endif +DEFCMD ("EXECUTE", ERRO, ERRO, PROC, PROC, cmd_execute) +DEFCMD ("EXIT", INIT, INPU, TRAN, PROC, cmd_exit) +DEFCMD ("EXPORT", ERRO, ERRO, PROC, PROC, cmd_export) +DEFCMD ("FILE HANDLE", INIT, INPU, TRAN, PROC, cmd_file_handle) +DEFCMD ("FILE LABEL", INIT, INPU, TRAN, PROC, cmd_file_label) +DEFCMD ("FILE TYPE", INPU, ERRO, INPU, INPU, cmd_file_type) +DEFCMD ("FILTER", ERRO, ERRO, TRAN, TRAN, cmd_filter) +DEFCMD ("FINISH", INIT, INPU, TRAN, PROC, cmd_finish) +DEFCMD ("FLIP", ERRO, ERRO, PROC, PROC, cmd_flip) +DEFCMD ("FORMATS", INIT, INPU, TRAN, PROC, cmd_formats) +DEFCMD ("FREQUENCIES", ERRO, ERRO, PROC, PROC, cmd_frequencies) +DEFCMD ("GET", TRAN, ERRO, TRAN, TRAN, cmd_get) +DEFCMD ("HOST", INIT, INPU, TRAN, PROC, cmd_host) +DEFCMD ("IF", ERRO, INPU, TRAN, TRAN, cmd_if) +DEFCMD ("INCLUDE", INIT, INPU, TRAN, PROC, cmd_include) +UNIMPL ("INFO", INIT, INPU, TRAN, PROC) +DEFCMD ("IMPORT", TRAN, ERRO, TRAN, TRAN, cmd_import) +UNIMPL ("INPUT MATRIX", INIT, INPU, TRAN, PROC) +DEFCMD ("INPUT PROGRAM", INPU, ERRO, INPU, INPU, cmd_input_program) +UNIMPL ("KEYED DATA LIST", INPU, ERRO, INPU, INPU) +DEFCMD ("LEAVE", ERRO, INPU, TRAN, TRAN, cmd_leave) +DEFCMD ("LIST", ERRO, ERRO, PROC, PROC, cmd_list) +DEFCMD ("LOOP", ERRO, INPU, TRAN, TRAN, cmd_loop) +DEFCMD ("MATCH FILES", TRAN, ERRO, TRAN, PROC, cmd_match_files) +DEFCMD ("MATRIX DATA", TRAN, ERRO, TRAN, TRAN, cmd_matrix_data) +DEFCMD ("MEANS", ERRO, ERRO, PROC, PROC, cmd_means) +DEFCMD ("MISSING VALUES", ERRO, INPU, TRAN, TRAN, cmd_missing_values) +DEFCMD ("MODIFY VARS", ERRO, INPU, TRAN, PROC, cmd_modify_vars) +DEFCMD ("NEW FILE", INIT, ERRO, INIT, INIT, cmd_new_file) +DEFCMD ("N OF CASES", INIT, INPU, TRAN, TRAN, cmd_n_of_cases) +UNIMPL ("NUMBERED", INIT, INPU, TRAN, PROC) +DEFCMD ("NUMERIC", ERRO, INPU, TRAN, TRAN, cmd_numeric) +UNIMPL ("UNNUMBERED", INIT, INPU, TRAN, PROC) +DEFCMD ("PEARSON CORRELATIONS", ERRO, ERRO, PROC, PROC, cmd_correlations) +UNIMPL ("POINT", ERRO, INPU, ERRO, ERRO) +UNIMPL ("PRESERVE", INIT, INPU, TRAN, PROC) +DEFCMD ("PRINT", ERRO, INPU, TRAN, TRAN, cmd_print) +DEFCMD ("PRINT EJECT", ERRO, INPU, TRAN, TRAN, cmd_print_eject) +DEFCMD ("PRINT FORMATS", ERRO, INPU, TRAN, TRAN, cmd_print_formats) +DEFCMD ("PRINT SPACE", ERRO, INPU, TRAN, TRAN, cmd_print_space) +UNIMPL ("PROCEDURE OUTPUT", INIT, INPU, TRAN, PROC) +DEFCMD ("PROCESS IF", ERRO, ERRO, TRAN, TRAN, cmd_process_if) +DEFCMD ("Q", INIT, INPU, TRAN, PROC, cmd_exit) +DEFCMD ("QUIT", INIT, INPU, TRAN, PROC, cmd_exit) +DEFCMD ("RECODE", ERRO, INPU, TRAN, TRAN, cmd_recode) +DEFCMD ("RECORD TYPE", ERRO, INPU, ERRO, ERRO, cmd_record_type) +UNIMPL ("REFORMAT", ERRO, ERRO, TRAN, TRAN) +DEFCMD ("REMARK", INIT, INPU, TRAN, PROC, cmd_remark) +DEFCMD ("RENAME VARIABLES", ERRO, INPU, TRAN, PROC, cmd_rename_variables) +DEFCMD ("REPEATING DATA", ERRO, INPU, ERRO, ERRO, cmd_repeating_data) +DEFCMD ("REREAD", ERRO, INPU, ERRO, ERRO, cmd_reread) +UNIMPL ("RESTORE", INIT, INPU, TRAN, PROC) +DEFCMD ("SAMPLE", ERRO, ERRO, TRAN, TRAN, cmd_sample) +DEFCMD ("SAVE", ERRO, ERRO, PROC, PROC, cmd_save) +DEFCMD ("SELECT IF", ERRO, ERRO, TRAN, TRAN, cmd_select_if) +DEFCMD ("SET", INIT, INPU, TRAN, PROC, cmd_set) +UNIMPL ("SHOW", INIT, INPU, TRAN, PROC) +DEFCMD ("SORT CASES", ERRO, ERRO, PROC, PROC, cmd_sort_cases) +DEFCMD ("SPLIT FILE", ERRO, INPU, TRAN, TRAN, cmd_split_file) +DEFCMD ("STRING", ERRO, INPU, TRAN, TRAN, cmd_string) +DEFCMD ("SUBTITLE", INIT, INPU, TRAN, PROC, cmd_subtitle) +DEFCMD ("SYSFILE INFO", INIT, INPU, TRAN, PROC, cmd_sysfile_info) +DEFCMD ("TEMPORARY", ERRO, ERRO, TRAN, TRAN, cmd_temporary) +DEFCMD ("TITLE", INIT, INPU, TRAN, PROC, cmd_title) +DEFCMD ("T-TEST", ERRO, ERRO, PROC, PROC, cmd_t_test) +UNIMPL ("UPDATE", TRAN, ERRO, TRAN, TRAN) +DEFCMD ("VALUE LABELS", ERRO, INPU, TRAN, TRAN, cmd_value_labels) +DEFCMD ("VARIABLE LABELS", ERRO, INPU, TRAN, TRAN, cmd_variable_labels) +DEFCMD ("VECTOR", ERRO, INPU, TRAN, TRAN, cmd_vector) +DEFCMD ("WEIGHT", ERRO, INPU, TRAN, TRAN, cmd_weight) +DEFCMD ("WRITE", ERRO, INPU, TRAN, TRAN, cmd_write) +DEFCMD ("WRITE FORMATS", ERRO, INPU, TRAN, TRAN, cmd_write_formats) +DEFCMD ("XSAVE", ERRO, INPU, TRAN, TRAN, cmd_xsave) diff --git a/src/command.h b/src/command.h new file mode 100644 index 00000000..0a61996d --- /dev/null +++ b/src/command.h @@ -0,0 +1,49 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !command_h +#define command_h 1 + +/* Current program state. */ +enum + { + STATE_INIT, /* Initialization state. */ + STATE_INPUT, /* Input state. */ + STATE_TRANS, /* Transformation state. */ + STATE_PROC, /* Procedure state. */ + STATE_ERROR /* Invalid state transition. */ + }; + +/* Command return values. */ +enum + { + CMD_FAILURE = 0x1000, /* Command not executed. */ + CMD_SUCCESS, /* Command successfully parsed and executed. */ + CMD_PART_SUCCESS_MAYBE, /* Command may have been partially executed. */ + CMD_PART_SUCCESS, /* Command fully executed up to error. */ + CMD_TRAILING_GARBAGE, /* Command followed by garbage. */ + }; + +extern int pgm_state; +extern const char *cur_proc; + +void cmd_init (void); +int cmd_parse (void); + +#endif /* !command_h */ diff --git a/src/compute.c b/src/compute.c new file mode 100644 index 00000000..c4ed544f --- /dev/null +++ b/src/compute.c @@ -0,0 +1,477 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "alloc.h" +#include "approx.h" +#include "cases.h" +#include "command.h" +#include "error.h" +#include "expr.h" +#include "lexer.h" +#include "str.h" +#include "var.h" +#include "vector.h" + +/* I can't think of any really good reason to disable debugging for + this module. */ +/*#undef DEBUGGING */ +#define DEBUGGING 1 +#include "debug-print.h" + +/* COMPUTE and IF transformation. */ +struct compute_trns + { + struct trns_header h; + + /* Destination. (Used only during parsing.) */ + struct variable *v; /* Destvar, if dest isn't a vector elem. */ + int created; /* Whether we created the destvar (used only during + parsing). */ + + /* Destination. (Used during execution.) */ + struct vector *vec; /* Destination vector, if dest is a vector elem. */ + int fv; /* `value' index of destination variable. */ + int width; /* Target variable width (string vars only). */ + + /* Expressions. */ + struct expression *vec_elem; /* Destination vector element expr. */ + struct expression *target; /* Target expression. */ + struct expression *test; /* Test expression (IF only). */ + }; + +static int parse_target_expression (struct compute_trns *, + int (*func_tab[4]) (struct trns_header *, struct ccase *)); +static struct compute_trns *new_trns (void); +static void delete_trns (struct compute_trns *); +static void free_trns (struct trns_header *); +static int parse_var_or_vec (struct compute_trns *); + +/* COMPUTE. */ + +static int compute_num (struct trns_header *, struct ccase *); +static int compute_str (struct trns_header *, struct ccase *); +static int compute_num_vec (struct trns_header *, struct ccase *); +static int compute_str_vec (struct trns_header *, struct ccase *); + +int +cmd_compute (void) +{ + /* Table of functions to process data. */ + static int (*func_tab[4]) (struct trns_header *, struct ccase *) = + { + compute_num, + compute_str, + compute_num_vec, + compute_str_vec, + }; + + /* Transformation being constructed. */ + struct compute_trns *c; + + lex_match_id ("COMPUTE"); + + c = new_trns (); + if (!parse_var_or_vec (c)) + goto fail; + + if (!lex_force_match ('=') + || !parse_target_expression (c, func_tab)) + goto fail; + + /* Goofy behavior, but compatible: Turn off LEAVE on the destvar. */ + if (c->v && c->v->left && c->v->name[0] != '#') + { + devector (c->v); + c->v->left = 0; + envector (c->v); + } + + add_transformation ((struct trns_header *) c); + + return CMD_SUCCESS; + +fail: + delete_trns (c); + return CMD_FAILURE; +} + +static int +compute_num (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + expr_evaluate (t->target, c, &c->data[t->fv]); + return -1; +} + +static int +compute_num_vec (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + /* Index into the vector. */ + union value index; + + /* Rounded index value. */ + int rindx; + + expr_evaluate (t->vec_elem, c, &index); + rindx = floor (index.f + EPSILON); + if (index.f == SYSMIS || rindx < 1 || rindx > t->vec->nv) + { + if (index.f == SYSMIS) + msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as " + "an index into vector %s."), t->vec->name); + else + msg (SW, _("When executing COMPUTE: %g is not a valid value as " + "an index into vector %s."), index.f, t->vec->name); + return -1; + } + expr_evaluate (t->target, c, &c->data[t->vec->v[rindx - 1]->fv]); + return -1; +} + +static int +compute_str (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + /* Temporary storage for string expression return value. */ + union value v; + + expr_evaluate (t->target, c, &v); + st_bare_pad_len_copy (c->data[t->fv].s, &v.c[1], t->width, v.c[0]); + return -1; +} + +static int +compute_str_vec (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + /* Temporary storage for string expression return value. */ + union value v; + + /* Index into the vector. */ + union value index; + + /* Rounded index value. */ + int rindx; + + /* Variable reference by indexed vector. */ + struct variable *vr; + + expr_evaluate (t->vec_elem, c, &index); + rindx = floor (index.f + EPSILON); + if (index.f == SYSMIS || rindx < 1 || rindx > t->vec->nv) + { + if (index.f == SYSMIS) + msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as " + "an index into vector %s."), t->vec->name); + else + msg (SW, _("When executing COMPUTE: %g is not a valid value as " + "an index into vector %s."), index.f, t->vec->name); + return -1; + } + + expr_evaluate (t->target, c, &v); + vr = t->vec->v[rindx - 1]; + st_bare_pad_len_copy (c->data[vr->fv].s, &v.c[1], vr->width, v.c[0]); + return -1; +} + +/* IF. */ + +static int if_num (struct trns_header *, struct ccase *); +static int if_str (struct trns_header *, struct ccase *); +static int if_num_vec (struct trns_header *, struct ccase *); +static int if_str_vec (struct trns_header *, struct ccase *); + +int +cmd_if (void) +{ + /* Table of functions to process data. */ + static int (*func_tab[4]) (struct trns_header *, struct ccase *) = + { + if_num, + if_str, + if_num_vec, + if_str_vec, + }; + + /* Transformation being constructed. */ + struct compute_trns *c; + + lex_match_id ("IF"); + c = new_trns (); + + /* Test expression. */ + c->test = expr_parse (PXP_BOOLEAN); + if (!c->test) + goto fail; + + /* Target variable. */ + if (!parse_var_or_vec (c)) + goto fail; + + /* Target expression. */ + + if (!lex_force_match ('=') + || !parse_target_expression (c, func_tab)) + goto fail; + + add_transformation ((struct trns_header *) c); + + return CMD_SUCCESS; + +fail: + delete_trns (c); + return CMD_FAILURE; +} + +static int +if_num (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + if (expr_evaluate (t->test, c, NULL) == 1.0) + expr_evaluate (t->target, c, &c->data[t->fv]); + return -1; +} + +static int +if_str (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + if (expr_evaluate (t->test, c, NULL) == 1.0) + { + union value v; + + expr_evaluate (t->target, c, &v); + st_bare_pad_len_copy (c->data[t->fv].s, &v.c[1], t->width, v.c[0]); + } + return -1; +} + +static int +if_num_vec (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + if (expr_evaluate (t->test, c, NULL) == 1.0) + { + /* Index into the vector. */ + union value index; + + /* Rounded index value. */ + int rindx; + + expr_evaluate (t->vec_elem, c, &index); + rindx = floor (index.f + EPSILON); + if (index.f == SYSMIS || rindx < 1 || rindx > t->vec->nv) + { + if (index.f == SYSMIS) + msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as " + "an index into vector %s."), t->vec->name); + else + msg (SW, _("When executing COMPUTE: %g is not a valid value as " + "an index into vector %s."), index.f, t->vec->name); + return -1; + } + expr_evaluate (t->target, c, + &c->data[t->vec->v[rindx]->fv]); + } + return -1; +} + +static int +if_str_vec (struct trns_header * pt, struct ccase * c) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + if (expr_evaluate (t->test, c, NULL) == 1.0) + { + /* Index into the vector. */ + union value index; + + /* Rounded index value. */ + int rindx; + + /* Temporary storage for result of target expression. */ + union value v2; + + /* Variable reference by indexed vector. */ + struct variable *vr; + + expr_evaluate (t->vec_elem, c, &index); + rindx = floor (index.f + EPSILON); + if (index.f == SYSMIS || rindx < 1 || rindx > t->vec->nv) + { + if (index.f == SYSMIS) + msg (SW, _("When executing COMPUTE: SYSMIS is not a valid value as " + "an index into vector %s."), t->vec->name); + else + msg (SW, _("When executing COMPUTE: %g is not a valid value as " + "an index into vector %s."), index.f, t->vec->name); + return -1; + } + expr_evaluate (t->target, c, &v2); + vr = t->vec->v[rindx - 1]; + st_bare_pad_len_copy (c->data[vr->fv].s, &v2.c[1], vr->width, v2.c[0]); + } + return -1; +} + +/* Code common to COMPUTE and IF. */ + +/* Checks for type mismatches on transformation C. Also checks for + command terminator, sets the case-handling proc from the array + passed. */ +static int +parse_target_expression (struct compute_trns *c, + int (*proc_list[4]) (struct trns_header *, struct ccase *)) +{ + int dest_type = c->v ? c->v->type : c->vec->v[0]->type; + c->target = expr_parse (dest_type == ALPHA ? PXP_STRING : PXP_NUMERIC); + if (!c->target) + return 0; + + c->h.proc = proc_list[(dest_type == ALPHA) + 2 * (c->vec != NULL)]; + + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + + return 1; +} + +/* Returns a new struct compute_trns after initializing its fields. */ +static struct compute_trns * +new_trns (void) +{ + struct compute_trns *c = xmalloc (sizeof *c); + c->h.proc = NULL; + c->h.free = free_trns; + c->v = NULL; + c->created = 0; + c->vec = NULL; + c->fv = 0; + c->width = 0; + c->vec_elem = NULL; + c->target = NULL; + c->test = NULL; + return c; +} + +/* Deletes all the fields in C, the variable C->v if we created it, + and C itself. */ +static void +delete_trns (struct compute_trns * c) +{ + free_trns ((struct trns_header *) c); + if (c->created) + delete_variable (&default_dict, c->v); + free (c); +} + +/* Deletes all the fields in C. */ +static void +free_trns (struct trns_header * pt) +{ + struct compute_trns *t = (struct compute_trns *) pt; + + expr_free (t->vec_elem); + expr_free (t->target); + expr_free (t->test); +} + +/* Parses a variable name or a vector element into C. If the + variable does not exist, it is created. Returns success. */ +static int +parse_var_or_vec (struct compute_trns * c) +{ + if (!lex_force_id ()) + return 0; + + if (lex_look_ahead () == '(') + { + /* Vector element. */ + c->vec = find_vector (tokid); + if (!c->vec) + { + msg (SE, _("There is no vector named %s."), tokid); + return 0; + } + + lex_get (); + if (!lex_force_match ('(')) + return 0; + c->vec_elem = expr_parse (PXP_NUMERIC); + if (!c->vec_elem) + return 0; + if (!lex_force_match (')')) + { + expr_free (c->vec_elem); + return 0; + } + } + else + { + /* Variable name. */ + c->v = find_variable (tokid); + if (!c->v) + { + c->v = force_create_variable (&default_dict, tokid, NUMERIC, 0); + envector (c->v); + c->created = 1; + } + c->fv = c->v->fv; + c->width = c->v->width; + lex_get (); + } + return 1; +} + +/* EVALUATE. */ + +#if GLOBAL_DEBUGGING +int +cmd_evaluate (void) +{ + struct expression *expr; + + lex_match_id ("EVALUATE"); + expr = expr_parse (PXP_DUMP); + if (!expr) + return CMD_FAILURE; + + expr_free (expr); + if (token != '.') + { + msg (SE, _("Extra characters after expression.")); + return CMD_FAILURE; + } + + return CMD_SUCCESS; +} +#endif diff --git a/src/correlations.q b/src/correlations.q new file mode 100644 index 00000000..6b708f64 --- /dev/null +++ b/src/correlations.q @@ -0,0 +1,166 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "alloc.h" +#include "file-handle.h" +#include "command.h" +#include "lexer.h" +#include "var.h" +/* (headers) */ + +#undef DEBUGGING +#define DEBUGGING 1 +#include "debug-print.h" + +struct cor_set + { + struct cor_set *next; + struct variable **v1, **v2; + int nv1, nv2; + }; + +struct cor_set *cor_list, *cor_last; + +struct file_handle *matrix_file; + +static void free_correlations_state (void); +static int internal_cmd_correlations (void); + +int +cmd_correlations (void) +{ + int result = internal_cmd_correlations (); + free_correlations_state (); + return result; +} + +/* (specification) + "CORRELATIONS" (cor_): + *variables=custom; + +missing=miss:!pairwise/listwise, + inc:include/exclude; + +print=tail:!twotail/onetail, + sig:!sig/nosig; + +format=fmt:!matrix/serial; + +matrix=custom; + +statistics[st_]=descriptives,xprod,all. +*/ +/* (declarations) */ +/* (functions) */ + +int +internal_cmd_correlations (void) +{ + struct cmd_correlations cmd; + + cor_list = cor_last = NULL; + matrix_file = NULL; + + lex_match_id ("PEARSON"); + lex_match_id ("CORRELATIONS"); + + if (!parse_correlations (&cmd)) + return CMD_FAILURE; + free_correlations (&cmd); + + return CMD_SUCCESS; +} + +static int +cor_custom_variables (struct cmd_correlations *cmd unused) +{ + struct variable **v1, **v2; + int nv1, nv2; + struct cor_set *cor; + + /* Ensure that this is a VARIABLES subcommand. */ + if (!lex_match_id ("VARIABLES") && (token != T_ID || !is_varname (tokid)) + && token != T_ALL) + return 2; + lex_match ('='); + + if (!parse_variables (&default_dict, &v1, &nv1, + PV_NO_DUPLICATE | PV_NUMERIC)) + return 0; + + if (lex_match (T_WITH)) + { + if (!parse_variables (&default_dict, &v2, &nv2, + PV_NO_DUPLICATE | PV_NUMERIC)) + { + free (v1); + return 0; + } + } + else + { + nv2 = nv1; + v2 = v1; + } + + cor = xmalloc (sizeof *cor); + cor->next = NULL; + cor->v1 = v1; + cor->v2 = v2; + cor->nv1 = nv1; + cor->nv2 = nv2; + if (cor_list) + cor_last = cor_last->next = cor; + else + cor_list = cor_last = cor; + + return 1; +} + +static int +cor_custom_matrix (struct cmd_correlations *cmd unused) +{ + if (!lex_force_match ('(')) + return 0; + + if (lex_match ('*')) + matrix_file = inline_file; + else + matrix_file = fh_parse_file_handle (); + + if (!matrix_file) + return 0; + + if (!lex_force_match (')')) + return 0; + + return 1; +} + +static void +free_correlations_state (void) +{ + struct cor_set *cor, *next; + + for (cor = cor_list; cor != NULL; cor = next) + { + next = cor->next; + if (cor->v1 != cor->v2) + free (cor->v2); + free (cor->v1); + free (cor); + } +} diff --git a/src/count.c b/src/count.c new file mode 100644 index 00000000..25469665 --- /dev/null +++ b/src/count.c @@ -0,0 +1,641 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +/* Implementation details: + + The S?SS manuals do not specify the order that COUNT subcommands are + performed in. Experiments, however, have shown that they are performed + in the order that they are specified in, rather than simultaneously. + So, with the two variables A and B, and the two cases, + + A B + 1 2 + 2 1 + + the command COUNT A=A B (1) / B=A B (2) will produce the following + results, + + A B + 1 1 + 1 0 + + rather than the results that would be produced if subcommands were + simultaneous: + + A B + 1 1 + 1 1 + + Perhaps simultaneity could be implemented as an option. On the + other hand, what good are the above commands? */ + +#undef DEBUGGING +#define DEBUGGING 1 +#include "debug-print.h" + +/* Definitions. */ + +enum + { + CNT_ERROR, /* Invalid value. */ + CNT_SINGLE, /* Single value. */ + CNT_HIGH, /* x >= a. */ + CNT_LOW, /* x <= a. */ + CNT_RANGE, /* a <= x <= b. */ + CNT_ANY, /* Count any. */ + CNT_SENTINEL /* List terminator. */ + }; + +struct cnt_num + { + int type; + double a, b; + }; + +struct cnt_str + { + int type; + char *s; + }; + +struct counting + { + struct counting *next; + + /* variables to count */ + struct variable **v; + int n; + + /* values to count */ + int missing; /* (numeric only) + 0=don't count missing, + 1=count SYSMIS, + 2=count system- and user-missing */ + union /* Criterion values. */ + { + struct cnt_num *n; + struct cnt_str *s; + } + crit; + }; + +struct cnt_var_info + { + struct cnt_var_info *next; + + struct variable *d; /* Destination variable. */ + char n[9]; /* Name of dest var. */ + + struct counting *c; /* The counting specifications. */ + }; + +struct count_trns + { + struct trns_header h; + struct cnt_var_info *specs; + }; + +#if DEBUGGING +static void debug_print (void); +#endif + +/* First counting in chain. */ +static struct cnt_var_info *head; + +/* Parser. */ + +static int count_trns_proc (struct trns_header *, struct ccase *); +static void count_trns_free (struct trns_header *); + +static int parse_numeric_criteria (struct counting *); +static int parse_string_criteria (struct counting *); + +int cmd_count (void); + +int +internal_cmd_count (void) +{ + int code = cmd_count (); + if (!code) + { + struct count_trns c; + c.specs = head; + count_trns_free ((struct trns_header *) & c); + } + return code; +} + +int +cmd_count (void) +{ + /* Specification currently being parsed. */ + struct cnt_var_info *cnt; + + /* Counting currently being parsed. */ + struct counting *c; + + /* Return value from parsing function. */ + int ret; + + /* Transformation. */ + struct count_trns *trns; + + lex_match_id ("COUNT"); + + /* Parses each slash-delimited specification. */ + head = cnt = xmalloc (sizeof *cnt); + for (;;) + { + /* Initialize this struct cnt_var_info to ensure proper cleanup. */ + cnt->next = NULL; + cnt->d = NULL; + cnt->c = NULL; + + /* Get destination struct variable, or at least its name. */ + if (!lex_force_id ()) + goto fail; + cnt->d = find_variable (tokid); + if (cnt->d) + { + if (cnt->d->type == ALPHA) + { + msg (SE, _("Destination cannot be a string variable.")); + goto fail; + } + } + else + strcpy (cnt->n, tokid); + + lex_get (); + if (!lex_force_match ('=')) + goto fail; + + c = cnt->c = xmalloc (sizeof *c); + for (;;) + { + c->next = NULL; + c->v = NULL; + if (!parse_variables (NULL, &c->v, &c->n, PV_DUPLICATE | PV_SAME_TYPE)) + goto fail; + + if (!lex_force_match ('(')) + goto fail; + + ret = (c->v[0]->type == NUMERIC + ? parse_numeric_criteria + : parse_string_criteria) (c); + if (!ret) + goto fail; + + if (token == '/' || token == '.') + break; + + c = c->next = xmalloc (sizeof *c); + } + + if (token == '.') + break; + + if (!lex_force_match ('/')) + goto fail; + cnt = cnt->next = xmalloc (sizeof *cnt); + } + + /* Create all the nonexistent destination variables. */ + for (cnt = head; cnt; cnt = cnt->next) + if (!cnt->d) + { + /* It's legal, though motivationally questionable, to count to + the same dest var more than once. */ + cnt->d = find_variable (cnt->n); + + if (!cnt->d) + cnt->d = force_create_variable (&default_dict, cnt->n, NUMERIC, 0); + } + +#if DEBUGGING + debug_print (); +#endif + + trns = xmalloc (sizeof *trns); + trns->h.proc = count_trns_proc; + trns->h.free = count_trns_free; + trns->specs = head; + add_transformation ((struct trns_header *) trns); + + return CMD_SUCCESS; + +fail: + { + struct count_trns t; + t.specs = head; + count_trns_free ((struct trns_header *) & t); + return CMD_FAILURE; + } +} + +/* Parses a set of numeric criterion values. */ +static int +parse_numeric_criteria (struct counting * c) +{ + int n = 0; + int m = 0; + + c->crit.n = 0; + c->missing = 0; + for (;;) + { + struct cnt_num *cur; + if (n >= m - 1) + { + m += 16; + c->crit.n = xrealloc (c->crit.n, m * sizeof (struct cnt_num)); + } + + cur = &c->crit.n[n++]; + if (token == T_NUM) + { + cur->a = tokval; + lex_get (); + if (lex_match_id ("THRU")) + { + if (token == T_NUM) + { + if (!lex_force_num ()) + return 0; + cur->b = tokval; + cur->type = CNT_RANGE; + lex_get (); + + if (cur->a > cur->b) + { + msg (SE, _("%g THRU %g is not a valid range. The " + "number following THRU must be at least " + "as big as the number preceding THRU."), + cur->a, cur->b); + return 0; + } + } + else if (lex_match_id ("HI") || lex_match_id ("HIGHEST")) + cur->type = CNT_HIGH; + else + { + lex_error (NULL); + return 0; + } + } + else + cur->type = CNT_SINGLE; + } + else if (lex_match_id ("LO") || lex_match_id ("LOWEST")) + { + if (!lex_force_match_id ("THRU")) + return 0; + if (token == T_NUM) + { + cur->type = CNT_LOW; + cur->a = tokval; + lex_get (); + } + else if (lex_match_id ("HI") || lex_match_id ("HIGHEST")) + cur->type = CNT_ANY; + else + { + lex_error (NULL); + return 0; + } + } + else if (lex_match_id ("SYSMIS")) + { + if (c->missing < 1) + c->missing = 1; + } + else if (lex_match_id ("MISSING")) + c->missing = 2; + else + { + lex_error (NULL); + return 0; + } + + lex_match (','); + if (lex_match (')')) + break; + } + + c->crit.n[n].type = CNT_SENTINEL; + return 1; +} + +/* Parses a set of string criteria values. The skeleton is the same + as parse_numeric_criteria(). */ +static int +parse_string_criteria (struct counting * c) +{ + int len = 0; + + int n = 0; + int m = 0; + + int i; + + for (i = 0; i < c->n; i++) + if (c->v[i]->width > len) + len = c->v[i]->width; + + c->crit.n = 0; + for (;;) + { + struct cnt_str *cur; + if (n >= m - 1) + { + m += 16; + c->crit.n = xrealloc (c->crit.n, m * sizeof (struct cnt_str)); + } + + if (!lex_force_string ()) + return 0; + cur = &c->crit.s[n++]; + cur->type = CNT_SINGLE; + cur->s = malloc (len + 1); + st_pad_copy (cur->s, ds_value (&tokstr), len + 1); + lex_get (); + + lex_match (','); + if (lex_match (')')) + break; + } + + c->crit.s[n].type = CNT_SENTINEL; + return 1; +} + +/* Transformation. */ + +/* Counts the number of values in case C matching counting CNT. */ +static inline int +count_numeric (struct counting * cnt, struct ccase * c) +{ + int counter = 0; + + struct cnt_num *num; + + double cmp; + int i; + + for (i = 0; i < cnt->n; i++) + { + /* Extract the variable value and eliminate missing values. */ + cmp = c->data[cnt->v[i]->fv].f; + if (cmp == SYSMIS) + { + if (cnt->missing >= 1) + counter++; + continue; + } + if (cnt->missing >= 2 && is_num_user_missing (cmp, cnt->v[i])) + { + counter++; + continue; + } + + /* Try to find the value in the list. */ + for (num = cnt->crit.n;; num++) + switch (num->type) + { + case CNT_ERROR: + assert (0); + break; + case CNT_SINGLE: + if (approx_ne (cmp, num->a)) + break; + counter++; + goto done; + case CNT_HIGH: + if (approx_lt (cmp, num->a)) + break; + counter++; + goto done; + case CNT_LOW: + if (approx_gt (cmp, num->a)) + break; + counter++; + goto done; + case CNT_RANGE: + if (approx_lt (cmp, num->a) || approx_gt (cmp, num->b)) + break; + counter++; + goto done; + case CNT_ANY: + counter++; + goto done; + case CNT_SENTINEL: + goto done; + default: + assert (0); + } + done: ; + } + return counter; +} + +/* Counts the number of values in case C matching counting CNT. */ +static inline int +count_string (struct counting * cnt, struct ccase * c) +{ + int counter = 0; + + struct cnt_str *str; + + char *cmp; + int len; + + int i; + + for (i = 0; i < cnt->n; i++) + { + /* Extract the variable value, variable width. */ + cmp = c->data[cnt->v[i]->fv].s; + len = cnt->v[i]->width; + + for (str = cnt->crit.s;; str++) + switch (str->type) + { + case CNT_ERROR: + assert (0); + case CNT_SINGLE: + if (memcmp (cmp, str->s, len)) + break; + counter++; + goto done; + case CNT_SENTINEL: + goto done; + default: + assert (0); + } + done: ; + } + return counter; +} + +/* Performs the COUNT transformation T on case C. */ +static int +count_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct cnt_var_info *info; + struct counting *cnt; + int counter; + + for (info = ((struct count_trns *) trns)->specs; info; info = info->next) + { + counter = 0; + for (cnt = info->c; cnt; cnt = cnt->next) + if (cnt->v[0]->type == NUMERIC) + counter += count_numeric (cnt, c); + else + counter += count_string (cnt, c); + c->data[info->d->fv].f = counter; + } + return -1; +} + +/* Destroys all dynamic data structures associated with T. */ +static void +count_trns_free (struct trns_header * t) +{ + struct cnt_var_info *iter, *next; + + for (iter = ((struct count_trns *) t)->specs; iter; iter = next) + { + struct counting *i, *n; + + for (i = iter->c; i; i = n) + { + if (i->n && i->v) + { + if (i->v[0]->type == NUMERIC) + free (i->crit.n); + else + { + struct cnt_str *s; + + for (s = i->crit.s; s->type != CNT_SENTINEL; s++) + free (s->s); + free (i->crit.s); + } + } + free (i->v); + + n = i->next; + free (i); + } + + next = iter->next; + free (iter); + } +} + +/* Debugging. */ + +#if DEBUGGING +static void +debug_print (void) +{ + struct cnt_var_info *iter; + struct counting *i; + int j; + + printf ("COUNT\n"); + for (iter = head; iter; iter = iter->next) + { + printf (" %s=", iter->d->name); + for (i = iter->c; i; i = i->next) + { + for (j = 0; j < i->n; j++) + printf ("%s%s", j ? " " : "", i->v[j]->name); + printf (" ("); + if (i->v[0]->type == NUMERIC) + { + struct cnt_num *n; + + if (i->missing == 2) + printf ("MISSING"); + else if (i->missing == 1) + printf ("SYSMIS"); + else + assert (i->missing == 0); + + for (n = i->crit.n; n->type != CNT_SENTINEL; n++) + { + if (i->missing && n != i->crit.n) + printf (","); + switch (n->type) + { + case CNT_SINGLE: + printf ("%g", n->a); + break; + case CNT_HIGH: + printf ("%g THRU HIGH", n->a); + break; + case CNT_LOW: + printf ("LOW THRU %g", n->a); + break; + case CNT_RANGE: + printf ("%g THRU %g", n->a, n->b); + break; + case CNT_ANY: + printf ("LOW THRU HIGH"); + break; + default: + printf ("", n->type); + break; + } + } + } + else + { + struct cnt_str *s; + + for (s = i->crit.s; s->type != CNT_SENTINEL; s++) + { + if (s != i->crit.s) + printf (","); + if (s->type == CNT_SINGLE) + printf ("'%s'", s->s); + else + printf ("", s->type); + } + } + printf (") "); + } + printf ("\n"); + } +} +#endif /* DEBUGGING */ diff --git a/src/crosstabs.q b/src/crosstabs.q new file mode 100644 index 00000000..5ea9a1d5 --- /dev/null +++ b/src/crosstabs.q @@ -0,0 +1,3311 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* FIXME: + + - Pearson's R (but not Spearman!) is off a little. + - T values for Spearman's R and Pearson's R are wrong. + - How to calculate significance of symmetric and directional measures? + - Asymmetric ASEs and T values for lambda are wrong. + - ASE of Goodman and Kruskal's tau is not calculated. + - ASE of symmetric somers' d is wrong. + - Approx. T of uncertainty coefficient is wrong. + +*/ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "hash.h" +#include "pool.h" +#include "dcdflib/cdflib.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "magic.h" +#include "misc.h" +#include "stats.h" +#include "output.h" +#include "tab.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* (specification) + crosstabs (crs_): + *tables=custom; + +variables=custom; + +missing=miss:!table/include/report; + +write[wr_]=none,cells,all; + +format=fmt:!labels/nolabels/novallabs, + val:!avalue/dvalue, + indx:!noindex/index, + tabl:!tables/notables, + box:!box/nobox, + pivot:!pivot/nopivot; + +cells[cl_]=count,none,row,column,total,expected,residual,sresidual, + asresidual,all; + +statistics[st_]=chisq,phi,cc,lambda,uc,none,btau,ctau,risk,gamma,d, + kappa,eta,corr,all. +*/ +/* (declarations) */ +/* (functions) */ + +/* Number of chi-square statistics. */ +#define N_CHISQ 5 + +/* Number of symmetric statistics. */ +#define N_SYMMETRIC 9 + +/* Number of directional statistics. */ +#define N_DIRECTIONAL 13 + +/* A single table entry for general mode. */ +struct table_entry + { + int table; /* Flattened table number. */ + union + { + double freq; /* Frequency count. */ + double *data; /* Crosstabulation table for integer mode. */ + } + u; + union value v[1]; /* Values. */ + }; + +/* A crosstabulation. */ +struct crosstab + { + int nvar; /* Number of variables. */ + double missing; /* Missing cases count. */ + int ofs; /* Integer mode: Offset into sorted_tab[]. */ + struct variable *v[2]; /* At least two variables; sorted by + larger indices first. */ + }; + +/* Indexes into crosstab.v. */ +enum + { + ROW_VAR = 0, + COL_VAR = 1 + }; + +/* General mode crosstabulation table. */ +static struct hsh_table *gen_tab; /* Hash table. */ +static int n_sorted_tab; /* Number of entries in sorted_tab. */ +static struct table_entry **sorted_tab; /* Sorted table. */ + +/* VARIABLES dictionary. */ +static struct dictionary *var_dict; + +/* TABLES. */ +static struct crosstab **xtab; +static int nxtab; + +/* Integer or general mode? */ +enum + { + INTEGER, + GENERAL + }; +static int mode; + +/* CELLS. */ +static int num_cells; /* Number of cells requested. */ +static int cells[8]; /* Cells requested. */ +static int expected; /* Nonzero if expected value is needed. */ + +/* WRITE. */ +static int write; /* One of WR_* that specifies the WRITE style. */ + +/* Command parsing info. */ +static struct cmd_crosstabs cmd; + +/* Pools. */ +static struct pool *pl_tc; /* For table cells. */ +static struct pool *pl_col; /* For column data. */ + +static int internal_cmd_crosstabs (void); +static void free_var_dict (void); +static void precalc (void); +static int calc_general (struct ccase *); +static int calc_integer (struct ccase *); +static void postcalc (void); +static void submit (struct tab_table *); + +#if DEBUGGING +static void debug_print (void); +static void print_table_entries (struct table_entry **tab); +#endif + +/* Parse and execute CROSSTABS, then clean up. */ +int +cmd_crosstabs (void) +{ + int result = internal_cmd_crosstabs (); + + free_var_dict (); + pool_destroy (pl_tc); + pool_destroy (pl_col); + + return result; +} + +/* Parses and executes the CROSSTABS procedure. */ +static int +internal_cmd_crosstabs (void) +{ + var_dict = NULL; + xtab = NULL; + nxtab = 0; + pl_tc = pool_create (); + pl_col = pool_create (); + + lex_match_id ("CROSSTABS"); + if (!parse_crosstabs (&cmd)) + return CMD_FAILURE; + +#if DEBUGGING + /* Needs var_dict. */ + debug_print (); +#endif + + mode = var_dict ? INTEGER : GENERAL; + free_var_dict(); + + /* CELLS. */ + expected = 0; + if (!cmd.sbc_cells) + { + cmd.a_cells[CRS_CL_COUNT] = 1; + num_cells = 1; + } + else + { + int i; + int count = 0; + + for (i = 0; i < CRS_CL_count; i++) + if (cmd.a_cells[i]) + count++; + if (count == 0) + { + cmd.a_cells[CRS_CL_COUNT] = 1; + cmd.a_cells[CRS_CL_ROW] = 1; + cmd.a_cells[CRS_CL_COLUMN] = 1; + cmd.a_cells[CRS_CL_TOTAL] = 1; + } + if (cmd.a_cells[CRS_CL_ALL]) + { + for (i = 0; i < CRS_CL_count; i++) + cmd.a_cells[i] = 1; + cmd.a_cells[CRS_CL_ALL] = 0; + } + cmd.a_cells[CRS_CL_NONE] = 0; + for (num_cells = i = 0; i < CRS_CL_count; i++) + if (cmd.a_cells[i]) + { + if (i >= CRS_CL_EXPECTED) + expected = 1; + cmd.a_cells[num_cells++] = i; + } + } + + /* STATISTICS. */ + if (cmd.sbc_statistics) + { + int i; + int count = 0; + + for (i = 0; i < CRS_ST_count; i++) + if (cmd.a_statistics[i]) + count++; + if (count == 0) + cmd.a_statistics[CRS_ST_CHISQ] = 1; + if (cmd.a_statistics[CRS_ST_ALL]) + for (i = 0; i < CRS_ST_count; i++) + cmd.a_statistics[i] = 1; + } + + /* MISSING. */ + if (cmd.miss == CRS_REPORT && mode == GENERAL) + { + msg (SE, _("Missing mode REPORT not allowed in general mode. " + "Assuming MISSING=TABLE.")); + cmd.miss = CRS_TABLE; + } + + /* WRITE. */ + if (cmd.a_write[CRS_WR_ALL] && cmd.a_write[CRS_WR_CELLS]) + cmd.a_write[CRS_WR_ALL] = 0; + if (cmd.a_write[CRS_WR_ALL] && mode == GENERAL) + { + msg (SE, _("Write mode ALL not allowed in general mode. " + "Assuming WRITE=CELLS.")); + cmd.a_write[CRS_WR_CELLS] = 1; + } + if (cmd.sbc_write + && (cmd.a_write[CRS_WR_NONE] + + cmd.a_write[CRS_WR_ALL] + + cmd.a_write[CRS_WR_CELLS] == 0)) + cmd.a_write[CRS_WR_CELLS] = 1; + if (cmd.a_write[CRS_WR_CELLS]) + write = CRS_WR_CELLS; + else if (cmd.a_write[CRS_WR_ALL]) + write = CRS_WR_ALL; + else + write = CRS_WR_NONE; + + update_weighting (&default_dict); + procedure (precalc, mode == GENERAL ? calc_general : calc_integer, postcalc); + + return CMD_SUCCESS; +} + +/* Frees var_dict once it's no longer needed. */ +static void +free_var_dict (void) +{ + if (!var_dict) + return; + + { + int i; + + if (var_dict->var_by_name) + { + avl_destroy (var_dict->var_by_name, NULL); + var_dict->var_by_name = NULL; + } + + for (i = 0; i < var_dict->nvar; i++) + free (var_dict->var[i]); + free (var_dict->var); + var_dict->var = NULL; + var_dict->nvar = 0; + + free_dictionary (var_dict); + + var_dict = NULL; + } +} + +/* Parses the TABLES subcommand. */ +static int +crs_custom_tables (struct cmd_crosstabs *cmd unused) +{ + struct dictionary *dict; + int n_by; + struct variable ***by = NULL; + int *by_nvar = NULL; + int nx = 1; + int success = 0; + + /* Ensure that this is a TABLES subcommand. */ + if (!lex_match_id ("TABLES") + && (token != T_ID || !is_varname (tokid)) + && token != T_ALL) + return 2; + lex_match ('='); + + dict = var_dict ? var_dict : &default_dict; + + for (n_by = 0; ;) + { + by = xrealloc (by, sizeof *by * (n_by + 1)); + by_nvar = xrealloc (by_nvar, sizeof *by_nvar * (n_by + 1)); + if (!parse_variables (dict, &by[n_by], &by_nvar[n_by], + PV_NO_DUPLICATE | PV_NO_SCRATCH)) + goto lossage; + nx *= by_nvar[n_by]; + n_by++; + + if (!lex_match (T_BY)) + { + if (n_by < 1) + { + lex_error (_("expecting BY")); + goto lossage; + } + else + break; + } + } + + { + int *by_iter = xcalloc (sizeof *by_iter * n_by); + int i; + + xtab = xrealloc (xtab, sizeof *xtab * (nxtab + nx)); + for (i = 0; i < nx; i++) + { + struct crosstab *x; + + x = xmalloc (sizeof *x + sizeof (struct variable *) * (n_by - 2)); + x->nvar = n_by; + x->missing = 0.; + + { + int i; + + if (var_dict == NULL) + for (i = 0; i < n_by; i++) + x->v[i] = by[i][by_iter[i]]; + else + for (i = 0; i < n_by; i++) + x->v[i] = default_dict.var[by[i][by_iter[i]]->foo]; + } + + { + int i; + + for (i = n_by - 1; i >= 0; i--) + { + if (++by_iter[i] < by_nvar[i]) + break; + by_iter[i] = 0; + } + } + + xtab[nxtab++] = x; + } + free (by_iter); + } + + success = 1; + /* Despite the name, we come here whether we're successful or + not. */ + lossage: + { + int i; + + for (i = 0; i < n_by; i++) + free (by[i]); + free (by); + free (by_nvar); + } + + return success; +} + +/* Parses the VARIABLES subcommand. */ +static int +crs_custom_variables (struct cmd_crosstabs *cmd unused) +{ + struct variable **v = NULL; + int nv = 0; + + if (nxtab) + { + msg (SE, _("VARIABLES must be specified before TABLES.")); + return 0; + } + + lex_match ('='); + + for (;;) + { + int orig_nv = nv; + int i; + + long min, max; + + if (!parse_variables (&default_dict, &v, &nv, + (PV_APPEND | PV_NUMERIC + | PV_NO_DUPLICATE | PV_NO_SCRATCH))) + return 0; + + if (token != '(') + { + lex_error ("expecting `('"); + goto lossage; + } + lex_get (); + + if (!lex_force_int ()) + goto lossage; + min = lex_integer (); + lex_get (); + + lex_match (','); + + if (!lex_force_int ()) + goto lossage; + max = lex_integer (); + if (max < min) + { + msg (SE, _("Maximum value (%ld) less than minimum value (%ld)."), + max, min); + goto lossage; + } + lex_get (); + + if (token != ')') + { + lex_error ("expecting `)'"); + goto lossage; + } + lex_get (); + + for (i = orig_nv; i < nv; i++) + { + v[i]->p.crs.min = min; + v[i]->p.crs.max = max + 1.; + v[i]->p.crs.count = max - min + 1; + } + + if (token == '/') + break; + } + + { + int i; + + var_dict = new_dictionary (0); + var_dict->var = xmalloc (sizeof *var_dict->var * nv); + var_dict->nvar = nv; + for (i = 0; i < nv; i++) + { + struct variable *var = xmalloc (offsetof (struct variable, width)); + strcpy (var->name, v[i]->name); + var->index = i; + var->type = v[i]->type; + var->foo = v[i]->index; + var_dict->var[i] = var; + avl_force_insert (var_dict->var_by_name, var); + } + + free (v); + return 1; + } + + lossage: + free (v); + return 0; +} + +#if DEBUGGING +static void +debug_print (void) +{ + printf ("CROSSTABS\n"); + + if (var_dict) + { + int i; + + printf ("\t/VARIABLES="); + for (i = 0; i < var_dict->nvar; i++) + { + struct variable *v = var_dict->var[i]; + struct variable *iv = default_dict.var[v->foo]; + + printf ("%s ", v->name); + if (i < var_dict->nvar - 1) + { + struct variable *nv = var_dict->var[i + 1]; + struct variable *niv = default_dict.var[nv->foo]; + + if (iv->p.crs.min == niv->p.crs.min + && iv->p.crs.max == niv->p.crs.max) + continue; + } + printf ("(%d,%d) ", iv->p.crs.min, iv->p.crs.max - 1); + } + printf ("\n"); + } + + { + int i; + + printf ("\t/TABLES="); + for (i = 0; i < nxtab; i++) + { + struct crosstab *x = xtab[i]; + int j; + + if (i) + printf("\t\t"); + for (j = 0; j < x->nvar; j++) + { + if (j) + printf (" BY "); + printf ("%s", x->v[j]->name); + } + printf ("\n"); + } + } +} +#endif /* DEBUGGING */ + +/* Data file processing. */ + +static int compare_table_entry (const void *, const void *, void *); +static unsigned hash_table_entry (const void *, void *); + +/* Set up the crosstabulation tables for processing. */ +static void +precalc (void) +{ + if (mode == GENERAL) + { + gen_tab = hsh_create (512, compare_table_entry, hash_table_entry, + NULL, NULL); + } + else + { + int i; + + sorted_tab = NULL; + n_sorted_tab = 0; + + for (i = 0; i < nxtab; i++) + { + struct crosstab *x = xtab[i]; + int count = 1; + int *v; + int j; + + x->ofs = n_sorted_tab; + + for (j = 2; j < x->nvar; j++) + count *= x->v[j - 2]->p.crs.count; + + sorted_tab = xrealloc (sorted_tab, + sizeof *sorted_tab * (n_sorted_tab + count)); + v = local_alloc (sizeof *v * x->nvar); + for (j = 2; j < x->nvar; j++) + v[j] = x->v[j]->p.crs.min; + for (j = 0; j < count; j++) + { + struct table_entry *te; + int k; + + te = sorted_tab[n_sorted_tab++] + = xmalloc (sizeof *te + sizeof (union value) * (x->nvar - 1)); + te->table = i; + + { + const int mat_size = (x->v[0]->p.crs.count + * x->v[1]->p.crs.count); + int m; + + te->u.data = xmalloc (sizeof *te->u.data * mat_size); + for (m = 0; m < mat_size; m++) + te->u.data[m] = 0.; + } + + for (k = 2; k < x->nvar; k++) + te->v[k].f = v[k]; + for (k = 2; k < x->nvar; k++) + if (++v[k] >= x->v[k]->p.crs.max) + v[k] = x->v[k]->p.crs.min; + else + break; + } + local_free (v); + } + + sorted_tab = xrealloc (sorted_tab, + sizeof *sorted_tab * (n_sorted_tab + 1)); + sorted_tab[n_sorted_tab] = NULL; + } +} + +/* Form crosstabulations for general mode. */ +static int +calc_general (struct ccase *c) +{ + /* Case weight. */ + double w = (default_dict.weight_index != -1 + ? c->data[default_dict.var[default_dict.weight_index]->fv].f + : 1.0); + + /* Flattened current table index. */ + int t; + + for (t = 0; t < nxtab; t++) + { + struct crosstab *x = xtab[t]; + const size_t entry_size = (sizeof (struct table_entry) + + sizeof (union value) * (x->nvar - 1)); + struct table_entry *te = local_alloc (entry_size); + + /* Construct table entry for the current record and table. */ + te->table = t; + { + int j; + + assert (x != NULL); + for (j = 0; j < x->nvar; j++) + { + if ((cmd.miss == CRS_TABLE + && is_missing (&c->data[x->v[j]->fv], x->v[j])) + || (cmd.miss == CRS_INCLUDE + && is_system_missing (&c->data[x->v[j]->fv], x->v[j]))) + { + x->missing += w; + goto next_crosstab; + } + + if (x->v[j]->type == NUMERIC) + te->v[j].f = c->data[x->v[j]->fv].f; + else + { + memcpy (te->v[j].s, c->data[x->v[j]->fv].s, x->v[j]->width); + + /* Necessary in order to simplify comparisons. */ + memset (&te->v[j].s[x->v[j]->width], 0, + sizeof (union value) - x->v[j]->width); + } + } + } + + /* Add record to hash table. */ + { + struct table_entry **tepp = (struct table_entry **) hsh_probe (gen_tab, te); + if (NULL == *tepp) + { + struct table_entry *tep = pool_alloc (pl_tc, entry_size); + + te->u.freq = w; + memcpy (tep, te, entry_size); + + *tepp = tep; + } + else + (*tepp)->u.freq += w; + } + + next_crosstab: + local_free (te); + } + + return 1; +} + +static int +calc_integer (struct ccase *c) +{ + /* Case weight. */ + double w = (default_dict.weight_index != -1 + ? c->data[default_dict.var[default_dict.weight_index]->fv].f + : 1.0); + + /* Flattened current table index. */ + int t; + + for (t = 0; t < nxtab; t++) + { + struct crosstab *x = xtab[t]; + int i, fact, ofs; + + fact = i = 1; + ofs = x->ofs; + for (i = 0; i < x->nvar; i++) + { + struct variable *const v = x->v[i]; + double value = c->data[v->fv].f; + + /* Note that the first test also rules out SYSMIS. */ + if ((value < v->p.crs.min || value >= v->p.crs.max) + || (cmd.miss == CRS_TABLE && is_num_user_missing (value, v))) + { + x->missing += w; + goto next_crosstab; + } + + if (i > 1) + { + ofs += fact * ((int) value - v->p.crs.min); + fact *= v->p.crs.count; + } + } + + { + const int row = c->data[x->v[ROW_VAR]->fv].f - x->v[ROW_VAR]->p.crs.min; + const int col = c->data[x->v[COL_VAR]->fv].f - x->v[COL_VAR]->p.crs.min; + const int col_dim = x->v[COL_VAR]->p.crs.count; + + sorted_tab[ofs]->u.data[col + row * col_dim] += w; + } + + next_crosstab: ; + } + + return 1; +} + +#if DEBUGGING +/* Print out all table entries in NULL-terminated TAB for use by a + debugger (a person, not a program). */ +static void +print_table_entries (struct table_entry **tab) +{ + printf ("raw crosstabulation data:\n"); + for (; *tab; tab++) + { + const struct crosstab *x = xtab[(*tab)->table]; + int i; + + printf ("(%g) table:%d ", (*tab)->u.freq, (*tab)->table); + for (i = 0; i < x->nvar; i++) + { + if (i) + printf (", "); + printf ("%s:", x->v[i]->name); + + if (x->v[i]->type == NUMERIC) + printf ("%g", (*tab)->v[i].f); + else + printf ("%.*s", x->v[i]->width, (*tab)->v[i].s); + } + printf ("\n"); + } + fflush (stdout); +} +#endif + +/* Compare the table_entry's at PA and PB and return a strcmp()-type + result. */ +static int +compare_table_entry (const void *pa, const void *pb, void *foo unused) +{ + const struct table_entry *a = pa; + const struct table_entry *b = pb; + + { + const int difftable = a->table - b->table; + if (difftable) + return difftable; + } + + { + const struct crosstab *x = xtab[a->table]; + int i; + + for (i = x->nvar - 1; i >= 0; i--) + if (x->v[i]->type == NUMERIC) + { + const double diffnum = a->v[i].f - b->v[i].f; + if (diffnum < 0) + return -1; + else if (diffnum > 0) + return 1; + } + else + { + assert (x->v[i]->type == ALPHA); + { + const int diffstr = strncmp (a->v[i].s, b->v[i].s, x->v[i]->width); + if (diffstr) + return diffstr; + } + } + } + + return 0; +} + +/* Calculate a hash value from table_entry PA. */ +static unsigned +hash_table_entry (const void *pa, void *foo unused) +{ + const struct table_entry *a = pa; + unsigned long hash = a->table; + int i; + + /* Hash formula from _SPSS Statistical Algorithms_. */ + for (i = 0; i < xtab[a->table]->nvar; i++) + { + hash = (hash << 3) | (hash >> (CHAR_BIT * SIZEOF_LONG - 3)); + hash ^= a->v[i].hash[0]; +#if SIZEOF_DOUBLE / SIZEOF_LONG > 1 + hash ^= a->v[i].hash[1]; +#endif + } + + return hash; +} + +/* Post-data reading calculations. */ + +static struct table_entry **find_pivot_extent (struct table_entry **, int *cnt, int pivot); +static void enum_var_values (struct table_entry **beg, int cnt, + union value **values, int *nvalues, + int var_index); +static void output_pivot_table (struct table_entry **, struct table_entry **, + double **, double **, double **, + int *, int *, int *); +static void make_summary_table (void); + +static void +postcalc (void) +{ + if (mode == GENERAL) + { + n_sorted_tab = hsh_count (gen_tab); + sorted_tab = (struct table_entry **) hsh_sort (gen_tab, compare_table_entry); +#if DEBUGGING + print_table_entries (sorted_tab); +#endif + } + + make_summary_table (); + + /* Identify all the individual crosstabulation tables, and deal with + them. */ + { + struct table_entry **pb = sorted_tab, **pe; /* Pivot begin, pivot end. */ + int pc = n_sorted_tab; /* Pivot count. */ + + double *mat = NULL, *row_tot = NULL, *col_tot = NULL; + int maxrows = 0, maxcols = 0, maxcells = 0; + + for (;;) + { + pe = find_pivot_extent (pb, &pc, cmd.pivot == CRS_PIVOT); + if (pe == NULL) + break; + + output_pivot_table (pb, pe, &mat, &row_tot, &col_tot, + &maxrows, &maxcols, &maxcells); + + pb = pe; + } + free (mat); + free (row_tot); + free (col_tot); + } + + hsh_destroy (gen_tab); +} + +static void insert_summary (struct tab_table *, int tab_index, double valid); + +/* Output a table summarizing the cases processed. */ +static void +make_summary_table (void) +{ + struct tab_table *summary; + + struct table_entry **pb = sorted_tab, **pe; + int pc = n_sorted_tab; + int cur_tab = 0; + + summary = tab_create (7, 3 + nxtab, 1); + tab_title (summary, 0, _("Summary.")); + tab_headers (summary, 1, 0, 3, 0); + tab_joint_text (summary, 1, 0, 6, 0, TAB_CENTER, _("Cases")); + tab_joint_text (summary, 1, 1, 2, 1, TAB_CENTER, _("Valid")); + tab_joint_text (summary, 3, 1, 4, 1, TAB_CENTER, _("Missing")); + tab_joint_text (summary, 5, 1, 6, 1, TAB_CENTER, _("Total")); + tab_hline (summary, TAL_1, 1, 6, 1); + tab_hline (summary, TAL_1, 1, 6, 2); + tab_vline (summary, TAL_1, 3, 1, 1); + tab_vline (summary, TAL_1, 5, 1, 1); + { + int i; + + for (i = 0; i < 3; i++) + { + tab_text (summary, 1 + i * 2, 2, TAB_RIGHT, _("N")); + tab_text (summary, 2 + i * 2, 2, TAB_RIGHT, _("Percent")); + } + } + tab_offset (summary, 0, 3); + + for (;;) + { + double valid; + + pe = find_pivot_extent (pb, &pc, cmd.pivot == CRS_PIVOT); + if (pe == NULL) + break; + + while (cur_tab < (*pb)->table) + insert_summary (summary, cur_tab++, 0.); + + if (mode == GENERAL) + for (valid = 0.; pb < pe; pb++) + valid += (*pb)->u.freq; + else + { + const struct crosstab *const x = xtab[(*pb)->table]; + const int n_cols = x->v[COL_VAR]->p.crs.count; + const int n_rows = x->v[ROW_VAR]->p.crs.count; + const int count = n_cols * n_rows; + + for (valid = 0.; pb < pe; pb++) + { + const double *data = (*pb)->u.data; + int i; + + for (i = 0; i < count; i++) + valid += *data++; + } + } + insert_summary (summary, cur_tab++, valid); + + pb = pe; + } + + while (cur_tab < nxtab) + insert_summary (summary, cur_tab++, 0.); + + submit (summary); +} + +/* Inserts a line into T describing the crosstabulation at index + TAB_INDEX, which has VALID valid observations. */ +static void +insert_summary (struct tab_table *t, int tab_index, double valid) +{ + struct crosstab *x = xtab[tab_index]; + + tab_hline (t, TAL_1, 0, 6, 0); + + /* Crosstabulation name. */ + { + char *buf = local_alloc (128 * x->nvar); + char *cp = buf; + int i; + + for (i = 0; i < x->nvar; i++) + { + if (i > 0) + cp = stpcpy (cp, " * "); + + cp = stpcpy (cp, x->v[i]->label ? x->v[i]->label : x->v[i]->name); + } + tab_text (t, 0, 0, TAB_LEFT, buf); + + local_free (buf); + } + + /* Counts and percentages. */ + { + double n[3]; + int i; + + n[0] = valid; + n[1] = x->missing; + n[2] = n[0] + n[1]; + + + for (i = 0; i < 3; i++) + { + tab_float (t, i * 2 + 1, 0, TAB_RIGHT, n[i], 8, 0); + tab_text (t, i * 2 + 2, 0, TAB_RIGHT | TAT_PRINTF, "%.1f%%", + n[i] / n[2] * 100.); + } + } + + tab_next_row (t); +} + +/* Output. */ + +/* Tables. */ +static struct tab_table *table; /* Crosstabulation table. */ +static struct tab_table *chisq; /* Chi-square table. */ +static struct tab_table *sym; /* Symmetric measures table. */ +static struct tab_table *risk; /* Risk estimate table. */ +static struct tab_table *direct; /* Directional measures table. */ + +/* Statistics. */ +static int chisq_fisher; /* Did any rows include Fisher's exact test? */ + +/* Column values, number of columns. */ +static union value *cols; +static int n_cols; + +/* Row values, number of rows. */ +static union value *rows; +static int n_rows; + +/* Number of statistically interesting columns/rows (columns/rows with + data in them). */ +static int ns_cols, ns_rows; + +/* Crosstabulation. */ +static struct crosstab *x; + +/* Number of variables from the crosstabulation to consider. This is + either x->nvar, if pivoting is on, or 2, if pivoting is off. */ +static int nvar; + +/* Matrix contents. */ +static double *mat; /* Matrix proper. */ +static double *row_tot; /* Row totals. */ +static double *col_tot; /* Column totals. */ +static double W; /* Grand total. */ + +static void display_dimensions (struct tab_table *, int first_difference, + struct table_entry *); +static void display_crosstabulation (void); +static void display_chisq (void); +static void display_symmetric (void); +static void display_risk (void); +static void display_directional (void); +static void crosstabs_dim (struct tab_table *, struct outp_driver *); +static void table_value_missing (struct tab_table *table, int c, int r, + unsigned char opt, const union value *v, + const struct variable *var); +static void delete_missing (void); + +/* Output pivot table beginning at PB and continuing until PE, + exclusive. For efficiency, *MATP is a pointer to a matrix that can + hold *MAXROWS entries. */ +static void +output_pivot_table (struct table_entry **pb, struct table_entry **pe, + double **matp, double **row_totp, double **col_totp, + int *maxrows, int *maxcols, int *maxcells) +{ + /* Subtable. */ + struct table_entry **tb = pb, **te; /* Table begin, table end. */ + int tc = pe - pb; /* Table count. */ + + /* Table entry for header comparison. */ + struct table_entry *cmp; + + x = xtab[(*pb)->table]; + enum_var_values (pb, pe - pb, &cols, &n_cols, COL_VAR); + + nvar = cmd.pivot == CRS_PIVOT ? x->nvar : 2; + + /* Crosstabulation table initialization. */ + if (num_cells) + { + table = tab_create (nvar + n_cols, + (pe - pb) / n_cols * 3 / 2 * num_cells + 10, 1); + tab_headers (table, nvar - 1, 0, 2, 0); + + /* First header line. */ + tab_joint_text (table, nvar - 1, 0, (nvar - 1) + (n_cols - 1), 0, + TAB_CENTER | TAT_TITLE, x->v[COL_VAR]->name); + + tab_hline (table, TAL_1, nvar - 1, nvar + n_cols - 2, 1); + + /* Second header line. */ + { + int i; + + for (i = 2; i < nvar; i++) + tab_joint_text (table, nvar - i - 1, 0, nvar - i - 1, 1, + TAB_RIGHT | TAT_TITLE, + x->v[i]->label ? x->v[i]->label : x->v[i]->name); + tab_text (table, nvar - 2, 1, TAB_RIGHT | TAT_TITLE, + x->v[ROW_VAR]->name); + for (i = 0; i < n_cols; i++) + table_value_missing (table, nvar + i - 1, 1, TAB_RIGHT, &cols[i], + x->v[COL_VAR]); + tab_text (table, nvar + n_cols - 1, 1, TAB_CENTER, _("Total")); + } + + tab_hline (table, TAL_1, 0, nvar + n_cols - 1, 2); + tab_vline (table, TAL_1, nvar + n_cols - 1, 0, 1); + + /* Title. */ + { + char *title = local_alloc (x->nvar * 64 + 128); + char *cp = title; + int i; + + if (cmd.pivot == CRS_PIVOT) + for (i = 0; i < nvar; i++) + { + if (i) + cp = stpcpy (cp, " by "); + cp = stpcpy (cp, x->v[i]->name); + } + else + { + cp = spprintf (cp, "%s by %s for", x->v[0]->name, x->v[1]->name); + for (i = 2; i < nvar; i++) + { + char buf[64], *bufp; + + if (i > 2) + *cp++ = ','; + *cp++ = ' '; + cp = stpcpy (cp, x->v[i]->name); + *cp++ = '='; + data_out (buf, &x->v[i]->print, &(*pb)->v[i]); + for (bufp = buf; isspace ((unsigned char) *bufp); bufp++) + ; + cp = stpcpy (cp, bufp); + } + } + + cp = stpcpy (cp, " ["); + for (i = 0; i < num_cells; i++) + { + struct tuple + { + int value; + const char *name; + }; + + static const struct tuple cell_names[] = + { + {CRS_CL_COUNT, N_("count")}, + {CRS_CL_ROW, N_("row %")}, + {CRS_CL_COLUMN, N_("column %")}, + {CRS_CL_TOTAL, N_("total %")}, + {CRS_CL_EXPECTED, N_("expected")}, + {CRS_CL_RESIDUAL, N_("residual")}, + {CRS_CL_SRESIDUAL, N_("std. resid.")}, + {CRS_CL_ASRESIDUAL, N_("adj. resid.")}, + {-1, NULL}, + }; + + const struct tuple *t; + + for (t = cell_names; t->value != cells[i]; t++) + assert (t->value != -1); + if (i) + cp = stpcpy (cp, ", "); + cp = stpcpy (cp, gettext (t->name)); + } + strcpy (cp, "]."); + + tab_title (table, 0, title); + local_free (title); + } + + tab_offset (table, 0, 2); + } + else + table = NULL; + + /* Chi-square table initialization. */ + if (cmd.a_statistics[CRS_ST_CHISQ]) + { + chisq = tab_create (6 + (nvar - 2), + (pe - pb) / n_cols * 3 / 2 * N_CHISQ + 10, 1); + tab_headers (chisq, 1 + (nvar - 2), 0, 1, 0); + + tab_title (chisq, 0, "Chi-square tests."); + + tab_offset (chisq, nvar - 2, 0); + tab_text (chisq, 0, 0, TAB_LEFT | TAT_TITLE, _("Statistic")); + tab_text (chisq, 1, 0, TAB_RIGHT | TAT_TITLE, _("Value")); + tab_text (chisq, 2, 0, TAB_RIGHT | TAT_TITLE, _("df")); + tab_text (chisq, 3, 0, TAB_RIGHT | TAT_TITLE, + _("Asymp. Sig. (2-sided)")); + tab_text (chisq, 4, 0, TAB_RIGHT | TAT_TITLE, + _("Exact. Sig. (2-sided)")); + tab_text (chisq, 5, 0, TAB_RIGHT | TAT_TITLE, + _("Exact. Sig. (1-sided)")); + chisq_fisher = 0; + tab_offset (chisq, 0, 1); + } + else + chisq = NULL; + + /* Symmetric measures. */ + if (cmd.a_statistics[CRS_ST_PHI] || cmd.a_statistics[CRS_ST_CC] + || cmd.a_statistics[CRS_ST_BTAU] || cmd.a_statistics[CRS_ST_CTAU] + || cmd.a_statistics[CRS_ST_GAMMA] || cmd.a_statistics[CRS_ST_CORR] + || cmd.a_statistics[CRS_ST_KAPPA]) + { + sym = tab_create (6 + (nvar - 2), (pe - pb) / n_cols * 7 + 10, 1); + tab_headers (sym, 2 + (nvar - 2), 0, 1, 0); + tab_title (sym, 0, "Symmetric measures."); + + tab_offset (sym, nvar - 2, 0); + tab_text (sym, 0, 0, TAB_LEFT | TAT_TITLE, _("Category")); + tab_text (sym, 1, 0, TAB_LEFT | TAT_TITLE, _("Statistic")); + tab_text (sym, 2, 0, TAB_RIGHT | TAT_TITLE, _("Value")); + tab_text (sym, 3, 0, TAB_RIGHT | TAT_TITLE, _("Asymp. Std. Error")); + tab_text (sym, 4, 0, TAB_RIGHT | TAT_TITLE, _("Approx. T")); + tab_text (sym, 5, 0, TAB_RIGHT | TAT_TITLE, _("Approx. Sig.")); + tab_offset (sym, 0, 1); + } + else + sym = NULL; + + /* Risk estimate. */ + if (cmd.a_statistics[CRS_ST_RISK]) + { + risk = tab_create (4 + (nvar - 2), (pe - pb) / n_cols * 4 + 10, 1); + tab_headers (risk, 1 + nvar - 2, 0, 2, 0); + tab_title (risk, 0, "Risk estimate."); + + tab_offset (risk, nvar - 2, 0); + tab_joint_text (risk, 2, 0, 3, 0, TAB_CENTER | TAT_TITLE | TAT_PRINTF, + _(" 95%% Confidence Interval")); + tab_text (risk, 0, 1, TAB_LEFT | TAT_TITLE, _("Statistic")); + tab_text (risk, 1, 1, TAB_RIGHT | TAT_TITLE, _("Value")); + tab_text (risk, 2, 1, TAB_RIGHT | TAT_TITLE, _("Lower")); + tab_text (risk, 3, 1, TAB_RIGHT | TAT_TITLE, _("Upper")); + tab_hline (risk, TAL_1, 2, 3, 1); + tab_vline (risk, TAL_1, 2, 0, 1); + tab_offset (risk, 0, 2); + } + else + risk = NULL; + + /* Directional measures. */ + if (cmd.a_statistics[CRS_ST_LAMBDA] || cmd.a_statistics[CRS_ST_UC] + || cmd.a_statistics[CRS_ST_D] || cmd.a_statistics[CRS_ST_ETA]) + { + direct = tab_create (7 + (nvar - 2), (pe - pb) / n_cols * 7 + 10, 1); + tab_headers (direct, 3 + (nvar - 2), 0, 1, 0); + tab_title (direct, 0, "Directional measures."); + + tab_offset (direct, nvar - 2, 0); + tab_text (direct, 0, 0, TAB_LEFT | TAT_TITLE, _("Category")); + tab_text (direct, 1, 0, TAB_LEFT | TAT_TITLE, _("Statistic")); + tab_text (direct, 2, 0, TAB_LEFT | TAT_TITLE, _("Type")); + tab_text (direct, 3, 0, TAB_RIGHT | TAT_TITLE, _("Value")); + tab_text (direct, 4, 0, TAB_RIGHT | TAT_TITLE, _("Asymp. Std. Error")); + tab_text (direct, 5, 0, TAB_RIGHT | TAT_TITLE, _("Approx. T")); + tab_text (direct, 6, 0, TAB_RIGHT | TAT_TITLE, _("Approx. Sig.")); + tab_offset (direct, 0, 1); + } + else + direct = NULL; + + for (;;) + { + /* Find pivot subtable if applicable. */ + te = find_pivot_extent (tb, &tc, 0); + if (te == NULL) + break; + + /* Find all the row variable values. */ + enum_var_values (tb, te - tb, &rows, &n_rows, ROW_VAR); + + /* Allocate memory space for the column and row totals. */ + if (n_rows > *maxrows) + { + *row_totp = xrealloc (*row_totp, sizeof **row_totp * n_rows); + row_tot = *row_totp; + *maxrows = n_rows; + } + if (n_cols > *maxcols) + { + *col_totp = xrealloc (*col_totp, sizeof **col_totp * n_cols); + col_tot = *col_totp; + *maxcols = n_cols; + } + + /* Allocate table space for the matrix. */ + if (table && tab_row (table) + (n_rows + 1) * num_cells > tab_nr (table)) + tab_realloc (table, -1, + max (tab_nr (table) + (n_rows + 1) * num_cells, + tab_nr (table) * (pe - pb) / (te - tb))); + + if (mode == GENERAL) + { + /* Allocate memory space for the matrix. */ + if (n_cols * n_rows > *maxcells) + { + *matp = xrealloc (*matp, sizeof **matp * n_cols * n_rows); + *maxcells = n_cols * n_rows; + } + + mat = *matp; + + /* Build the matrix and calculate column totals. */ + { + union value *cur_col = cols; + union value *cur_row = rows; + double *mp = mat; + double *cp = col_tot; + struct table_entry **p; + + *cp = 0.; + for (p = &tb[0]; p < te; p++) + { + for (; memcmp (cur_col, &(*p)->v[COL_VAR], sizeof *cur_col); + cur_row = rows) + { + *++cp = 0.; + for (; cur_row < &rows[n_rows]; cur_row++) + { + *mp = 0.; + mp += n_cols; + } + cur_col++; + mp = &mat[cur_col - cols]; + } + + for (; memcmp (cur_row, &(*p)->v[ROW_VAR], sizeof *cur_row); + cur_row++) + { + *mp = 0.; + mp += n_cols; + } + + *cp += *mp = (*p)->u.freq; + mp += n_cols; + cur_row++; + } + + /* Zero out the rest of the matrix. */ + for (; cur_row < &rows[n_rows]; cur_row++) + { + *mp = 0.; + mp += n_cols; + } + cur_col++; + if (cur_col < &cols[n_cols]) + { + const int rem_cols = n_cols - (cur_col - cols); + int c, r; + + for (c = 0; c < rem_cols; c++) + *++cp = 0.; + mp = &mat[cur_col - cols]; + for (r = 0; r < n_rows; r++) + { + for (c = 0; c < rem_cols; c++) + *mp++ = 0.; + mp += n_cols - rem_cols; + } + } + } + } + else + { + int r, c; + double *tp = col_tot; + + assert (mode == INTEGER); + mat = (*tb)->u.data; + ns_cols = n_cols; + + /* Calculate column totals. */ + for (c = 0; c < n_cols; c++) + { + double cum = 0.; + double *cp = &mat[c]; + + for (r = 0; r < n_rows; r++) + cum += cp[r * n_cols]; + *tp++ = cum; + } + } + + { + double *cp; + + for (ns_cols = 0, cp = col_tot; cp < &col_tot[n_cols]; cp++) + ns_cols += *cp != 0.; + } + + /* Calculate row totals. */ + { + double *mp = mat; + double *rp = row_tot; + int r, c; + + for (ns_rows = 0, r = n_rows; r--; ) + { + double cum = 0.; + for (c = n_cols; c--; ) + cum += *mp++; + *rp++ = cum; + if (cum != 0.) + ns_rows++; + } + } + + /* Calculate grand total. */ + { + double *tp; + double cum = 0.; + int n; + + if (n_rows < n_cols) + tp = row_tot, n = n_rows; + else + tp = col_tot, n = n_cols; + while (n--) + cum += *tp++; + W = cum; + } + +#if DEBUGGING + /* Print the matrix. */ + { + int i, r, c; + + printf ("%s by %s for", x->v[0]->name, x->v[1]->name); + for (i = 2; i < nvar; i++) + printf (" %s=%g", x->v[i]->name, tb[0]->v[i].f); + printf ("\n"); + printf (" "); + for (c = 0; c < n_cols; c++) + printf ("%4g", cols[c].f); + printf ("\n"); + for (r = 0; r < n_rows; r++) + { + printf ("%4g:", rows[r].f); + for (c = 0; c < n_cols; c++) + printf ("%4g", mat[c + r * n_cols]); + printf ("%4g", row_tot[r]); + printf ("\n"); + } + printf (" "); + for (c = 0; c < n_cols; c++) + printf ("%4g", col_tot[c]); + printf ("%4g", W); + printf ("\n\n"); + } +#endif + + /* Find the first variable that differs from the last subtable, + then display the values of the dimensioning variables for + each table that needs it. */ + { + int first_difference = nvar - 1; + + if (tb != pb) + for (; ; first_difference--) + { + assert (first_difference >= 2); + if (memcmp (&cmp->v[first_difference], + &(*tb)->v[first_difference], sizeof *cmp->v)) + break; + } + cmp = *tb; + + if (table) + display_dimensions (table, first_difference, *tb); + if (chisq) + display_dimensions (chisq, first_difference, *tb); + if (sym) + display_dimensions (sym, first_difference, *tb); + if (risk) + display_dimensions (risk, first_difference, *tb); + if (direct) + display_dimensions (direct, first_difference, *tb); + } + + if (table) + display_crosstabulation (); + if (cmd.miss == CRS_REPORT) + delete_missing (); + if (chisq) + display_chisq (); + if (sym) + display_symmetric (); + if (risk) + display_risk (); + if (direct) + display_directional (); + + tb = te; + free (rows); + } + + submit (table); + + if (chisq) + { + if (!chisq_fisher) + tab_resize (chisq, 4 + (nvar - 2), -1); + submit (chisq); + } + + submit (sym); + submit (risk); + submit (direct); + + free (cols); +} + +/* Delete missing rows and columns for statistical analysis when + /MISSING=REPORT. */ +static void +delete_missing (void) +{ + { + int r; + + for (r = 0; r < n_rows; r++) + if (is_num_user_missing (rows[r].f, x->v[ROW_VAR])) + { + int c; + + for (c = 0; c < n_cols; c++) + mat[c + r * n_cols] = 0.; + ns_rows--; + } + } + + { + int c; + + for (c = 0; c < n_cols; c++) + if (is_num_user_missing (cols[c].f, x->v[COL_VAR])) + { + int r; + + for (r = 0; r < n_rows; r++) + mat[c + r * n_cols] = 0.; + ns_cols--; + } + } +} + +/* Prepare table T for submission, and submit it. */ +static void +submit (struct tab_table *t) +{ + int i; + + if (t == NULL) + return; + + tab_resize (t, -1, 0); + if (tab_nr (t) == tab_t (t)) + { + tab_destroy (t); + return; + } + tab_offset (t, 0, 0); + if (t != table) + for (i = 2; i < nvar; i++) + tab_text (t, nvar - i - 1, 0, TAB_RIGHT | TAT_TITLE, + x->v[i]->label ? x->v[i]->label : x->v[i]->name); + tab_box (t, TAL_2, TAL_2, -1, -1, 0, 0, tab_nc (t) - 1, tab_nr (t) - 1); + tab_box (t, -1, -1, -1, TAL_1, tab_l (t), tab_t (t) - 1, tab_nc (t) - 1, + tab_nr (t) - 1); + tab_box (t, -1, -1, -1, TAL_1 | TAL_SPACING, 0, tab_t (t), tab_l (t) - 1, + tab_nr (t) - 1); + tab_vline (t, TAL_2, tab_l (t), 0, tab_nr (t) - 1); + tab_dim (t, crosstabs_dim); + tab_submit (t); +} + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +crosstabs_dim (struct tab_table *t, struct outp_driver *d) +{ + int i; + + /* Width of a numerical column. */ + int c = outp_string_width (d, "0.000000"); + if (cmd.miss == CRS_REPORT) + c += outp_string_width (d, "M"); + + /* Set width for header columns. */ + if (t->l != 0) + { + int w = (d->width - t->vr_tot - c * (t->nc - t->l)) / t->l; + + if (w < d->prop_em_width * 8) + w = d->prop_em_width * 8; + + if (w > d->prop_em_width * 15) + w = d->prop_em_width * 15; + + for (i = 0; i < t->l; i++) + t->w[i] = w; + } + + for (i = t->l; i < t->nc; i++) + t->w[i] = c; + + for (i = 0; i < t->nr; i++) + t->h[i] = tab_natural_height (t, d, i); +} + +static struct table_entry **find_pivot_extent_general (struct table_entry **tp, + int *cnt, int pivot); +static struct table_entry **find_pivot_extent_integer (struct table_entry **tp, + int *cnt, int pivot); + +/* Calls find_pivot_extent_general or find_pivot_extent_integer, as + appropriate. */ +static struct table_entry ** +find_pivot_extent (struct table_entry **tp, int *cnt, int pivot) +{ + return (mode == GENERAL + ? find_pivot_extent_general (tp, cnt, pivot) + : find_pivot_extent_integer (tp, cnt, pivot)); +} + +/* Find the extent of a region in TP that contains one table. If + PIVOT != 0 that means a set of table entries with identical table + number; otherwise they also have to have the same values for every + dimension after the row and column dimensions. The table that is + searched starts at TP and has length CNT. Returns the first entry + after the last one in the table; sets *CNT to the number of + remaining values. If there are no entries in TP at all, returns + NULL. A yucky interface, admittedly, but it works. */ +static struct table_entry ** +find_pivot_extent_general (struct table_entry **tp, int *cnt, int pivot) +{ + struct table_entry *fp = *tp; + struct crosstab *x; + + if (*cnt == 0) + return NULL; + x = xtab[(*tp)->table]; + for (;;) + { + tp++; + if (--*cnt == 0) + break; + assert (*cnt > 0); + + if ((*tp)->table != fp->table) + break; + if (pivot) + continue; + + if (memcmp (&(*tp)->v[2], &fp->v[2], sizeof (union value) * (x->nvar - 2))) + break; + } + + return tp; +} + +/* Integer mode correspondent to find_pivot_extent_general(). This + could be optimized somewhat, but I just don't give a crap about + CROSSTABS performance in integer mode, which is just a wart on + CROSSTABS' ass as far as I'm concerned. + + That said, feel free to send optimization patches to me. */ +static struct table_entry ** +find_pivot_extent_integer (struct table_entry **tp, int *cnt, int pivot) +{ + struct table_entry *fp = *tp; + struct crosstab *x; + + if (*cnt == 0) + return NULL; + x = xtab[(*tp)->table]; + for (;;) + { + tp++; + if (--*cnt == 0) + break; + assert (*cnt > 0); + + if ((*tp)->table != fp->table) + break; + if (pivot) + continue; + + if (memcmp (&(*tp)->v[2], &fp->v[2], sizeof (union value) * (x->nvar - 2))) + break; + } + + return tp; +} + +/* Compare value * A and B, where WIDTH is the string width or 0 for + numerics, and return a strcmp()-type result. */ +static int +compare_value (const void *pa, const void *pb, void *pwidth) +{ + const union value *a = pa; + const union value *b = pb; + const int width = (int) pwidth; + + if (width) + return strncmp (a->s, b->s, width); + else + return a->f < b->f ? -1 : (a->f > b->f ? 1 : 0); +} + +/* Given a list of CNT table_entry's starting at BEG, creates a list + of *NVALUES values *VALUES of variable with index VAR_INDEX. */ +static void +enum_var_values (struct table_entry **beg, int cnt, union value **values, int *nvalues, + int var_index) +{ + if (mode == GENERAL) + { + avl_tree *tree; + + tree = avl_create (pl_col, compare_value, + (void *) (xtab[(*beg)->table]->v[var_index]->width)); + + { + int i; + + for (i = 0; i < cnt; i++) + avl_insert (tree, &beg[i]->v[var_index]); + *values = xmalloc (sizeof **values * avl_count (tree)); + } + + { + avl_traverser trav; + union value *v; + int i; + + i = 0; + hsh_iterator_init (trav); + while (NULL != (v = avl_traverse (tree, &trav))) + (*values)[i++] = *v; + *nvalues = i; + } + + /* Destroy tree. */ + pool_destroy (pl_col); + pl_col = pool_create (); + } + else + { + struct crosstab_proc *crs = &xtab[(*beg)->table]->v[var_index]->p.crs; + int i; + + assert (mode == INTEGER); + *values = xmalloc (sizeof **values * crs->count); + for (i = 0; i < crs->count; i++) + (*values)[i].f = i + crs->min; + *nvalues = crs->count; + } +} + +/* Sets cell (C,R) in TABLE, with options OPT, to have a value taken + from V, displayed with print format spec from variable VAR. When + in REPORT missing-value mode, missing values have an M appended. */ +static void +table_value_missing (struct tab_table *table, int c, int r, unsigned char opt, + const union value *v, const struct variable *var) +{ + struct len_string s; + + char *label = get_val_lab (var, *v, 0); + if (label) + { + tab_text (table, c, r, TAB_LEFT, label); + return; + } + + s.length = var->print.w; + s.string = tab_alloc (table, s.length + 1); + data_out (s.string, &var->print, v); + if (cmd.miss == CRS_REPORT && is_num_user_missing (v->f, var)) + s.string[s.length++] = 'M'; + while (s.length && *s.string == ' ') + { + s.length--; + s.string++; + } + tab_raw (table, c, r, opt, &s); +} + +/* Draws a line across TABLE at the current row to indicate the most + major dimension variable with index FIRST_DIFFERENCE out of NVAR + that changed, and puts the values that changed into the table. TB + and X must be the corresponding table_entry and crosstab, + respectively. */ +static void +display_dimensions (struct tab_table *table, int first_difference, struct table_entry *tb) +{ + tab_hline (table, TAL_1, nvar - first_difference - 1, tab_nc (table) - 1, 0); + + for (; first_difference >= 2; first_difference--) + table_value_missing (table, nvar - first_difference - 1, 0, + TAB_RIGHT, &tb->v[first_difference], + x->v[first_difference]); +} + +/* Put value V into cell (C,R) of TABLE, suffixed with letter M. */ +static void +float_M_suffix (struct tab_table *table, int c, int r, double v) +{ + static const struct fmt_spec f = {FMT_F, 8, 0}; + struct len_string s; + + s.length = 9; + s.string = tab_alloc (table, 9); + s.string[8] = 'M'; + data_out (s.string, &f, (union value *) &v); + while (*s.string == ' ') + { + s.length--; + s.string++; + } + tab_raw (table, c, r, TAB_RIGHT, &s); +} + +/* Displays the crosstabulation table. */ +static void +display_crosstabulation (void) +{ + { + int r; + + for (r = 0; r < n_rows; r++) + table_value_missing (table, nvar - 2, r * num_cells, + TAB_RIGHT, &rows[r], x->v[ROW_VAR]); + } + tab_text (table, nvar - 2, n_rows * num_cells, + TAB_LEFT, _("Total")); + + /* Put in the actual cells. */ + { + double *mp = mat; + int r, c, i; + + tab_offset (table, nvar - 1, -1); + for (r = 0; r < n_rows; r++) + { + if (num_cells > 1) + tab_hline (table, TAL_1, -1, n_cols, 0); + for (c = 0; c < n_cols; c++) + { + double expected_value; + + if (expected) + expected_value = row_tot[r] * col_tot[c] / W; + for (i = 0; i < num_cells; i++) + { + double v; + + switch (cells[i]) + { + case CRS_CL_COUNT: + v = *mp; + break; + case CRS_CL_ROW: + v = *mp / row_tot[r] * 100.; + break; + case CRS_CL_COLUMN: + v = *mp / col_tot[c] * 100.; + break; + case CRS_CL_TOTAL: + v = *mp / W * 100.; + break; + case CRS_CL_EXPECTED: + v = expected_value; + break; + case CRS_CL_RESIDUAL: + v = *mp - expected_value; + break; + case CRS_CL_SRESIDUAL: + v = (*mp - expected_value) / sqrt (expected_value); + break; + case CRS_CL_ASRESIDUAL: + v = ((*mp - expected_value) + / sqrt (expected_value + * (1. - row_tot[r] / W) + * (1. - col_tot[c] / W))); + break; + default: + assert (0); + } + + if (cmd.miss == CRS_REPORT + && (is_num_user_missing (cols[c].f, x->v[COL_VAR]) + || is_num_user_missing (rows[r].f, x->v[ROW_VAR]))) + float_M_suffix (table, c, i, v); + else if (v != 0.) + tab_float (table, c, i, TAB_RIGHT, v, 8, 0); + } + + mp++; + } + + tab_offset (table, -1, tab_row (table) + num_cells); + } + } + + /* Row totals. */ + { + int r, i; + + tab_offset (table, -1, tab_row (table) - num_cells * n_rows); + for (r = 0; r < n_rows; r++) + for (i = 0; i < num_cells; i++) + { + double v; + + switch (cells[i]) + { + case CRS_CL_COUNT: + v = row_tot[r]; + break; + case CRS_CL_ROW: + v = 100.; + break; + case CRS_CL_COLUMN: + v = row_tot[r] / W * 100.; + break; + case CRS_CL_TOTAL: + v = row_tot[r] / W * 100.; + break; + case CRS_CL_EXPECTED: + case CRS_CL_RESIDUAL: + case CRS_CL_SRESIDUAL: + case CRS_CL_ASRESIDUAL: + v = 0.; + break; + default: + assert (0); + } + + if (cmd.miss == CRS_REPORT + && is_num_user_missing (rows[r].f, x->v[ROW_VAR])) + float_M_suffix (table, n_cols, 0, v); + else if (v != 0.) + tab_float (table, n_cols, 0, TAB_RIGHT, v, 8, 0); + + tab_next_row (table); + } + } + + /* Column totals, grand total. */ + { + int c, j; + + if (num_cells > 1) + tab_hline (table, TAL_1, -1, n_cols, 0); + for (c = 0; c <= n_cols; c++) + { + double ct = c < n_cols ? col_tot[c] : W; + int i; + + for (i = j = 0; i < num_cells; i++) + { + double v; + + switch (cells[i]) + { + case CRS_CL_COUNT: + v = ct; + break; + case CRS_CL_ROW: + v = ct / W * 100.; + break; + case CRS_CL_COLUMN: + v = 100.; + break; + case CRS_CL_TOTAL: + v = ct / W * 100.; + break; + case CRS_CL_EXPECTED: + case CRS_CL_RESIDUAL: + case CRS_CL_SRESIDUAL: + case CRS_CL_ASRESIDUAL: + continue; + default: + assert (0); + } + + if (cmd.miss == CRS_REPORT && c < n_cols + && is_num_user_missing (cols[c].f, x->v[COL_VAR])) + float_M_suffix (table, c, j, v); + else if (v != 0.) + tab_float (table, c, j, TAB_RIGHT, v, 8, 0); + + j++; + } + } + + tab_offset (table, -1, tab_row (table) + j); + } + + tab_offset (table, 0, -1); +} + +static void calc_r (double *X, double *Y, double *, double *, double *); +static void calc_chisq (double[N_CHISQ], int[N_CHISQ], double *, double *); + +/* Display chi-square statistics. */ +static void +display_chisq (void) +{ + static const char *chisq_stats[N_CHISQ] = + { + N_("Pearson Chi-Square"), + N_("Likelihood Ratio"), + N_("Fisher's Exact Test"), + N_("Continuity Correction"), + N_("Linear-by-Linear Association"), + }; + double chisq_v[N_CHISQ]; + double fisher1, fisher2; + int df[N_CHISQ]; + int s = 0; + + int i; + + calc_chisq (chisq_v, df, &fisher1, &fisher2); + + tab_offset (chisq, nvar - 2, -1); + + for (i = 0; i < N_CHISQ; i++) + { + if ((i != 2 && chisq_v[i] == SYSMIS) + || (i == 2 && fisher1 == SYSMIS)) + continue; + s = 1; + + tab_text (chisq, 0, 0, TAB_LEFT, gettext (chisq_stats[i])); + if (i != 2) + { + tab_float (chisq, 1, 0, TAB_RIGHT, chisq_v[i], 8, 3); + tab_float (chisq, 2, 0, TAB_RIGHT, df[i], 8, 0); + tab_float (chisq, 3, 0, TAB_RIGHT, + chisq_sig (chisq_v[i], df[i]), 8, 3); + } + else + { + chisq_fisher = 1; + tab_float (chisq, 4, 0, TAB_RIGHT, fisher2, 8, 3); + tab_float (chisq, 5, 0, TAB_RIGHT, fisher1, 8, 3); + } + tab_next_row (chisq); + } + + tab_text (chisq, 0, 0, TAB_LEFT, _("N of Valid Cases")); + tab_float (chisq, 1, 0, TAB_RIGHT, W, 8, 0); + tab_next_row (chisq); + + tab_offset (chisq, 0, -1); +} + +static int calc_symmetric (double[N_SYMMETRIC], double[N_SYMMETRIC], + double[N_SYMMETRIC]); + +/* Display symmetric measures. */ +static void +display_symmetric (void) +{ + static const char *categories[] = + { + N_("Nominal by Nominal"), + N_("Ordinal by Ordinal"), + N_("Interval by Interval"), + N_("Measure of Agreement"), + }; + + static const char *stats[N_SYMMETRIC] = + { + N_("Phi"), + N_("Cramer's V"), + N_("Contingency Coefficient"), + N_("Kendall's tau-b"), + N_("Kendall's tau-c"), + N_("Gamma"), + N_("Spearman Correlation"), + N_("Pearson's R"), + N_("Kappa"), + }; + + static const int stats_categories[N_SYMMETRIC] = + { + 0, 0, 0, 1, 1, 1, 1, 2, 3, + }; + + int last_cat = -1; + double sym_v[N_SYMMETRIC], sym_ase[N_SYMMETRIC], sym_t[N_SYMMETRIC]; + int i; + + if (!calc_symmetric (sym_v, sym_ase, sym_t)) + return; + + tab_offset (sym, nvar - 2, -1); + + for (i = 0; i < N_SYMMETRIC; i++) + { + if (sym_v[i] == SYSMIS) + continue; + + if (stats_categories[i] != last_cat) + { + last_cat = stats_categories[i]; + tab_text (sym, 0, 0, TAB_LEFT, gettext (categories[last_cat])); + } + + tab_text (sym, 1, 0, TAB_LEFT, gettext (stats[i])); + tab_float (sym, 2, 0, TAB_RIGHT, sym_v[i], 8, 3); + if (sym_ase[i] != SYSMIS) + tab_float (sym, 3, 0, TAB_RIGHT, sym_ase[i], 8, 3); + if (sym_t[i] != SYSMIS) + tab_float (sym, 4, 0, TAB_RIGHT, sym_t[i], 8, 3); + /*tab_float (sym, 5, 0, TAB_RIGHT, normal_sig (sym_v[i]), 8, 3);*/ + tab_next_row (sym); + } + + tab_text (sym, 0, 0, TAB_LEFT, _("N of Valid Cases")); + tab_float (sym, 2, 0, TAB_RIGHT, W, 8, 0); + tab_next_row (sym); + + tab_offset (sym, 0, -1); +} + +static int calc_risk (double[], double[], double[], union value *); + +/* Display risk estimate. */ +static void +display_risk (void) +{ + char buf[256]; + double risk_v[3], lower[3], upper[3]; + union value c[2]; + int i; + + if (!calc_risk (risk_v, upper, lower, c)) + return; + + tab_offset (risk, nvar - 2, -1); + + for (i = 0; i < 3; i++) + { + if (risk_v[i] == SYSMIS) + continue; + + switch (i) + { + case 0: + if (x->v[COL_VAR]->type == NUMERIC) + sprintf (buf, _("Odds Ratio for %s (%g / %g)"), + x->v[COL_VAR]->name, c[0].f, c[1].f); + else + sprintf (buf, _("Odds Ratio for %s (%.*s / %.*s)"), + x->v[COL_VAR]->name, + x->v[COL_VAR]->width, c[0].s, + x->v[COL_VAR]->width, c[1].s); + break; + case 1: + case 2: + if (x->v[ROW_VAR]->type == NUMERIC) + sprintf (buf, _("For cohort %s = %g"), + x->v[ROW_VAR]->name, rows[i - 1].f); + else + sprintf (buf, _("For cohort %s = %.*s"), + x->v[ROW_VAR]->name, + x->v[ROW_VAR]->width, rows[i - 1].s); + break; + } + + tab_text (risk, 0, 0, TAB_LEFT, buf); + tab_float (risk, 1, 0, TAB_RIGHT, risk_v[i], 8, 3); + tab_float (risk, 2, 0, TAB_RIGHT, lower[i], 8, 3); + tab_float (risk, 3, 0, TAB_RIGHT, upper[i], 8, 3); + tab_next_row (risk); + } + + tab_text (risk, 0, 0, TAB_LEFT, _("N of Valid Cases")); + tab_float (risk, 1, 0, TAB_RIGHT, W, 8, 0); + tab_next_row (risk); + + tab_offset (risk, 0, -1); +} + +static int calc_directional (double[N_DIRECTIONAL], double[N_DIRECTIONAL], + double[N_DIRECTIONAL]); + +/* Display directional measures. */ +static void +display_directional (void) +{ + static const char *categories[] = + { + N_("Nominal by Nominal"), + N_("Ordinal by Ordinal"), + N_("Nominal by Interval"), + }; + + static const char *stats[] = + { + N_("Lambda"), + N_("Goodman and Kruskal tau"), + N_("Uncertainty Coefficient"), + N_("Somers' d"), + N_("Eta"), + }; + + static const char *types[] = + { + N_("Symmetric"), + N_("%s Dependent"), + N_("%s Dependent"), + }; + + static const int stats_categories[N_DIRECTIONAL] = + { + 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 2, 2, + }; + + static const int stats_stats[N_DIRECTIONAL] = + { + 0, 0, 0, 1, 1, 2, 2, 2, 3, 3, 3, 4, 4, + }; + + static const int stats_types[N_DIRECTIONAL] = + { + 0, 1, 2, 1, 2, 0, 1, 2, 0, 1, 2, 1, 2, + }; + + static const int *stats_lookup[] = + { + stats_categories, + stats_stats, + stats_types, + }; + + static const char **stats_names[] = + { + categories, + stats, + types, + }; + + int last[3] = + { + -1, -1, -1, + }; + + double direct_v[N_DIRECTIONAL]; + double direct_ase[N_DIRECTIONAL]; + double direct_t[N_DIRECTIONAL]; + + int i; + + if (!calc_directional (direct_v, direct_ase, direct_t)) + return; + + tab_offset (direct, nvar - 2, -1); + + for (i = 0; i < N_DIRECTIONAL; i++) + { + if (direct_v[i] == SYSMIS) + continue; + + { + int j; + + for (j = 0; j < 3; j++) + if (last[j] != stats_lookup[j][i]) + { + if (j < 2) + tab_hline (direct, TAL_1, j, 6, 0); + + for (; j < 3; j++) + { + char *string; + int k = last[j] = stats_lookup[j][i]; + + if (k == 0) + string = NULL; + else if (k == 1) + string = x->v[0]->name; + else + string = x->v[1]->name; + + tab_text (direct, j, 0, TAB_LEFT | TAT_PRINTF, + gettext (stats_names[j][k]), string); + } + } + } + + tab_float (direct, 3, 0, TAB_RIGHT, direct_v[i], 8, 3); + if (direct_ase[i] != SYSMIS) + tab_float (direct, 4, 0, TAB_RIGHT, direct_ase[i], 8, 3); + if (direct_t[i] != SYSMIS) + tab_float (direct, 5, 0, TAB_RIGHT, direct_t[i], 8, 3); + /*tab_float (direct, 6, 0, TAB_RIGHT, normal_sig (direct_v[i]), 8, 3);*/ + tab_next_row (direct); + } + + tab_offset (direct, 0, -1); +} + +/* Statistical calculations. */ + +/* Returns the value of the gamma (factorial) function for an integer + argument X. */ +double +gamma_int (double x) +{ + double r = 1; + int i; + + for (i = 2; i < x; i++) + r *= i; + return r; +} + +/* Calculate P_r as specified in _SPSS Statistical Algorithms_, + Appendix 5. */ +static inline double +Pr (int a, int b, int c, int d) +{ + return (gamma_int (a + b + 1.) / gamma_int (a + 1.) + * gamma_int (c + d + 1.) / gamma_int (b + 1.) + * gamma_int (a + c + 1.) / gamma_int (c + 1.) + * gamma_int (b + d + 1.) / gamma_int (d + 1.) + / gamma_int (a + b + c + d + 1.)); +} + +/* Swap the contents of A and B. */ +static inline void +swap (int *a, int *b) +{ + int t = *a; + *a = *b; + *b = t; +} + +/* Calculate significance for Fisher's exact test as specified in + _SPSS Statistical Algorithms_, Appendix 5. */ +static void +calc_fisher (int a, int b, int c, int d, double *fisher1, double *fisher2) +{ + int x; + + if (min (c, d) < min (a, b)) + swap (&a, &c), swap (&b, &d); + if (min (b, d) < min (a, c)) + swap (&a, &b), swap (&c, &d); + if (b * c < a * d) + { + if (b < c) + swap (&a, &b), swap (&c, &d); + else + swap (&a, &c), swap (&b, &d); + } + + *fisher1 = 0.; + for (x = 0; x <= a; x++) + *fisher1 += Pr (a - x, b + x, c + x, d - x); + + *fisher2 = *fisher1; + for (x = 1; x <= b; x++) + *fisher2 += Pr (a + x, b - x, c - x, d + x); +} + +/* Calculates chi-squares into CHISQ. MAT is a matrix with N_COLS + columns with values COLS and N_ROWS rows with values ROWS. Values + in the matrix sum to W. */ +static void +calc_chisq (double chisq[N_CHISQ], int df[N_CHISQ], + double *fisher1, double *fisher2) +{ + int r, c; + + chisq[0] = chisq[1] = 0.; + chisq[2] = chisq[3] = chisq[4] = SYSMIS; + *fisher1 = *fisher2 = SYSMIS; + + df[0] = df[1] = (ns_cols - 1) * (ns_rows - 1); + + if (ns_rows <= 1 || ns_cols <= 1) + { + chisq[0] = chisq[1] = SYSMIS; + return; + } + + for (r = 0; r < n_rows; r++) + for (c = 0; c < n_cols; c++) + { + const double expected = row_tot[r] * col_tot[c] / W; + const double freq = mat[n_cols * r + c]; + const double residual = freq - expected; + + if (expected) + chisq[0] += residual * residual / expected; + if (freq) + chisq[1] += freq * log (expected / freq); + } + + if (chisq[0] == 0.) + chisq[0] = SYSMIS; + + if (chisq[1] != 0.) + chisq[1] *= -2.; + else + chisq[1] = SYSMIS; + + /* Calculate Yates and Fisher exact test. */ + if (ns_cols == 2 && ns_rows == 2) + { + double f11, f12, f21, f22; + + { + int nz_cols[2]; + int i, j; + + for (i = j = 0; i < n_cols; i++) + if (col_tot[i] != 0.) + { + nz_cols[j++] = i; + if (j == 2) + break; + } + + assert (j == 2); + + f11 = mat[nz_cols[0]]; + f12 = mat[nz_cols[1]]; + f21 = mat[nz_cols[0] + n_cols]; + f22 = mat[nz_cols[1] + n_cols]; + } + + /* Yates. */ + { + const double x = fabs (f11 * f22 - f12 * f21) - 0.5 * W; + + if (x > 0.) + chisq[3] = (W * x * x + / (f11 + f12) / (f21 + f22) + / (f11 + f21) / (f12 + f22)); + else + chisq[3] = 0.; + + df[3] = 1.; + } + + /* Fisher. */ + if (f11 < 5. || f12 < 5. || f21 < 5. || f22 < 5.) + calc_fisher (f11 + .5, f12 + .5, f21 + .5, f22 + .5, fisher1, fisher2); + } + + /* Calculate Mantel-Haenszel. */ + if (x->v[ROW_VAR]->type == NUMERIC && x->v[COL_VAR]->type == NUMERIC) + { + double r, ase_0, ase_1; + calc_r ((double *) rows, (double *) cols, &r, &ase_0, &ase_1); + + chisq[4] = (W - 1.) * r * r; + df[4] = 1; + } +} + +/* Calculate the value of Pearson's r. r is stored into R, ase_1 into + ASE_1, and ase_0 into ASE_0. The row and column values must be + passed in X and Y. */ +static void +calc_r (double *X, double *Y, double *r, double *ase_0, double *ase_1) +{ + double SX, SY, S, T; + double Xbar, Ybar; + double sum_XYf, sum_X2Y2f; + double sum_Xr, sum_X2r; + double sum_Yc, sum_Y2c; + int i, j; + + for (sum_X2Y2f = sum_XYf = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + double fij = mat[j + i * n_cols]; + double product = X[i] * Y[j]; + double temp = fij * product; + sum_XYf += temp; + sum_X2Y2f += temp * product; + } + + for (sum_Xr = sum_X2r = 0., i = 0; i < n_rows; i++) + { + sum_Xr += X[i] * row_tot[i]; + sum_X2r += X[i] * X[i] * row_tot[i]; + } + Xbar = sum_Xr / W; + + for (sum_Yc = sum_Y2c = 0., i = 0; i < n_cols; i++) + { + sum_Yc += Y[i] * col_tot[i]; + sum_Y2c += Y[i] * Y[i] * col_tot[i]; + } + Ybar = sum_Yc / W; + + S = sum_XYf - sum_Xr * sum_Yc / W; + SX = sum_X2r - sum_Xr * sum_Xr / W; + SY = sum_Y2c - sum_Yc * sum_Yc / W; + T = sqrt (SX * SY); + *r = S / T; + *ase_0 = sqrt ((sum_X2Y2f - (sum_XYf * sum_XYf) / W) / (sum_X2r * sum_Y2c)); + + { + double s, c, y, t; + + for (s = c = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + double Xresid, Yresid; + double temp; + + Xresid = X[i] - Xbar; + Yresid = Y[j] - Ybar; + temp = (T * Xresid * Yresid + - ((S / (2. * T)) + * (Xresid * Xresid * SY + Yresid * Yresid * SX))); + y = mat[j + i * n_cols] * temp * temp - c; + t = s + y; + c = (t - s) - y; + s = t; + } + *ase_1 = sqrt (s) / (T * T); + } +} + +static double somers_d_v[3]; +static double somers_d_ase[3]; +static double somers_d_t[3]; + +/* Calculate symmetric statistics and their asymptotic standard + errors. Returns 0 if none could be calculated. */ +static int +calc_symmetric (double v[N_SYMMETRIC], double ase[N_SYMMETRIC], + double t[N_SYMMETRIC]) +{ + int q = min (ns_rows, ns_cols); + + if (q <= 1) + return 0; + + { + int i; + + if (v) + for (i = 0; i < N_SYMMETRIC; i++) + v[i] = ase[i] = t[i] = SYSMIS; + } + + /* Phi, Cramer's V, contingency coefficient. */ + if (cmd.a_statistics[CRS_ST_PHI] || cmd.a_statistics[CRS_ST_CC]) + { + double Xp = 0.; /* Pearson chi-square. */ + + { + int r, c; + + for (r = 0; r < n_rows; r++) + for (c = 0; c < n_cols; c++) + { + const double expected = row_tot[r] * col_tot[c] / W; + const double freq = mat[n_cols * r + c]; + const double residual = freq - expected; + + if (expected) + Xp += residual * residual / expected; + } + } + + if (cmd.a_statistics[CRS_ST_PHI]) + { + v[0] = sqrt (Xp / W); + v[1] = sqrt (Xp / (W * (q - 1))); + } + if (cmd.a_statistics[CRS_ST_CC]) + v[2] = sqrt (Xp / (Xp + W)); + } + + if (cmd.a_statistics[CRS_ST_BTAU] || cmd.a_statistics[CRS_ST_CTAU] + || cmd.a_statistics[CRS_ST_GAMMA] || cmd.a_statistics[CRS_ST_D]) + { + double *cum; + double Dr, Dc; + double P, Q; + double btau_cum, ctau_cum, gamma_cum, d_yx_cum, d_xy_cum; + double btau_var; + + { + int r, c; + + Dr = Dc = W * W; + for (r = 0; r < n_rows; r++) + Dr -= row_tot[r] * row_tot[r]; + for (c = 0; c < n_cols; c++) + Dc -= col_tot[c] * col_tot[c]; + } + + { + int r, c; + + cum = xmalloc (sizeof *cum * n_cols * n_rows); + for (c = 0; c < n_cols; c++) + { + double ct = 0.; + + for (r = 0; r < n_rows; r++) + cum[c + r * n_cols] = ct += mat[c + r * n_cols]; + } + } + + /* P and Q. */ + { + int i, j; + double Cij, Dij; + + P = Q = 0.; + for (i = 0; i < n_rows; i++) + { + Cij = Dij = 0.; + + for (j = 1; j < n_cols; j++) + Cij += col_tot[j] - cum[j + i * n_cols]; + + if (i > 0) + for (j = 1; j < n_cols; j++) + Dij += cum[j + (i - 1) * n_cols]; + + for (j = 0;;) + { + double fij = mat[j + i * n_cols]; + P += fij * Cij; + Q += fij * Dij; + + if (++j == n_cols) + break; + assert (j < n_cols); + + Cij -= col_tot[j] - cum[j + i * n_cols]; + Dij += col_tot[j - 1] - cum[j - 1 + i * n_cols]; + + if (i > 0) + { + Cij += cum[j - 1 + (i - 1) * n_cols]; + Dij -= cum[j + (i - 1) * n_cols]; + } + } + } + } + + if (cmd.a_statistics[CRS_ST_BTAU]) + v[3] = (P - Q) / sqrt (Dr * Dc); + if (cmd.a_statistics[CRS_ST_CTAU]) + v[4] = (q * (P - Q)) / ((W * W) * (q - 1)); + if (cmd.a_statistics[CRS_ST_GAMMA]) + v[5] = (P - Q) / (P + Q); + + /* ASE for tau-b, tau-c, gamma. Calculations could be + eliminated here, at expense of memory. */ + { + int i, j; + double Cij, Dij; + + btau_cum = ctau_cum = gamma_cum = d_yx_cum = d_xy_cum = 0.; + for (i = 0; i < n_rows; i++) + { + Cij = Dij = 0.; + + for (j = 1; j < n_cols; j++) + Cij += col_tot[j] - cum[j + i * n_cols]; + + if (i > 0) + for (j = 1; j < n_cols; j++) + Dij += cum[j + (i - 1) * n_cols]; + + for (j = 0;;) + { + double fij = mat[j + i * n_cols]; + + if (cmd.a_statistics[CRS_ST_BTAU]) + { + const double temp = (2. * sqrt (Dr * Dc) * (Cij - Dij) + + v[3] * (row_tot[i] * Dc + + col_tot[j] * Dr)); + btau_cum += fij * temp * temp; + } + + { + const double temp = Cij - Dij; + ctau_cum += fij * temp * temp; + } + + if (cmd.a_statistics[CRS_ST_GAMMA]) + { + const double temp = Q * Cij - P * Dij; + gamma_cum += fij * temp * temp; + } + + if (cmd.a_statistics[CRS_ST_D]) + { + d_yx_cum += fij * sqr (Dr * (Cij - Dij) + - (P - Q) * (W - row_tot[i])); + d_xy_cum += fij * sqr (Dc * (Dij - Cij) + - (Q - P) * (W - col_tot[j])); + } + + if (++j == n_cols) + break; + assert (j < n_cols); + + Cij -= col_tot[j] - cum[j + i * n_cols]; + Dij += col_tot[j - 1] - cum[j - 1 + i * n_cols]; + + if (i > 0) + { + Cij += cum[j - 1 + (i - 1) * n_cols]; + Dij -= cum[j + (i - 1) * n_cols]; + } + } + } + } + + btau_var = ((btau_cum + - (W * sqr (W * (P - Q) / sqrt (Dr * Dc) * (Dr + Dc)))) + / sqr (Dr * Dc)); + if (cmd.a_statistics[CRS_ST_BTAU]) + { + ase[3] = sqrt (btau_var); + t[3] = v[3] / (2 * sqrt ((ctau_cum - (P - Q) * (P - Q) / W) + / (Dr * Dc))); + } + if (cmd.a_statistics[CRS_ST_CTAU]) + { + ase[4] = ((2 * q / ((q - 1) * W * W)) + * sqrt (ctau_cum - (P - Q) * (P - Q) / W)); + t[4] = v[4] / ase[4]; + } + if (cmd.a_statistics[CRS_ST_GAMMA]) + { + ase[5] = ((4. / ((P + Q) * (P + Q))) * sqrt (gamma_cum)); + t[5] = v[5] / (2. / (P + Q) + * sqrt (ctau_cum - (P - Q) * (P - Q) / W)); + } + if (cmd.a_statistics[CRS_ST_D]) + { + somers_d_v[0] = (P - Q) / (.5 * (Dc + Dr)); + somers_d_ase[0] = 2. * btau_var / (Dr + Dc) * sqrt (Dr * Dc); + somers_d_t[0] = (somers_d_v[0] + / (4 / (Dc + Dr) + * sqrt (ctau_cum - sqr (P - Q) / W))); + somers_d_v[1] = (P - Q) / Dc; + somers_d_ase[1] = 2. / sqr (Dc) * sqrt (d_xy_cum); + somers_d_t[1] = (somers_d_v[1] + / (2. / Dc + * sqrt (ctau_cum - sqr (P - Q) / W))); + somers_d_v[2] = (P - Q) / Dr; + somers_d_ase[2] = 2. / sqr (Dr) * sqrt (d_yx_cum); + somers_d_t[2] = (somers_d_v[2] + / (2. / Dr + * sqrt (ctau_cum - sqr (P - Q) / W))); + } + + free (cum); + } + + /* Spearman correlation, Pearson's r. */ + if (cmd.a_statistics[CRS_ST_CORR]) + { + double *R = local_alloc (sizeof *R * n_rows); + double *C = local_alloc (sizeof *C * n_cols); + + { + double y, t, c = 0., s = 0.; + int i = 0; + + for (;;) + { + R[i] = s + (row_tot[i] + 1.) / 2.; + y = row_tot[i] - c; + t = s + y; + c = (t - s) - y; + s = t; + if (++i == n_rows) + break; + assert (i < n_rows); + } + } + + { + double y, t, c = 0., s = 0.; + int j = 0; + + for (;;) + { + C[j] = s + (col_tot[j] + 1.) / 2; + y = col_tot[j] - c; + t = s + y; + c = (t - s) - y; + s = t; + if (++j == n_cols) + break; + assert (j < n_cols); + } + } + + calc_r (R, C, &v[6], &t[6], &ase[6]); + t[6] = v[6] / t[6]; + + local_free (R); + local_free (C); + + calc_r ((double *) rows, (double *) cols, &v[7], &t[7], &ase[7]); + t[7] = v[7] / t[7]; + } + + /* Cohen's kappa. */ + if (cmd.a_statistics[CRS_ST_KAPPA] && ns_rows == ns_cols) + { + double sum_fii, sum_rici, sum_fiiri_ci, sum_fijri_ci2, sum_riciri_ci; + int i, j; + + for (sum_fii = sum_rici = sum_fiiri_ci = sum_riciri_ci = 0., i = j = 0; + i < ns_rows; i++, j++) + { + double prod, sum; + + while (col_tot[j] == 0.) + j++; + + prod = row_tot[i] * col_tot[j]; + sum = row_tot[i] + col_tot[j]; + + sum_fii += mat[j + i * n_cols]; + sum_rici += prod; + sum_fiiri_ci += mat[j + i * n_cols] * sum; + sum_riciri_ci += prod * sum; + } + for (sum_fijri_ci2 = 0., i = 0; i < ns_rows; i++) + for (j = 0; j < ns_cols; j++) + { + double sum = row_tot[i] + col_tot[j]; + sum_fijri_ci2 += mat[j + i * n_cols] * sum * sum; + } + + v[8] = (W * sum_fii - sum_rici) / (W * W - sum_rici); + + ase[8] = sqrt ((W * W * sum_rici + + sum_rici * sum_rici + - W * sum_riciri_ci) + / (W * (W * W - sum_rici) * (W * W - sum_rici))); +#if 0 + t[8] = v[8] / sqrt (W * (((sum_fii * (W - sum_fii)) + / sqr (W * W - sum_rici)) + + ((2. * (W - sum_fii) + * (2. * sum_fii * sum_rici + - W * sum_fiiri_ci)) + / cube (W * W - sum_rici)) + + (sqr (W - sum_fii) + * (W * sum_fijri_ci2 - 4. + * sum_rici * sum_rici) + / hypercube (W * W - sum_rici)))); +#else + t[8] = v[8] / ase[8]; +#endif + } + + return 1; +} + +/* Calculate risk estimate. */ +static int +calc_risk (double *value, double *upper, double *lower, union value *c) +{ + double f11, f12, f21, f22; + double v; + + { + int i; + + for (i = 0; i < 3; i++) + value[i] = upper[i] = lower[i] = SYSMIS; + } + + if (ns_rows != 2 || ns_cols != 2) + return 0; + + { + int nz_cols[2]; + int i, j; + + for (i = j = 0; i < n_cols; i++) + if (col_tot[i] != 0.) + { + nz_cols[j++] = i; + if (j == 2) + break; + } + + assert (j == 2); + + f11 = mat[nz_cols[0]]; + f12 = mat[nz_cols[1]]; + f21 = mat[nz_cols[0] + n_cols]; + f22 = mat[nz_cols[1] + n_cols]; + + c[0] = cols[nz_cols[0]]; + c[1] = cols[nz_cols[1]]; + } + + value[0] = (f11 * f22) / (f12 * f21); + v = sqrt (1. / f11 + 1. / f12 + 1. / f21 + 1. / f22); + lower[0] = value[0] * exp (-1.960 * v); + upper[0] = value[0] * exp (1.960 * v); + + value[1] = (f11 * (f21 + f22)) / (f21 * (f11 + f12)); + v = sqrt ((f12 / (f11 * (f11 + f12))) + + (f22 / (f21 * (f21 + f22)))); + lower[1] = value[1] * exp (-1.960 * v); + upper[1] = value[1] * exp (1.960 * v); + + value[2] = (f12 * (f21 + f22)) / (f22 * (f11 + f12)); + v = sqrt ((f11 / (f12 * (f11 + f12))) + + (f21 / (f22 * (f21 + f22)))); + lower[2] = value[2] * exp (-1.960 * v); + upper[2] = value[2] * exp (1.960 * v); + + return 1; +} + +/* Calculate directional measures. */ +static int +calc_directional (double v[N_DIRECTIONAL], double ase[N_DIRECTIONAL], + double t[N_DIRECTIONAL]) +{ + { + int i; + + for (i = 0; i < N_DIRECTIONAL; i++) + v[i] = ase[i] = t[i] = SYSMIS; + } + + /* Lambda. */ + if (cmd.a_statistics[CRS_ST_LAMBDA]) + { + double *fim = xmalloc (sizeof *fim * n_rows); + int *fim_index = xmalloc (sizeof *fim_index * n_rows); + double *fmj = xmalloc (sizeof *fmj * n_cols); + int *fmj_index = xmalloc (sizeof *fmj_index * n_cols); + double sum_fim, sum_fmj; + double rm, cm; + int rm_index, cm_index; + int i, j; + + /* Find maximum for each row and their sum. */ + for (sum_fim = 0., i = 0; i < n_rows; i++) + { + double max = mat[i * n_cols]; + int index = 0; + + for (j = 1; j < n_cols; j++) + if (mat[j + i * n_cols] > max) + { + max = mat[j + i * n_cols]; + index = j; + } + + sum_fim += fim[i] = max; + fim_index[i] = index; + } + + /* Find maximum for each column. */ + for (sum_fmj = 0., j = 0; j < n_cols; j++) + { + double max = mat[j]; + int index = 0; + + for (i = 1; i < n_rows; i++) + if (mat[j + i * n_cols] > max) + { + max = mat[j + i * n_cols]; + index = i; + } + + sum_fmj += fmj[j] = max; + fmj_index[j] = index; + } + + /* Find maximum row total. */ + rm = row_tot[0]; + rm_index = 0; + for (i = 1; i < n_rows; i++) + if (row_tot[i] > rm) + { + rm = row_tot[i]; + rm_index = i; + } + + /* Find maximum column total. */ + cm = col_tot[0]; + cm_index = 0; + for (j = 1; j < n_cols; j++) + if (col_tot[j] > cm) + { + cm = col_tot[j]; + cm_index = j; + } + + v[0] = (sum_fim + sum_fmj - cm - rm) / (2. * W - rm - cm); + v[1] = (sum_fmj - rm) / (W - rm); + v[2] = (sum_fim - cm) / (W - cm); + + /* ASE1 for Y given X. */ + { + double accum; + + for (accum = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + const int deltaj = j == cm_index; + accum += (mat[j + i * n_cols] + * sqr ((j == fim_index[i]) + - deltaj + + v[0] * deltaj)); + } + + ase[2] = sqrt (accum - W * v[0]) / (W - cm); + } + + /* ASE0 for Y given X. */ + { + double accum; + + for (accum = 0., i = 0; i < n_rows; i++) + if (cm_index != fim_index[i]) + accum += (mat[i * n_cols + fim_index[i]] + + mat[i * n_cols + cm_index]); + t[2] = v[2] / (sqrt (accum - sqr (sum_fim - cm) / W) / (W - cm)); + } + + /* ASE1 for X given Y. */ + { + double accum; + + for (accum = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + const int deltaj = i == rm_index; + accum += (mat[j + i * n_cols] + * sqr ((i == fmj_index[j]) + - deltaj + + v[0] * deltaj)); + } + + ase[1] = sqrt (accum - W * v[0]) / (W - rm); + } + + /* ASE0 for X given Y. */ + { + double accum; + + for (accum = 0., j = 0; j < n_cols; j++) + if (rm_index != fmj_index[j]) + accum += (mat[j + n_cols * fmj_index[j]] + + mat[j + n_cols * rm_index]); + t[1] = v[1] / (sqrt (accum - sqr (sum_fmj - rm) / W) / (W - rm)); + } + + /* Symmetric ASE0 and ASE1. */ + { + double accum0; + double accum1; + + for (accum0 = accum1 = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + int temp0 = (fmj_index[j] == i) + (fim_index[i] == j); + int temp1 = (i == rm_index) + (j == cm_index); + accum0 += mat[j + i * n_cols] * sqr (temp0 - temp1); + accum1 += (mat[j + i * n_cols] + * sqr (temp0 + (v[0] - 1.) * temp1)); + } + ase[0] = sqrt (accum1 - 4. * W * v[0] * v[0]) / (2. * W - rm - cm); + t[0] = v[0] / (sqrt (accum0 - sqr ((sum_fim + sum_fmj - cm - rm) / W)) + / (2. * W - rm - cm)); + } + + free (fim); + free (fim_index); + free (fmj); + free (fmj_index); + + { + double sum_fij2_ri, sum_fij2_ci; + double sum_ri2, sum_cj2; + + for (sum_fij2_ri = sum_fij2_ci = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + double temp = sqr (mat[j + i * n_cols]); + sum_fij2_ri += temp / row_tot[i]; + sum_fij2_ci += temp / col_tot[j]; + } + + for (sum_ri2 = 0., i = 0; i < n_rows; i++) + sum_ri2 += row_tot[i] * row_tot[i]; + + for (sum_cj2 = 0., j = 0; j < n_cols; j++) + sum_cj2 += col_tot[j] * col_tot[j]; + + v[3] = (W * sum_fij2_ci - sum_ri2) / (W * W - sum_ri2); + v[4] = (W * sum_fij2_ri - sum_cj2) / (W * W - sum_cj2); + } + } + + if (cmd.a_statistics[CRS_ST_UC]) + { + double UX, UY, UXY, P; + double ase1_yx, ase1_xy, ase1_sym; + int i, j; + + for (UX = 0., i = 0; i < n_rows; i++) + if (row_tot[i] > 0.) + UX -= row_tot[i] / W * log (row_tot[i] / W); + + for (UY = 0., j = 0; j < n_cols; j++) + if (col_tot[j] > 0.) + UY -= col_tot[j] / W * log (col_tot[j] / W); + + for (UXY = P = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + double entry = mat[j + i * n_cols]; + + if (entry <= 0.) + continue; + + P += entry * sqr (log (col_tot[j] * row_tot[i] / (W * entry))); + UXY -= entry / W * log (entry / W); + } + + for (ase1_yx = ase1_xy = ase1_sym = 0., i = 0; i < n_rows; i++) + for (j = 0; j < n_cols; j++) + { + double entry = mat[j + i * n_cols]; + + if (entry <= 0.) + continue; + + ase1_yx += entry * sqr (UY * log (entry / row_tot[i]) + + (UX - UXY) * log (col_tot[j] / W)); + ase1_xy += entry * sqr (UX * log (entry / col_tot[j]) + + (UY - UXY) * log (row_tot[i] / W)); + ase1_sym += entry * sqr ((UXY + * log (row_tot[i] * col_tot[j] / (W * W))) + - (UX + UY) * log (entry / W)); + } + + v[5] = 2. * ((UX + UY - UXY) / (UX + UY)); + ase[5] = (2. / (W * sqr (UX + UY))) * sqrt (ase1_sym); + t[5] = v[5] / ((2. / (W * (UX + UY))) + * sqrt (P - sqr (UX + UY - UXY) / W)); + + v[6] = (UX + UY - UXY) / UX; + ase[6] = sqrt (ase1_xy) / (W * UX * UX); + t[6] = v[6] / (sqrt (P - W * sqr (UX + UY - UXY)) / (W * UX)); + + v[7] = (UX + UY - UXY) / UY; + ase[7] = sqrt (ase1_yx) / (W * UY * UY); + t[7] = v[7] / (sqrt (P - W * sqr (UX + UY - UXY)) / (W * UY)); + } + + /* Somers' D. */ + if (cmd.a_statistics[CRS_ST_D]) + { + int i; + + if (!sym) + calc_symmetric (NULL, NULL, NULL); + for (i = 0; i < 3; i++) + { + v[8 + i] = somers_d_v[i]; + ase[8 + i] = somers_d_ase[i]; + t[8 + i] = somers_d_t[i]; + } + } + + /* Eta. */ + if (cmd.a_statistics[CRS_ST_ETA]) + { + { + double sum_Xr, sum_X2r; + double SX, SXW; + int i, j; + + for (sum_Xr = sum_X2r = 0., i = 0; i < n_rows; i++) + { + sum_Xr += rows[i].f * row_tot[i]; + sum_X2r += rows[i].f * rows[i].f * row_tot[i]; + } + SX = sum_X2r - sum_Xr * sum_Xr / W; + + for (SXW = 0., j = 0; j < n_cols; j++) + { + double cum; + + for (cum = 0., i = 0; i < n_rows; i++) + { + SXW += rows[i].f * rows[i].f * mat[j + i * n_cols]; + cum += rows[i].f * mat[j + i * n_cols]; + } + + SXW -= cum * cum / col_tot[j]; + } + v[11] = sqrt (1. - SXW / SX); + } + + { + double sum_Yc, sum_Y2c; + double SY, SYW; + int i, j; + + for (sum_Yc = sum_Y2c = 0., i = 0; i < n_cols; i++) + { + sum_Yc += cols[i].f * col_tot[i]; + sum_Y2c += cols[i].f * cols[i].f * col_tot[i]; + } + SY = sum_Y2c - sum_Yc * sum_Yc / W; + + for (SYW = 0., i = 0; i < n_rows; i++) + { + double cum; + + for (cum = 0., j = 0; j < n_cols; j++) + { + SYW += cols[j].f * cols[j].f * mat[j + i * n_cols]; + cum += cols[j].f * mat[j + i * n_cols]; + } + + SYW -= cum * cum / row_tot[i]; + } + v[12] = sqrt (1. - SYW / SY); + } + } + + return 1; +} + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/data-in.c b/src/data-in.c new file mode 100644 index 00000000..04c035d4 --- /dev/null +++ b/src/data-in.c @@ -0,0 +1,1591 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include "data-in.h" +#include "error.h" +#include "getline.h" +#include "julcal/julcal.h" +#include "lexer.h" +#include "magic.h" +#include "misc.h" +#include "settings.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + + +/* Specialized error routine. */ + +static void dls_error (const struct data_in *, const char *format, ...) + __attribute__ ((format (printf, 2, 3))); + +static void +dls_error (const struct data_in *i, const char *format, ...) +{ + char buf[1024]; + + if (i->flags & DI_IGNORE_ERROR) + return; + + { + va_list args; + + va_start (args, format); + snprintf (buf, 1024, format, args); + va_end (args); + } + + { + struct error e; + struct string title; + + ds_init (NULL, &title, 64); + if (!getl_reading_script) + ds_concat (&title, _("data-file error: ")); + if (i->f1 == i->f2) + ds_printf (&title, _("(column %d"), i->f1); + else + ds_printf (&title, _("(columns %d-%d"), i->f1, i->f2); + ds_printf (&title, _(", field type %s) "), fmt_to_string (&i->format)); + + e.class = DE; + err_location (&e.where); + e.title = ds_value (&title); + e.text = buf; + + err_vmsg (&e); + + ds_destroy (&title); + } +} + +/* Excludes leading and trailing whitespace from I by adjusting + pointers. */ +static void +trim_whitespace (struct data_in *i) +{ + while (i->s < i->e && isspace (i->s[0])) + i->s++; + + while (i->s < i->e && isspace (i->e[-1])) + i->e--; +} + +/* Returns nonzero if we're not at the end of the string being + parsed. */ +static inline int +have_char (struct data_in *i) +{ + return i->s < i->e; +} + +/* Format parsers. */ + +static int parse_int (struct data_in *i, long *result); + +/* This function is based on strtod() from the GNU C library. */ +static int +parse_numeric (struct data_in *i) +{ + short int sign; /* +1 or -1. */ + double num; /* The number so far. */ + + int got_dot; /* Found a decimal point. */ + int got_digit; /* Count of digits. */ + + int decimal; /* Decimal point character. */ + int grouping; /* Grouping character. */ + + long int exponent; /* Number's exponent. */ + int type; /* Usually same as i->format.type. */ + + trim_whitespace (i); + + type = i->format.type; + if (type == FMT_DOLLAR && have_char (i) && *i->s == '$') + { + i->s++; + type = FMT_COMMA; + } + + /* Get the sign. */ + if (have_char (i)) + { + sign = *i->s == '-' ? -1 : 1; + if (*i->s == '-' || *i->s == '+') + i->s++; + } + + if (type != FMT_DOT) + { + decimal = set_decimal; + grouping = set_grouping; + } + else + { + decimal = set_grouping; + grouping = set_decimal; + } + + i->v->f = SYSMIS; + num = 0.0; + got_dot = 0; + got_digit = 0; + exponent = 0; + for (; have_char (i); i->s++) + { + if (isdigit (*i->s)) + { + got_digit++; + + /* Make sure that multiplication by 10 will not overflow. */ + if (num > DBL_MAX * 0.1) + /* The value of the digit doesn't matter, since we have already + gotten as many digits as can be represented in a `double'. + This doesn't necessarily mean the result will overflow. + The exponent may reduce it to within range. + + We just need to record that there was another + digit so that we can multiply by 10 later. */ + ++exponent; + else + num = (num * 10.0) + (*i->s - '0'); + + /* Keep track of the number of digits after the decimal point. + If we just divided by 10 here, we would lose precision. */ + if (got_dot) + --exponent; + } + else if (!got_dot && *i->s == decimal) + /* Record that we have found the decimal point. */ + got_dot = 1; + else if ((type != FMT_COMMA && type != FMT_DOT) || *i->s != grouping) + /* Any other character terminates the number. */ + break; + } + + if (!got_digit) + { + if (got_dot) + { + i->v->f = SYSMIS; + return 1; + } + goto noconv; + } + + if (have_char (i) + && (tolower (*i->s) == 'e' || tolower (*i->s) == 'd' + || (type == FMT_E && (*i->s == '+' || *i->s == '-')))) + { + /* Get the exponent specified after the `e' or `E'. */ + long exp; + + if (isalpha (*i->s)) + i->s++; + if (!parse_int (i, &exp)) + goto noconv; + + exponent += exp; + } + else if (!got_dot) + exponent -= i->format.d; + + if (type == FMT_PCT && have_char (i) && *i->s == '%') + i->s++; + if (i->s < i->e) + { + dls_error (i, _("Field contents followed by garbage.")); + i->v->f = SYSMIS; + return 0; + } + + if (num == 0.0) + { + i->v->f = 0.0; + return 1; + } + + /* Multiply NUM by 10 to the EXPONENT power, checking for overflow + and underflow. */ + + if (exponent < 0) + { + if (-exponent + got_digit > -(DBL_MIN_10_EXP) + 5 + || num < DBL_MIN * pow (10.0, (double) -exponent)) + goto underflow; + num *= pow (10.0, (double) exponent); + } + else if (exponent > 0) + { + if (num > DBL_MAX * pow (10.0, (double) -exponent)) + goto overflow; + num *= pow (10.0, (double) exponent); + } + + i->v->f = sign * num; + return 1; + +overflow: + /* Return an overflow error. */ + dls_error (i, _("Overflow in floating-point constant.")); + i->v->f = SYSMIS; + return 0; + +underflow: + /* Return an underflow error. */ + dls_error (i, _("Underflow in floating-point constant.")); + i->v->f = 0.0; + return 0; + +noconv: + /* There was no number. */ + dls_error (i, _("Field does not form a valid floating-point constant.")); + i->v->f = SYSMIS; + return 0; +} + +/* Returns the integer value of hex digit C. */ +static inline int +hexit_value (int c) +{ + const char s[] = "0123456789abcdef"; + const char *cp = strchr (s, tolower ((unsigned char) c)); + + assert (cp != NULL); + return cp - s; +} + +static inline int +parse_N (struct data_in *i) +{ + const unsigned char *cp; + + for (cp = i->s; cp < i->e; cp++) + { + if (!isdigit (*cp)) + { + dls_error (i, _("All characters in field must be digits.")); + return 0; + } + + i->v->f = i->v->f * 10.0 + *cp - '0'; + } + + if (i->format.d) + i->v->f /= pow (10.0, i->format.d); + return 1; +} + +static inline int +parse_PIBHEX (struct data_in *i) +{ + double n; + const unsigned char *cp; + + trim_whitespace (i); + + n = 0.0; + for (cp = i->s; cp < i->e; cp++) + { + if (!isxdigit (*cp)) + { + dls_error (i, _("Unrecognized character in field.")); + return 0; + } + + n = n * 16.0 + hexit_value (*cp); + } + + i->v->f = n; + return 1; +} + +static inline int +parse_RBHEX (struct data_in *i) +{ + /* Validate input. */ + trim_whitespace (i); + if ((i->e - i->s) % 2) + { + dls_error (i, _("Field must have even length.")); + return 0; + } + + { + const unsigned char *cp; + + for (cp = i->s; cp < i->e; cp++) + if (!isxdigit (*cp)) + { + dls_error (i, _("Field must contain only hex digits.")); + return 0; + } + } + + /* Parse input. */ + { + union + { + double d; + unsigned char c[sizeof (double)]; + } + u; + + int j; + + memset (u.c, 0, sizeof u.c); + for (j = 0; j < min ((i->e - i->s) / 2, sizeof u.d); j++) + u.c[j] = 16 * hexit_value (i->s[j * 2]) + hexit_value (i->s[j * 2 + 1]); + + i->v->f = u.d; + } + + return 1; +} + +static inline int +parse_Z (struct data_in *i) +{ + char buf[64]; + + /* Warn user that we suck. */ + { + static int warned; + + if (!warned) + { + msg (MW, _("Quality of zoned decimal (Z) input format code is " + "suspect. Check your results three times, report bugs " + "to author.")); + warned = 1; + } + } + + /* Validate input. */ + trim_whitespace (i); + + if (i->e - i->s < 2) + { + dls_error (i, _("Zoned decimal field contains fewer than 2 " + "characters.")); + return 0; + } + + /* Copy sign into buf[0]. */ + if ((i->e[-1] & 0xc0) != 0xc0) + { + dls_error (i, _("Bad sign byte in zoned decimal number.")); + return 0; + } + buf[0] = (i->e[-1] ^ (i->e[-1] >> 1)) & 0x10 ? '-' : '+'; + + /* Copy digits into buf[1 ... len - 1] and terminate string. */ + { + const unsigned char *sp; + char *dp; + + for (sp = i->s, dp = buf + 1; sp < i->e - 1; sp++, dp++) + if (*sp == '.') + *dp = '.'; + else if ((*sp & 0xf0) == 0xf0 && (*sp & 0xf) < 10) + *dp = (*sp & 0xf) + '0'; + else + { + dls_error (i, _("Format error in zoned decimal number.")); + return 0; + } + + *dp = '\0'; + } + + /* Parse as number. */ + { + char *tail; + + i->v->f = strtod ((char *) buf, (char **) &tail); + if ((unsigned char *) tail != i->e) + { + dls_error (i, _("Error in syntax of zoned decimal number.")); + return 0; + } + } + + return 1; +} + +static inline int +parse_IB (struct data_in *i) +{ + char buf[64]; + const char *p; + + unsigned char xor; + + /* We want the data to be in big-endian format. If this is a + little-endian machine, reverse the byte order. */ + if (endian == LITTLE) + { + memcpy (buf, i->s, i->e - i->s); + mm_reverse (buf, i->e - i->s); + p = buf; + } + else + p = i->s; + + /* If the value is negative, we need to logical-NOT each value + before adding it. */ + if (p[0] & 0x80) + xor = 0xff; + else + xor = 0x00; + + { + int j; + + i->v->f = 0.0; + for (j = 0; j < i->e - i->s; j++) + i->v->f = i->v->f * 256.0 + (p[j] ^ xor); + } + + /* If the value is negative, add 1 and set the sign, to complete a + two's-complement negation. */ + if (p[0] & 0x80) + i->v->f = -(i->v->f + 1.0); + + if (i->format.d) + i->v->f /= pow (10.0, i->format.d); + + return 1; +} + +static inline int +parse_PIB (struct data_in *i) +{ + int j; + + i->v->f = 0.0; + if (endian == BIG) + for (j = 0; j < i->e - i->s; j++) + i->v->f = i->v->f * 256.0 + i->s[j]; + else + for (j = i->e - i->s - 1; j >= 0; j--) + i->v->f = i->v->f * 256.0 + i->s[j]; + + if (i->format.d) + i->v->f /= pow (10.0, i->format.d); + + return 1; +} + +static inline int +parse_P (struct data_in *i) +{ + const unsigned char *cp; + + i->v->f = 0.0; + for (cp = i->s; cp < i->e - 1; cp++) + { + i->v->f = i->v->f * 10 + (*cp >> 4); + i->v->f = i->v->f * 10 + (*cp & 15); + } + i->v->f = i->v->f * 10 + (*cp >> 4); + if ((*cp ^ (*cp >> 1)) & 0x10) + i->v->f = -i->v->f; + + if (i->format.d) + i->v->f /= pow (10.0, i->format.d); + + return 1; +} + +static inline int +parse_PK (struct data_in *i) +{ + const unsigned char *cp; + + i->v->f = 0.0; + for (cp = i->s; cp < i->e; cp++) + { + i->v->f = i->v->f * 10 + (*cp >> 4); + i->v->f = i->v->f * 10 + (*cp & 15); + } + + if (i->format.d) + i->v->f /= pow (10.0, i->format.d); + + return 1; +} + +static inline int +parse_RB (struct data_in *i) +{ + union + { + double d; + unsigned char c[sizeof (double)]; + } + u; + + memset (u.c, 0, sizeof u.c); + memcpy (u.c, i->s, min ((int) sizeof (u.c), i->e - i->s)); + i->v->f = u.d; + + return 1; +} + +static inline int +parse_A (struct data_in *i) +{ + ptrdiff_t len = i->e - i->s; + + if (len >= i->format.w) + memcpy (i->v->s, i->s, i->format.w); + else + { + memcpy (i->v->s, i->s, len); + memset (i->v->s + len, ' ', i->format.w - len); + } + +#if __CHECKER__ + memset (i->v->s + i->format.w, '%', + REM_RND_UP (i->format.w, MAX_SHORT_STRING)); +#endif + + return 1; +} + +static inline int +parse_AHEX (struct data_in *i) +{ + /* Validate input. */ + trim_whitespace (i); + if ((i->e - i->s) % 2) + { + dls_error (i, _("Field must have even length.")); + return 0; + } + + { + const unsigned char *cp; + + for (cp = i->s; cp < i->e; cp++) + if (!isxdigit (*cp)) + { + dls_error (i, _("Field must contain only hex digits.")); + return 0; + } + } + + { + int j; + + /* Parse input. */ + for (j = 0; j < min (i->e - i->s, i->format.w); j += 2) + i->v->s[j / 2] = hexit_value (i->s[j]) * 16 + hexit_value (i->s[j + 1]); + memset (i->v->s + (i->e - i->s) / 2, ' ', (i->format.w - (i->e - i->s)) / 2); + } + +#if __CHECKER__ + memset (i->v->s + i->format.w / 2, '%', + REM_RND_UP (i->format.w / 2, MAX_SHORT_STRING)); +#endif + + return 1; +} + +/* Date & time format components. */ + +/* Advances *CP past any whitespace characters. */ +static inline void +skip_whitespace (struct data_in *i) +{ + while (isspace ((unsigned char) *i->s)) + i->s++; +} + +static inline int +parse_leader (struct data_in *i) +{ + skip_whitespace (i); + return 1; +} + +static inline int +force_have_char (struct data_in *i) +{ + if (have_char (i)) + return 1; + + dls_error (i, _("Unexpected end of field.")); + return 0; +} + +static int +parse_int (struct data_in *i, long *result) +{ + int negative = 0; + + if (!force_have_char (i)) + return 0; + + if (*i->s == '+') + { + i->s++; + force_have_char (i); + } + else if (*i->s == '-') + { + negative = 1; + i->s++; + force_have_char (i); + } + + if (!isdigit (*i->s)) + { + dls_error (i, _("Digit expected in field.")); + return 0; + } + + *result = 0; + for (;;) + { + *result = *result * 10 + *i->s++ - '0'; + if (!have_char (i) || !isdigit (*i->s)) + break; + } + + if (negative) + *result = -*result; + return 1; +} + +static int +parse_day (struct data_in *i, long *day) +{ + if (!parse_int (i, day)) + return 0; + if (*day >= 1 && *day <= 31) + return 1; + + dls_error (i, _("Day (%ld) must be between 1 and 31."), *day); + return 0; +} + +static int +parse_day_count (struct data_in *i, long *day_count) +{ + return parse_int (i, day_count); +} + +static int +parse_date_delimiter (struct data_in *i) +{ + int delim = 0; + + while (have_char (i) + && (*i->s == '-' || *i->s == '/' || isspace (*i->s) + || *i->s == '.' || *i->s == ',')) + { + delim = 1; + i->s++; + } + if (delim) + return 1; + + dls_error (i, _("Delimiter expected between fields in date.")); + return 0; +} + +/* Formats NUMBER as Roman numerals in ROMAN, or as Arabic numerals if + the Roman expansion would be too long. */ +static void +to_roman (int number, char roman[32]) +{ + int save_number = number; + + struct roman_digit + { + int value; /* Value corresponding to this digit. */ + char name; /* Digit name. */ + }; + + static const struct roman_digit roman_tab[7] = + { + {1000, 'M'}, + {500, 'D'}, + {100, 'C'}, + {50, 'L'}, + {10, 'X'}, + {5, 'V'}, + {1, 'I'}, + }; + + char *cp = roman; + + int i, j; + + assert (32 >= INT_DIGITS + 1); + if (number == 0) + goto arabic; + + if (number < 0) + { + *cp++ = '-'; + number = -number; + } + + for (i = 0; i < 7; i++) + { + int digit = roman_tab[i].value; + while (number >= digit) + { + number -= digit; + if (cp > &roman[30]) + goto arabic; + *cp++ = roman_tab[i].name; + } + + for (j = i + 1; j < 7; j++) + { + if (i == 4 && j == 5) /* VX is not a shortened form of V. */ + break; + + digit = roman_tab[i].value - roman_tab[j].value; + while (number >= digit) + { + number -= digit; + if (cp > &roman[29]) + goto arabic; + *cp++ = roman_tab[j].name; + *cp++ = roman_tab[i].name; + } + } + } + *cp = 0; + return; + +arabic: + sprintf (roman, "%d", save_number); +} + +/* Returns true if C is a (lowercase) roman numeral. */ +#define CHAR_IS_ROMAN(C) \ + ((C) == 'x' || (C) == 'v' || (C) == 'i') + +/* Returns the value of a single (lowercase) roman numeral. */ +#define ROMAN_VALUE(C) \ + ((C) == 'x' ? 10 : ((C) == 'v' ? 5 : 1)) + +static int +parse_month (struct data_in *i, long *month) +{ + if (!force_have_char (i)) + return 0; + + if (isdigit (*i->s)) + { + if (!parse_int (i, month)) + return 0; + if (*month >= 1 && *month <= 12) + return 1; + + dls_error (i, _("Month (%ld) must be between 1 and 12."), *month); + return 0; + } + + if (CHAR_IS_ROMAN (tolower (*i->s))) + { + int last = ROMAN_VALUE (tolower (*i->s)); + + *month = 0; + for (;;) + { + int value; + + i->s++; + if (!have_char || !CHAR_IS_ROMAN (tolower (*i->s))) + { + if (last != INT_MAX) + *month += last; + break; + } + + value = ROMAN_VALUE (tolower (*i->s)); + if (last == INT_MAX) + *month += value; + else if (value > last) + { + *month += value - last; + last = INT_MAX; + } + else + { + *month += last; + last = value; + } + } + + if (*month < 1 || *month > 12) + { + char buf[32]; + + to_roman (*month, buf); + dls_error (i, _("Month (%s) must be between I and XII."), buf); + return 0; + } + + return 1; + } + + { + static const char *months[12] = + { + "january", "february", "march", "april", "may", "june", + "july", "august", "september", "october", "november", "december", + }; + + char month_buf[32]; + char *mp; + + int j; + + for (mp = month_buf; + have_char (i) && isalpha (*i->s) && mp < &month_buf[31]; + i->s++) + *mp++ = tolower (*i->s); + *mp = '\0'; + + if (have_char (i) && isalpha (*i->s)) + { + dls_error (i, _("Month name (%s...) is too long."), month_buf); + return 0; + } + + for (j = 0; j < 12; j++) + if (lex_id_match (months[j], month_buf)) + { + *month = j + 1; + return 1; + } + + dls_error (i, _("Bad month name (%s)."), month_buf); + return 0; + } +} + +static int +parse_year (struct data_in *i, long *year) +{ + if (!parse_int (i, year)) + return 0; + + if (*year >= 0 && *year <= 199) + *year += 1900; + if (*year >= 1582 || *year <= 19999) + return 1; + + dls_error (i, _("Year (%ld) must be between 1582 and 19999."), *year); + return 0; +} + +static int +parse_trailer (struct data_in *i) +{ + skip_whitespace (i); + if (!have_char (i)) + return 1; + + dls_error (i, _("Trailing garbage \"%s\" following date."), i->s); + return 0; +} + +static int +parse_julian (struct data_in *i, long *julian) +{ + if (!parse_int (i, julian)) + return 0; + + { + int day = *julian % 1000; + + if (day < 1 || day > 366) + { + dls_error (i, _("Julian day (%d) must be between 1 and 366."), day); + return 0; + } + } + + { + int year = *julian / 1000; + + if (year >= 0 && year <= 199) + *julian += 1900000L; + else if (year < 1582 || year > 19999) + { + dls_error (i, _("Year (%d) must be between 1582 and 19999."), year); + return 0; + } + } + + return 1; +} + +static int +parse_quarter (struct data_in *i, long *quarter) +{ + if (!parse_int (i, quarter)) + return 0; + if (*quarter >= 1 && *quarter <= 4) + return 1; + + dls_error (i, _("Quarter (%ld) must be between 1 and 4."), *quarter); + return 0; +} + +static int +parse_q_delimiter (struct data_in *i) +{ + skip_whitespace (i); + if (!have_char (i) || tolower (*i->s) != 'q') + { + dls_error (i, _("`Q' expected between quarter and year.")); + return 0; + } + i->s++; + skip_whitespace (i); + return 1; +} + +static int +parse_week (struct data_in *i, long *week) +{ + if (!parse_int (i, week)) + return 0; + if (*week >= 1 && *week <= 53) + return 1; + + dls_error (i, _("Week (%ld) must be between 1 and 53."), *week); + return 0; +} + +static int +parse_wk_delimiter (struct data_in *i) +{ + skip_whitespace (i); + if (i->s + 1 >= i->e + || tolower (i->s[0]) != 'w' || tolower (i->s[1]) != 'k') + { + dls_error (i, _("`WK' expected between week and year.")); + return 0; + } + i->s += 2; + skip_whitespace (i); + return 1; +} + +static int +parse_time_delimiter (struct data_in *i) +{ + int delim = 0; + + while (have_char (i) + && (*i->s == ':' || *i->s == '.' || isspace (*i->s))) + { + delim = 1; + i->s++; + } + + if (delim) + return 1; + + dls_error (i, _("Delimiter expected between fields in time.")); + return 0; +} + +static int +parse_hour (struct data_in *i, long *hour) +{ + if (!parse_int (i, hour)) + return 0; + if (*hour >= 0) + return 1; + + dls_error (i, _("Hour (%ld) must be positive."), *hour); + return 0; +} + +static int +parse_minute (struct data_in *i, long *minute) +{ + if (!parse_int (i, minute)) + return 0; + if (*minute >= 0 && *minute <= 59) + return 1; + + dls_error (i, _("Minute (%ld) must be between 0 and 59."), *minute); + return 0; +} + +static int +parse_opt_second (struct data_in *i, double *second) +{ + int delim = 0; + + char buf[64]; + char *cp; + + while (have_char (i) + && (*i->s == ':' || *i->s == '.' || isspace (*i->s))) + { + delim = 1; + i->s++; + } + + if (!delim || !isdigit (*i->s)) + { + *second = 0.0; + return 1; + } + + cp = buf; + while (have_char (i) && isdigit (*i->s)) + *cp++ = *i->s++; + if (have_char (i) && *i->s == '.') + *cp++ = *i->s++; + while (have_char (i) && isdigit (*i->s)) + *cp++ = *i->s++; + *cp = '\0'; + + *second = strtod (buf, NULL); + + return 1; +} + +static int +parse_hour24 (struct data_in *i, long *hour24) +{ + if (!parse_int (i, hour24)) + return 0; + if (*hour24 >= 0 && *hour24 <= 23) + return 1; + + dls_error (i, _("Hour (%ld) must be between 0 and 23."), *hour24); + return 0; +} + + +static int +parse_weekday (struct data_in *i, int *weekday) +{ + /* PORTME */ + #define TUPLE(A,B) \ + (((A) << 8) + (B)) + + if (i->s + 1 >= i->e) + { + dls_error (i, _("Day of the week expected in date value.")); + return 0; + } + + switch (TUPLE (tolower (i->s[0]), tolower (i->s[1]))) + { + case TUPLE ('s', 'u'): + *weekday = 1; + break; + + case TUPLE ('m', 'o'): + *weekday = 2; + break; + + case TUPLE ('t', 'u'): + *weekday = 3; + break; + + case TUPLE ('w', 'e'): + *weekday = 4; + break; + + case TUPLE ('t', 'h'): + *weekday = 5; + break; + + case TUPLE ('f', 'r'): + *weekday = 6; + break; + + case TUPLE ('s', 'a'): + *weekday = 7; + break; + + default: + dls_error (i, _("Day of the week expected in date value.")); + return 0; + } + + while (have_char (i) && isalpha (*i->s)) + i->s++; + + return 1; + + #undef TUPLE +} + +static int +parse_spaces (struct data_in *i) +{ + skip_whitespace (i); + return 1; +} + +static int +parse_sign (struct data_in *i, int *sign) +{ + if (!force_have_char (i)) + return 0; + + switch (*i->s) + { + case '-': + i->s++; + *sign = 1; + break; + + case '+': + i->s++; + /* fall through */ + + default: + *sign = 0; + break; + } + + return 1; +} + +/* Date & time formats. */ + +static int +valid_date (struct data_in *i) +{ + if (i->v->f == SYSMIS) + { + dls_error (i, _("Date is not in valid range between " + "15 Oct 1582 and 31 Dec 19999.")); + return 0; + } + else + return 1; +} + +static int +parse_DATE (struct data_in *i) +{ + long day, month, year; + + if (!parse_leader (i) + || !parse_day (i, &day) + || !parse_date_delimiter (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, month, day); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_ADATE (struct data_in *i) +{ + long month, day, year; + + if (!parse_leader (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_day (i, &day) + || !parse_date_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, month, day); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_EDATE (struct data_in *i) +{ + long month, day, year; + + if (!parse_leader (i) + || !parse_day (i, &day) + || !parse_date_delimiter (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, month, day); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_SDATE (struct data_in *i) +{ + long month, day, year; + + if (!parse_leader (i) + || !parse_year (i, &year) + || !parse_date_delimiter (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_day (i, &day) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, month, day); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_JDATE (struct data_in *i) +{ + long julian; + + if (!parse_leader (i) + || !parse_julian (i, &julian) + || !parse_trailer (i)) + return 0; + + if (julian / 1000 == 1582) + i->v->f = calendar_to_julian (1583, 1, 1) - 365; + else + i->v->f = calendar_to_julian (julian / 1000, 1, 1); + + if (valid_date (i)) + { + i->v->f = (i->v->f + julian % 1000 - 1) * 60. * 60. * 24.; + if (i->v->f < 0.) + i->v->f = SYSMIS; + } + + return valid_date (i); +} + +static int +parse_QYR (struct data_in *i) +{ + long quarter, year; + + if (!parse_leader (i) + || !parse_quarter (i, &quarter) + || !parse_q_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, (quarter - 1) * 3 + 1, 1); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_MOYR (struct data_in *i) +{ + long month, year; + + if (!parse_leader (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, month, 1); + if (!valid_date (i)) + return 0; + i->v->f *= 60. * 60. * 24.; + + return 1; +} + +static int +parse_WKYR (struct data_in *i) +{ + long week, year; + + if (!parse_leader (i) + || !parse_week (i, &week) + || !parse_wk_delimiter (i) + || !parse_year (i, &year) + || !parse_trailer (i)) + return 0; + + i->v->f = calendar_to_julian (year, 1, 1); + if (!valid_date (i)) + return 0; + i->v->f = (i->v->f + (week - 1) * 7) * 60. * 60. * 24.; + + return 1; +} + +static int +parse_TIME (struct data_in *i) +{ + int sign; + double second; + long hour, minute; + + if (!parse_leader (i) + || !parse_sign (i, &sign) + || !parse_spaces (i) + || !parse_hour (i, &hour) + || !parse_time_delimiter (i) + || !parse_minute (i, &minute) + || !parse_opt_second (i, &second)) + return 0; + + i->v->f = hour * 60. * 60. + minute * 60. + second; + if (sign) + i->v->f = -i->v->f; + return 1; +} + +static int +parse_DTIME (struct data_in *i) +{ + int sign; + long day_count, hour; + double second; + long minute; + + if (!parse_leader (i) + || !parse_sign (i, &sign) + || !parse_spaces (i) + || !parse_day_count (i, &day_count) + || !parse_time_delimiter (i) + || !parse_hour (i, &hour) + || !parse_time_delimiter (i) + || !parse_minute (i, &minute) + || !parse_opt_second (i, &second)) + return 0; + + i->v->f = (day_count * 60. * 60. * 24. + + hour * 60. * 60. + + minute * 60. + + second); + if (sign) + i->v->f = -i->v->f; + return 1; +} + +static int +parse_DATETIME (struct data_in *i) +{ + long day, month, year; + long hour24; + double second; + long minute; + + if (!parse_leader (i) + || !parse_day (i, &day) + || !parse_date_delimiter (i) + || !parse_month (i, &month) + || !parse_date_delimiter (i) + || !parse_year (i, &year) + || !parse_time_delimiter (i) + || !parse_hour24 (i, &hour24) + || !parse_time_delimiter (i) + || !parse_minute (i, &minute) + || !parse_opt_second (i, &second)) + return 0; + + i->v->f = calendar_to_julian (year, month, day); + if (!valid_date (i)) + return 0; + i->v->f = (i->v->f * 60. * 60. * 24. + + hour24 * 60. * 60. + + minute * 60. + + second); + + return 1; +} + +static int +parse_WKDAY (struct data_in *i) +{ + int weekday; + + if (!parse_leader (i) + || !parse_weekday (i, &weekday) + || !parse_trailer (i)) + return 0; + + i->v->f = weekday; + return 1; +} + +static int +parse_MONTH (struct data_in *i) +{ + long month; + + if (!parse_leader (i) + || !parse_month (i, &month) + || !parse_trailer (i)) + return 0; + + i->v->f = month; + return 1; +} + +/* Main dispatcher. */ + +static void +default_result (struct data_in *i) +{ + const struct fmt_desc *const fmt = &formats[i->format.type]; + + /* Default to SYSMIS or blanks. */ + if (fmt->cat & FCAT_STRING) + { +#if __CHECKER__ + memset (i->v->s, ' ', ROUND_UP (i->format.w, MAX_SHORT_STRING)); +#else + memset (i->v->s, ' ', i->format.w); +#endif + } + else + i->v->f = set_blanks; +} + +int +data_in (struct data_in *i) +{ + const struct fmt_desc *const fmt = &formats[i->format.type]; + + /* Check that we've got a string to work with. */ + if (i->e == i->s || i->format.w <= 0) + { + default_result (i); + return 1; + } + + i->f2 = i->f1 + (i->e - i->s) - 1; + + /* Make sure that the string isn't too long. */ + if (i->format.w > fmt->Imax_w) + { + dls_error (i, _("Field too long (%d characters). Truncated after " + "character %d."), + i->format.w, fmt->Imax_w); + i->format.w = fmt->Imax_w; + } + + if (fmt->cat & FCAT_BLANKS_SYSMIS) + { + const unsigned char *cp; + + cp = i->s; + for (;;) + { + if (!isspace (*cp)) + break; + + if (++cp == i->e) + { + i->v->f = set_blanks; + return 1; + } + } + } + + { + static int (*const handlers[FMT_NUMBER_OF_FORMATS])(struct data_in *) = + { + parse_numeric, parse_N, parse_numeric, parse_numeric, + parse_numeric, parse_numeric, parse_numeric, + parse_Z, parse_A, parse_AHEX, parse_IB, parse_P, parse_PIB, + parse_PIBHEX, parse_PK, parse_RB, parse_RBHEX, + NULL, NULL, NULL, NULL, NULL, + parse_DATE, parse_EDATE, parse_SDATE, parse_ADATE, parse_JDATE, + parse_QYR, parse_MOYR, parse_WKYR, + parse_DATETIME, parse_TIME, parse_DTIME, + parse_WKDAY, parse_MONTH, + }; + + int (*handler)(struct data_in *); + int success; + + handler = handlers[i->format.type]; + assert (handler != NULL); + + success = handler (i); + if (!success) + default_result (i); + + return success; + } +} + +/* Utility function. */ + +/* Sets DI->{s,e} appropriately given that LINE has length LEN and the + field starts at one-based column FC and ends at one-based column + LC, inclusive. */ +void +data_in_finite_line (struct data_in *di, const char *line, size_t len, + int fc, int lc) +{ + di->s = line + ((size_t) fc <= len ? fc - 1 : len); + di->e = line + ((size_t) lc <= len ? lc : len); +} diff --git a/src/data-in.h b/src/data-in.h new file mode 100644 index 00000000..c5209205 --- /dev/null +++ b/src/data-in.h @@ -0,0 +1,59 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !data_in_h +#define data_in_h 1 + +#include "format.h" + +/* Flags. */ +enum + { + DI_IGNORE_ERROR = 01, /* Don't report errors to the user. */ + }; + +/* Information about parsing one data field. */ +struct data_in + { + const unsigned char *s; /* Source start. */ + const unsigned char *e; /* Source end. */ + + union value *v; /* Destination. */ + + int flags; /* Zero or more of DI_*. */ + int f1, f2; /* Columns the field was taken from. */ + struct fmt_spec format; /* Format specification to use. */ + }; + +int data_in (struct data_in *); + +void data_in_finite_line (struct data_in *di, const char *line, size_t len, + int fc, int lc); + +#if __GNUC__ >= 2 +extern inline void +data_in_finite_line (struct data_in *di, const char *line, size_t len, + int fc, int lc) +{ + di->s = line + ((size_t) fc <= len ? fc - 1 : len); + di->e = line + ((size_t) lc <= len ? lc : len); +} +#endif /* GNU C */ + +#endif /* data-in.h */ diff --git a/src/data-list.c b/src/data-list.c new file mode 100644 index 00000000..c775c8da --- /dev/null +++ b/src/data-list.c @@ -0,0 +1,1935 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "data-in.h" +#include "debug-print.h" +#include "dfm.h" +#include "error.h" +#include "file-handle.h" +#include "format.h" +#include "lexer.h" +#include "misc.h" +#include "settings.h" +#include "str.h" +#include "tab.h" +#include "var.h" +#include "vfm.h" + +/* Utility function. */ + +/* FIXME: Either REPEATING DATA must be the last transformation, or we + must multiplex the transformations that follow (i.e., perform them + for every case that we produce from a repetition instance). + Currently we do neither. We should do one or the other. */ + +/* Describes how to parse one variable. */ +struct dls_var_spec + { + struct dls_var_spec *next; + struct variable *v; /* Associated variable. Used only in + parsing. Not safe later. */ + char name[9]; /* Free-format: Name of variable. */ + int rec; /* Fixed-format: Record number (1-based). */ + int fc, lc; /* Fixed-format: Column numbers in record. */ + struct fmt_spec input; /* Input format of this field. */ + int fv; /* First value in case. */ + int type; /* 0=numeric, >0=width of alpha field. */ + }; + +/* Constants for DATA LIST type. */ +/* Must match table in cmd_data_list(). */ +enum + { + DLS_FIXED, + DLS_FREE, + DLS_LIST + }; + +/* DATA LIST private data structure. */ +struct data_list_pgm + { + struct trns_header h; + struct dls_var_spec *spec; /* Variable parsing specifications. */ + struct file_handle *handle; /* Input file, never NULL. */ + /* Do not reorder preceding fields. */ + + int type; /* A DLS_* constant. */ + struct variable *end; /* Variable specified on END subcommand. */ + int eof; /* End of file encountered. */ + int nrec; /* Number of records. */ + }; + +/* Holds information on parsing the data file. */ +static struct data_list_pgm dls; + +/* Pointer to a pointer to where the first dls_var_spec should go. */ +static struct dls_var_spec **first; + +/* Last dls_var_spec in the chain. Used for building the linked-list. */ +static struct dls_var_spec *next; + +static int parse_fixed (void); +static int parse_free (void); +static void dump_fixed_table (void); +static void dump_free_table (void); +static void destroy_dls (struct trns_header *); +static int read_one_case (struct trns_header *, struct ccase *); + +/* Message title for REPEATING DATA. */ +#define RPD_ERR "REPEATING DATA: " + +int +cmd_data_list (void) +{ + /* 0=print no table, 1=print table. (TABLE subcommand.) */ + int table = -1; + + lex_match_id ("DATA"); + lex_match_id ("LIST"); + + if (vfm_source != &input_program_source + && vfm_source != &file_type_source) + discard_variables (); + + dls.handle = default_handle; + dls.type = -1; + dls.end = NULL; + dls.eof = 0; + dls.nrec = 0; + dls.spec = NULL; + next = NULL; + first = &dls.spec; + + while (token != '/') + { + if (lex_match_id ("FILE")) + { + lex_match ('='); + dls.handle = fh_parse_file_handle (); + if (!dls.handle) + return CMD_FAILURE; + if (vfm_source == &file_type_source && dls.handle != default_handle) + { + msg (SE, _("DATA LIST may not use a different file from " + "that specified on its surrounding FILE TYPE.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("RECORDS")) + { + lex_match ('='); + lex_match ('('); + if (!lex_force_int ()) + return CMD_FAILURE; + dls.nrec = lex_integer (); + lex_get (); + lex_match (')'); + } + else if (lex_match_id ("END")) + { + if (dls.end) + { + msg (SE, _("The END subcommand may only be specified once.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (!lex_force_id ()) + return CMD_FAILURE; + dls.end = find_variable (tokid); + if (!dls.end) + dls.end = force_create_variable (&default_dict, tokid, NUMERIC, 0); + lex_get (); + } + else if (token == T_ID) + { + /* Must match DLS_* constants. */ + static const char *id[] = {"FIXED", "FREE", "LIST", "NOTABLE", + "TABLE", NULL}; + const char **p; + int index; + + for (p = id; *p; p++) + if (lex_id_match (*p, tokid)) + break; + if (*p == NULL) + { + lex_error (NULL); + return CMD_FAILURE; + } + + lex_get (); + + index = p - id; + if (index < 3) + { + if (dls.type != -1) + { + msg (SE, _("Only one of FIXED, FREE, or LIST may " + "be specified.")); + return CMD_FAILURE; + } + + dls.type = index; + } + else + table = index - 3; + } + else + { + lex_error (NULL); + return CMD_FAILURE; + } + } + + default_handle = dls.handle; + + if (dls.type == -1) + dls.type = DLS_FIXED; + + if (table == -1) + { + if (dls.type == DLS_FREE) + table = 0; + else + table = 1; + } + + if (dls.type == DLS_FIXED) + { + if (!parse_fixed ()) + return CMD_FAILURE; + if (table) + dump_fixed_table (); + } + else + { + if (!parse_free ()) + return CMD_FAILURE; + if (table) + dump_free_table (); + } + + if (vfm_source != NULL) + { + struct data_list_pgm *new_pgm; + + dls.h.proc = read_one_case; + dls.h.free = destroy_dls; + + new_pgm = xmalloc (sizeof *new_pgm); + memcpy (new_pgm, &dls, sizeof *new_pgm); + add_transformation ((struct trns_header *) new_pgm); + } + else + vfm_source = &data_list_source; + + return CMD_SUCCESS; +} + +static void +append_var_spec (struct dls_var_spec *spec) +{ + if (next == 0) + *first = next = xmalloc (sizeof *spec); + else + next = next->next = xmalloc (sizeof *spec); + +#if __CHECKER__ + spec->type = ROUND_UP (spec->type, 8); +#endif + + memcpy (next, spec, sizeof *spec); + next->next = NULL; +} + +/* Fixed-format parsing. */ + +/* Used for chaining together fortran-like format specifiers. */ +struct fmt_list + { + struct fmt_list *next; + int count; + struct fmt_spec f; + struct fmt_list *down; + }; + +/* Used as "local" variables among the fixed-format parsing funcs. If + it were guaranteed that PSPP were going to be compiled by gcc, + I'd make all these functions a single set of nested functions. */ +static struct + { + char **name; /* Variable names. */ + int nname; /* Number of names. */ + int cname; /* dump_fmt_list: index of next name to use. */ + + int recno; /* Index of current record. */ + int sc; /* 1-based column number of starting column for + next field to output. */ + + struct dls_var_spec spec; /* Next specification to output. */ + int fc, lc; /* First, last column in set of fields specified + together. */ + + int level; /* Nesting level in fixed_parse_fortran(). */ + } +fx; + +static int fixed_parse_compatible (void); +static struct fmt_list *fixed_parse_fortran (void); + +static int +parse_fixed (void) +{ + int i; + + fx.recno = 0; + fx.sc = 1; + + while (token != '.') + { + while (lex_match ('/')) + { + fx.recno++; + if (lex_integer_p ()) + { + if (lex_integer () < fx.recno) + { + msg (SE, _("The record number specified, %ld, is " + "before the previous record, %d. Data " + "fields must be listed in order of " + "increasing record number."), + lex_integer (), fx.recno - 1); + return 0; + } + + fx.recno = lex_integer (); + lex_get (); + } + fx.sc = 1; + } + fx.spec.rec = fx.recno; + + if (!parse_DATA_LIST_vars (&fx.name, &fx.nname, PV_NONE)) + return 0; + + if (token == T_NUM) + { + if (!fixed_parse_compatible ()) + goto fail; + } + else if (token == '(') + { + fx.level = 0; + fx.cname = 0; + if (!fixed_parse_fortran ()) + goto fail; + } + else + { + msg (SE, _("SPSS-like or FORTRAN-like format " + "specification expected after variable names.")); + goto fail; + } + + for (i = 0; i < fx.nname; i++) + free (fx.name[i]); + free (fx.name); + } + if (dls.nrec && next->rec > dls.nrec) + { + msg (SE, _("Variables are specified on records that " + "should not exist according to RECORDS subcommand.")); + return 0; + } + else if (!dls.nrec) + dls.nrec = next->rec; + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + return 1; + +fail: + for (i = 0; i < fx.nname; i++) + free (fx.name[i]); + free (fx.name); + return 0; +} + +static int +fixed_parse_compatible (void) +{ + int dividend; + int i; + + if (!lex_force_int ()) + return 0; + + fx.fc = lex_integer (); + if (fx.fc < 1) + { + msg (SE, _("Column positions for fields must be positive.")); + return 0; + } + lex_get (); + + lex_negative_to_dash (); + if (lex_match ('-')) + { + if (!lex_force_int ()) + return 0; + fx.lc = lex_integer (); + if (fx.lc < 1) + { + msg (SE, _("Column positions for fields must be positive.")); + return 0; + } + else if (fx.lc < fx.fc) + { + msg (SE, _("The ending column for a field must be " + "greater than the starting column.")); + return 0; + } + + lex_get (); + } + else + fx.lc = fx.fc; + + fx.spec.input.w = fx.lc - fx.fc + 1; + if (lex_match ('(')) + { + struct fmt_desc *fdp; + + if (token == T_ID) + { + const char *cp; + + fx.spec.input.type = parse_format_specifier_name (&cp, 0); + if (fx.spec.input.type == -1) + return 0; + if (*cp) + { + msg (SE, _("A format specifier on this line " + "has extra characters on the end.")); + return 0; + } + + lex_get (); + lex_match (','); + } + else + fx.spec.input.type = FMT_F; + + if (lex_integer_p ()) + { + if (lex_integer () < 1) + { + msg (SE, _("The value for number of decimal places " + "must be at least 1.")); + return 0; + } + + fx.spec.input.d = lex_integer (); + lex_get (); + } + else + fx.spec.input.d = 0; + + fdp = &formats[fx.spec.input.type]; + if (fdp->n_args < 2 && fx.spec.input.d) + { + msg (SE, _("Input format %s doesn't accept decimal places."), + fdp->name); + return 0; + } + + if (fx.spec.input.d > 16) + fx.spec.input.d = 16; + + if (!lex_force_match (')')) + return 0; + } + else + { + fx.spec.input.type = FMT_F; + fx.spec.input.d = 0; + } + + fx.sc = fx.lc + 1; + + if ((fx.lc - fx.fc + 1) % fx.nname) + { + msg (SE, _("The %d columns %d-%d " + "can't be evenly divided into %d fields."), + fx.lc - fx.fc + 1, fx.fc, fx.lc, fx.nname); + return 0; + } + + dividend = (fx.lc - fx.fc + 1) / fx.nname; + fx.spec.input.w = dividend; + if (!check_input_specifier (&fx.spec.input)) + return 0; + + for (i = 0; i < fx.nname; i++) + { + int type; + struct variable *v; + + if (fx.spec.input.type == FMT_A || fx.spec.input.type == FMT_AHEX) + type = ALPHA; + else + type = NUMERIC; + + v = create_variable (&default_dict, fx.name[i], type, dividend); + if (v) + { + convert_fmt_ItoO (&fx.spec.input, &v->print); + v->write = v->print; + } + else + { + v = find_variable (fx.name[i]); + assert (v); + if (!vfm_source) + { + msg (SE, _("%s is a duplicate variable name."), fx.name[i]); + return 0; + } + if (type != v->type) + { + msg (SE, _("There is already a variable %s of a " + "different type."), + fx.name[i]); + return 0; + } + if (type == ALPHA && dividend != v->width) + { + msg (SE, _("There is already a string variable %s of a " + "different width."), fx.name[i]); + return 0; + } + } + + fx.spec.v = v; + fx.spec.fc = fx.fc + dividend * i; + fx.spec.lc = fx.spec.fc + dividend - 1; + fx.spec.fv = v->fv; + fx.spec.type = v->type == NUMERIC ? 0 : v->width; + append_var_spec (&fx.spec); + } + return 1; +} + +/* Destroy a format list and, optionally, all its sublists. */ +static void +destroy_fmt_list (struct fmt_list *f, int recurse) +{ + struct fmt_list *next; + + for (; f; f = next) + { + next = f->next; + if (recurse && f->f.type == FMT_DESCEND) + destroy_fmt_list (f->down, 1); + free (f); + } +} + +/* Takes a hierarchically structured fmt_list F as constructed by + fixed_parse_fortran(), and flattens it into a linear list of + dls_var_spec's. */ +static int +dump_fmt_list (struct fmt_list *f) +{ + int i; + + for (; f; f = f->next) + if (f->f.type == FMT_X) + fx.sc += f->count; + else if (f->f.type == FMT_T) + fx.sc = f->f.w; + else if (f->f.type == FMT_NEWREC) + { + fx.recno += f->count; + fx.sc = 1; + } + else + for (i = 0; i < f->count; i++) + if (f->f.type == FMT_DESCEND) + { + if (!dump_fmt_list (f->down)) + return 0; + } + else + { + int type; + struct variable *v; + + type = (formats[f->f.type].cat & FCAT_STRING) ? ALPHA : NUMERIC; + if (fx.cname >= fx.nname) + { + msg (SE, _("The number of format " + "specifications exceeds the number of " + "variable names given.")); + return 0; + } + + fx.spec.v = v = create_variable (&default_dict, + fx.name[fx.cname++], + type, f->f.w); + if (!v) + { + msg (SE, _("%s is a duplicate variable name."), fx.name[i]); + return 0; + } + + fx.spec.input = f->f; + convert_fmt_ItoO (&fx.spec.input, &v->print); + v->write = v->print; + + fx.spec.rec = fx.recno; + fx.spec.fc = fx.sc; + fx.spec.lc = fx.sc + f->f.w - 1; + fx.spec.fv = v->fv; + fx.spec.type = v->type == NUMERIC ? 0 : v->width; + append_var_spec (&fx.spec); + + fx.sc += f->f.w; + } + return 1; +} + +/* Calls itself recursively to parse nested levels of parentheses. + Returns to its original caller: NULL, to indicate error; non-NULL, + but nothing useful, to indicate success (it returns a free()'d + block). */ +static struct fmt_list * +fixed_parse_fortran (void) +{ + struct fmt_list *head; + struct fmt_list *fl = NULL; + + lex_get (); /* Skip opening parenthesis. */ + while (token != ')') + { + if (fl) + fl = fl->next = xmalloc (sizeof *fl); + else + head = fl = xmalloc (sizeof *fl); + + if (lex_integer_p ()) + { + fl->count = lex_integer (); + lex_get (); + } + else + fl->count = 1; + + if (token == '(') + { + fl->f.type = FMT_DESCEND; + fx.level++; + fl->down = fixed_parse_fortran (); + fx.level--; + if (!fl->down) + goto fail; + } + else if (lex_match ('/')) + fl->f.type = FMT_NEWREC; + else if (!parse_format_specifier (&fl->f, 1) + || !check_input_specifier (&fl->f)) + goto fail; + + lex_match (','); + } + fl->next = NULL; + lex_get (); + + if (fx.level) + return head; + + fl->next = NULL; + dump_fmt_list (head); + if (fx.cname < fx.nname) + { + msg (SE, _("There aren't enough format specifications " + "to match the number of variable names given.")); + goto fail; + } + destroy_fmt_list (head, 1); + return head; + +fail: + fl->next = NULL; + destroy_fmt_list (head, 0); + + return NULL; +} + +/* Displays a table giving information on fixed-format variable + parsing on DATA LIST. */ +/* FIXME: The `Columns' column should be divided into three columns, + one for the starting column, one for the dash, one for the ending + column; then right-justify the starting column and left-justify the + ending column. */ +static void +dump_fixed_table (void) +{ + struct dls_var_spec *spec; + struct tab_table *t; + char *buf; + const char *filename; + int i; + + for (i = 0, spec = *first; spec; spec = spec->next) + i++; + t = tab_create (4, i + 1, 0); + tab_columns (t, TAB_COL_DOWN, 1); + tab_headers (t, 0, 0, 1, 0); + tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable")); + tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record")); + tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns")); + tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format")); + tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, i); + tab_hline (t, TAL_2, 0, 3, 1); + tab_dim (t, tab_natural_dimensions); + + for (i = 1, spec = *first; spec; spec = spec->next, i++) + { + tab_text (t, 0, i, TAB_LEFT, spec->v->name); + tab_text (t, 1, i, TAT_PRINTF, "%d", spec->rec); + tab_text (t, 2, i, TAT_PRINTF, "%3d-%3d", + spec->fc, spec->lc); + tab_text (t, 3, i, TAB_LEFT | TAT_FIX, + fmt_to_string (&spec->input)); + } + + if (*first == dls.spec) + { + filename = fh_handle_name (dls.handle); + if (filename == NULL) + filename = ""; + buf = local_alloc (strlen (filename) + INT_DIGITS + 80); + sprintf (buf, (dls.handle != inline_file + ? _("Reading %d record%s from file %s.") + : _("Reading %d record%s from the command file.")), + dls.nrec, dls.nrec != 1 ? "s" : "", filename); + } + else + { + buf = local_alloc (strlen (_("Occurrence data specifications.")) + 1); + strcpy (buf, _("Occurrence data specifications.")); + } + + tab_title (t, 0, buf); + tab_submit (t); + fh_handle_name (NULL); + local_free (buf); +} + +/* Free-format parsing. */ + +static int +parse_free (void) +{ + struct dls_var_spec spec; + struct fmt_spec in, out; + char **name; + int nname; + int i; + int type; + +#if __CHECKER__ + memset (&spec, 0, sizeof spec); +#endif + lex_get (); + while (token != '.') + { + if (!parse_DATA_LIST_vars (&name, &nname, PV_NONE)) + return 0; + if (lex_match ('(')) + { + if (!parse_format_specifier (&in, 0) || !check_input_specifier (&in)) + goto fail; + if (!lex_force_match (')')) + goto fail; + convert_fmt_ItoO (&in, &out); + } + else + { + lex_match ('*'); + in.type = FMT_F; + in.w = 8; + in.d = 0; + out = set_format; + } + + spec.input = in; + if (in.type == FMT_A || in.type == FMT_AHEX) + type = ALPHA; + else + type = NUMERIC; + for (i = 0; i < nname; i++) + { + struct variable *v; + + spec.v = v = create_variable (&default_dict, name[i], type, in.w); + if (!v) + { + msg (SE, _("%s is a duplicate variable name."), name[i]); + return 0; + } + + v->print = v->write = out; + + strcpy (spec.name, name[i]); + spec.fv = v->fv; + spec.type = type == NUMERIC ? 0 : v->width; + append_var_spec (&spec); + } + for (i = 0; i < nname; i++) + free (name[i]); + free (name); + } + + if (token != '.') + lex_error (_("expecting end of command")); + return 1; + +fail: + for (i = 0; i < nname; i++) + free (name[i]); + free (name); + return 0; +} + +/* Displays a table giving information on free-format variable parsing + on DATA LIST. */ +static void +dump_free_table (void) +{ + struct tab_table *t; + int i; + + { + struct dls_var_spec *spec; + for (i = 0, spec = dls.spec; spec; spec = spec->next) + i++; + } + + t = tab_create (2, i + 1, 0); + tab_columns (t, TAB_COL_DOWN, 1); + tab_headers (t, 0, 0, 1, 0); + tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable")); + tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format")); + tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i); + tab_hline (t, TAL_2, 0, 1, 1); + tab_dim (t, tab_natural_dimensions); + + { + struct dls_var_spec *spec; + + for (i = 1, spec = dls.spec; spec; spec = spec->next, i++) + { + tab_text (t, 0, i, TAB_LEFT, spec->v->name); + tab_text (t, 1, i, TAB_LEFT | TAT_FIX, fmt_to_string (&spec->input)); + } + } + + { + const char *filename; + + filename = fh_handle_name (dls.handle); + if (filename == NULL) + filename = ""; + tab_title (t, 1, + (dls.handle != inline_file + ? _("Reading free-form data from file %s.") + : _("Reading free-form data from the command file.")), + filename); + } + + tab_submit (t); + fh_handle_name (NULL); +} + +/* Input procedure. */ + +/* Pointer to relevant parsing data. Static just to avoid passing it + around so much. */ +static struct data_list_pgm *dlsp; + +/* Extracts a field from the current position in the current record. + Fields can be unquoted or quoted with single- or double-quote + characters. *RET_LEN is set to the field length, *RET_CP is set to + the field itself. After parsing the field, sets the current + position in the record to just past the field. Returns 0 on + failure or a 1-based column number indicating the beginning of the + field on success. */ +static int +cut_field (char **ret_cp, int *ret_len) +{ + char *cp, *ep; + int len; + + cp = dfm_get_record (dlsp->handle, &len); + if (!cp) + return 0; + + ep = cp + len; + + /* Skip leading whitespace and commas. */ + while ((isspace ((unsigned char) *cp) || *cp == ',') && cp < ep) + cp++; + if (cp >= ep) + return 0; + + /* Three types of fields: quoted with ', quoted with ", unquoted. */ + if (*cp == '\'' || *cp == '"') + { + int quote = *cp; + + *ret_cp = ++cp; + while (cp < ep && *cp != quote) + cp++; + *ret_len = cp - *ret_cp; + if (cp < ep) + cp++; + else + msg (SW, _("Scope of string exceeds line.")); + } + else + { + *ret_cp = cp; + while (cp < ep && !isspace ((unsigned char) *cp) && *cp != ',') + cp++; + *ret_len = cp - *ret_cp; + } + + { + int beginning_column; + + dfm_set_record (dlsp->handle, *ret_cp); + beginning_column = dfm_get_cur_col (dlsp->handle) + 1; + + dfm_set_record (dlsp->handle, cp); + + return beginning_column; + } +} + +static int read_from_data_list_fixed (void); +static int read_from_data_list_free (void); +static int read_from_data_list_list (void); +static int do_reading (int flag); + +/* FLAG==0: reads any number of cases into temp_case and calls + write_case() for each one, returns garbage. FLAG!=0: reads one + case into temp_case and returns -2 on eof, -1 otherwise. + Uses dlsp as the relevant parsing description. */ +static int +do_reading (int flag) +{ + int (*func) (void); + + int code; + + dfm_push (dlsp->handle); + + switch (dlsp->type) + { + case DLS_FIXED: + func = read_from_data_list_fixed; + break; + case DLS_FREE: + func = read_from_data_list_free; + break; + case DLS_LIST: + func = read_from_data_list_list; + break; + default: + assert (0); + } + if (flag) + { + code = func (); + if (code == -2) + { + if (dlsp->eof == 1) + { + msg (SE, _("Attempt to read past end of file.")); + err_failure (); + return -2; + } + dlsp->eof = 1; + } + else + dlsp->eof = 0; + + if (dlsp->end != NULL) + { + if (code == -2) + { + printf ("end of file, setting %s to 1\n", dlsp->end->name); + temp_case->data[dlsp->end->fv].f = 1.0; + code = -1; + } + else + { + printf ("not end of file, setting %s to 0\n", dlsp->end->name); + temp_case->data[dlsp->end->fv].f = 0.0; + } + } + } + else + { + while (func () != -2) + if (!write_case ()) + { + debug_printf ((_("abort in write_case()\n"))); + break; + } + fh_close_handle (dlsp->handle); +#if __CHECKER__ + code = 0; /* prevent error at `return code;' */ +#endif + } + dfm_pop (dlsp->handle); + + return code; +} + +/* Reads a case from the data file and parses it according to + fixed-format syntax rules. */ +static int +read_from_data_list_fixed (void) +{ + struct dls_var_spec *var_spec = dlsp->spec; + int i; + + if (!dfm_get_record (dlsp->handle, NULL)) + return -2; + for (i = 1; i <= dlsp->nrec; i++) + { + int len; + char *line = dfm_get_record (dlsp->handle, &len); + + if (!line) + { + /* Note that this can't occur on the first record. */ + msg (SW, _("Partial case of %d of %d records discarded."), + i - 1, dlsp->nrec); + return -2; + } + + for (; var_spec && i == var_spec->rec; var_spec = var_spec->next) + { + struct data_in di; + + data_in_finite_line (&di, line, len, var_spec->fc, var_spec->lc); + di.v = &temp_case->data[var_spec->fv]; + di.flags = 0; + di.f1 = var_spec->fc; + di.format = var_spec->input; + + data_in (&di); + } + + dfm_fwd_record (dlsp->handle); + } + + return -1; +} + +/* Reads a case from the data file and parses it according to + free-format syntax rules. */ +static int +read_from_data_list_free (void) +{ + struct dls_var_spec *var_spec; + char *field; + int len; + + for (var_spec = dlsp->spec; var_spec; var_spec = var_spec->next) + { + int column; + + /* Cut out a field and read in a new record if necessary. */ + for (;;) + { + column = cut_field (&field, &len); + if (column != 0) + break; + + if (dfm_get_record (dlsp->handle, NULL)) + dfm_fwd_record (dlsp->handle); + if (!dfm_get_record (dlsp->handle, NULL)) + { + if (var_spec != dlsp->spec) + msg (SW, _("Partial case discarded. The first variable " + "missing was %s."), var_spec->name); + return -2; + } + } + + { + struct data_in di; + + di.s = field; + di.e = field + len; + di.v = &temp_case->data[var_spec->fv]; + di.flags = 0; + di.f1 = column; + di.format = var_spec->input; + data_in (&di); + } + } + return -1; +} + +/* Reads a case from the data file and parses it according to + list-format syntax rules. */ +static int +read_from_data_list_list (void) +{ + struct dls_var_spec *var_spec; + char *field; + int len; + + if (!dfm_get_record (dlsp->handle, NULL)) + return -2; + + for (var_spec = dlsp->spec; var_spec; var_spec = var_spec->next) + { + /* Cut out a field and check for end-of-line. */ + int column = cut_field (&field, &len); + + if (column == 0) + { + if (set_undefined) + msg (SW, _("Missing value(s) for all variables from %s onward. " + "These will be filled with the system-missing value " + "or blanks, as appropriate."), + var_spec->name); + for (; var_spec; var_spec = var_spec->next) + if (!var_spec->type) + temp_case->data[var_spec->fv].f = SYSMIS; + else + memset (temp_case->data[var_spec->fv].s, ' ', var_spec->type); + break; + } + + { + struct data_in di; + + di.s = field; + di.e = field + len; + di.v = &temp_case->data[var_spec->fv]; + di.flags = 0; + di.f1 = column; + di.format = var_spec->input; + data_in (&di); + } + } + + dfm_fwd_record (dlsp->handle); + return -1; +} + +/* Destroys DATA LIST transformation or input program PGM. */ +static void +destroy_dls (struct trns_header *pgm) +{ + struct data_list_pgm *dls = (struct data_list_pgm *) pgm; + struct dls_var_spec *iter, *next; + + iter = dls->spec; + while (iter) + { + next = iter->next; + free (iter); + iter = next; + } + fh_close_handle (dls->handle); +} + +/* Note that since this is exclusively an input program, C is + guaranteed to be temp_case. */ +static int +read_one_case (struct trns_header *t, struct ccase *c unused) +{ + dlsp = (struct data_list_pgm *) t; + return do_reading (1); +} + +/* Reads all the records from the data file and passes them to + write_case(). */ +static void +data_list_source_read (void) +{ + dlsp = &dls; + do_reading (0); +} + +/* Destroys the source's internal data. */ +static void +data_list_source_destroy_source (void) +{ + destroy_dls ((struct trns_header *) & dls); +} + +struct case_stream data_list_source = + { + NULL, + data_list_source_read, + NULL, + NULL, + data_list_source_destroy_source, + NULL, + "DATA LIST", + }; + +/* REPEATING DATA. */ + +/* Represents a number or a variable. */ +struct rpd_num_or_var + { + int num; /* Value, or 0. */ + struct variable *var; /* Variable, if number==0. */ + }; + +/* REPEATING DATA private data structure. */ +struct repeating_data_trns + { + struct trns_header h; + struct dls_var_spec *spec; /* Variable parsing specifications. */ + struct file_handle *handle; /* Input file, never NULL. */ + /* Do not reorder preceding fields. */ + + struct rpd_num_or_var starts_beg; /* STARTS=, before the dash. */ + struct rpd_num_or_var starts_end; /* STARTS=, after the dash. */ + struct rpd_num_or_var occurs; /* OCCURS= subcommand. */ + struct rpd_num_or_var length; /* LENGTH= subcommand. */ + struct rpd_num_or_var cont_beg; /* CONTINUED=, before the dash. */ + struct rpd_num_or_var cont_end; /* CONTINUED=, after the dash. */ + int id_beg, id_end; /* ID subcommand, beginning & end columns. */ + struct variable *id_var; /* ID subcommand, DATA LIST variable. */ + struct fmt_spec id_spec; /* ID subcommand, input format spec. */ + }; + +/* Information about the transformation being parsed. */ +static struct repeating_data_trns rpd; + +static int read_one_set_of_repetitions (struct trns_header *, struct ccase *); +static int parse_num_or_var (struct rpd_num_or_var *, const char *); +static int parse_repeating_data (void); +static void find_variable_input_spec (struct variable *v, + struct fmt_spec *spec); + +/* Parses the REPEATING DATA command. */ +int +cmd_repeating_data (void) +{ + /* 0=print no table, 1=print table. (TABLE subcommand.) */ + int table = 1; + + /* Bits are set when a particular subcommand has been seen. */ + unsigned seen = 0; + + lex_match_id ("REPEATING"); + lex_match_id ("DATA"); + + assert (vfm_source == &input_program_source + || vfm_source == &file_type_source); + + rpd.handle = default_handle; + rpd.starts_beg.num = 0; + rpd.starts_beg.var = NULL; + rpd.starts_end = rpd.occurs = rpd.length = rpd.cont_beg + = rpd.cont_end = rpd.starts_beg; + rpd.id_beg = rpd.id_end = 0; + rpd.id_var = NULL; + rpd.spec = NULL; + first = &rpd.spec; + next = NULL; + + lex_match ('/'); + + for (;;) + { + if (lex_match_id ("FILE")) + { + lex_match ('='); + rpd.handle = fh_parse_file_handle (); + if (!rpd.handle) + return CMD_FAILURE; + if (rpd.handle != default_handle) + { + msg (SE, _("REPEATING DATA must use the same file as its " + "corresponding DATA LIST or FILE TYPE.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("STARTS")) + { + lex_match ('='); + if (seen & 1) + { + msg (SE, _("STARTS subcommand given multiple times.")); + return CMD_FAILURE; + } + seen |= 1; + + if (!parse_num_or_var (&rpd.starts_beg, "STARTS beginning column")) + return CMD_FAILURE; + + lex_negative_to_dash (); + if (lex_match ('-')) + { + if (!parse_num_or_var (&rpd.starts_end, "STARTS ending column")) + return CMD_FAILURE; + } else { + /* Otherwise, rpd.starts_end is left uninitialized. + This is okay. We will initialize it later from the + record length of the file. We can't do this now + because we can't be sure that the user has specified + the file handle yet. */ + } + + if (rpd.starts_beg.num != 0 && rpd.starts_end.num != 0 + && rpd.starts_beg.num > rpd.starts_end.num) + { + msg (SE, _("STARTS beginning column (%d) exceeds " + "STARTS ending column (%d)."), + rpd.starts_beg.num, rpd.starts_end.num); + return CMD_FAILURE; + } + } + else if (lex_match_id ("OCCURS")) + { + lex_match ('='); + if (seen & 2) + { + msg (SE, _("OCCURS subcommand given multiple times.")); + return CMD_FAILURE; + } + seen |= 2; + + if (!parse_num_or_var (&rpd.occurs, "OCCURS")) + return CMD_FAILURE; + } + else if (lex_match_id ("LENGTH")) + { + lex_match ('='); + if (seen & 4) + { + msg (SE, _("LENGTH subcommand given multiple times.")); + return CMD_FAILURE; + } + seen |= 4; + + if (!parse_num_or_var (&rpd.length, "LENGTH")) + return CMD_FAILURE; + } + else if (lex_match_id ("CONTINUED")) + { + lex_match ('='); + if (seen & 8) + { + msg (SE, _("CONTINUED subcommand given multiple times.")); + return CMD_FAILURE; + } + seen |= 8; + + if (!lex_match ('/')) + { + if (!parse_num_or_var (&rpd.cont_beg, "CONTINUED beginning column")) + return CMD_FAILURE; + + lex_negative_to_dash (); + if (lex_match ('-') + && !parse_num_or_var (&rpd.cont_end, + "CONTINUED ending column")) + return CMD_FAILURE; + + if (rpd.cont_beg.num != 0 && rpd.cont_end.num != 0 + && rpd.cont_beg.num > rpd.cont_end.num) + { + msg (SE, _("CONTINUED beginning column (%d) exceeds " + "CONTINUED ending column (%d)."), + rpd.cont_beg.num, rpd.cont_end.num); + return CMD_FAILURE; + } + } + else + rpd.cont_beg.num = 1; + } + else if (lex_match_id ("ID")) + { + lex_match ('='); + if (seen & 16) + { + msg (SE, _("ID subcommand given multiple times.")); + return CMD_FAILURE; + } + seen |= 16; + + if (!lex_force_int ()) + return CMD_FAILURE; + if (lex_integer () < 1) + { + msg (SE, _("ID beginning column (%ld) must be positive."), + lex_integer ()); + return CMD_FAILURE; + } + rpd.id_beg = lex_integer (); + + lex_get (); + lex_negative_to_dash (); + + if (lex_match ('-')) + { + if (!lex_force_int ()) + return CMD_FAILURE; + if (lex_integer () < 1) + { + msg (SE, _("ID ending column (%ld) must be positive."), + lex_integer ()); + return CMD_FAILURE; + } + if (lex_integer () < rpd.id_end) + { + msg (SE, _("ID ending column (%ld) cannot be less than " + "ID beginning column (%d)."), + lex_integer (), rpd.id_beg); + return CMD_FAILURE; + } + + rpd.id_end = lex_integer (); + lex_get (); + } + else rpd.id_end = rpd.id_beg; + + if (!lex_force_match ('=')) + return CMD_FAILURE; + rpd.id_var = parse_variable (); + if (rpd.id_var == NULL) + return CMD_FAILURE; + + find_variable_input_spec (rpd.id_var, &rpd.id_spec); + } + else if (lex_match_id ("TABLE")) + table = 1; + else if (lex_match_id ("NOTABLE")) + table = 0; + else if (lex_match_id ("DATA")) + break; + else + { + lex_error (NULL); + return CMD_FAILURE; + } + + if (!lex_force_match ('/')) + return CMD_FAILURE; + } + + /* Comes here when DATA specification encountered. */ + if ((seen & (1 | 2)) != (1 | 2)) + { + if ((seen & 1) == 0) + msg (SE, _("Missing required specification STARTS.")); + if ((seen & 2) == 0) + msg (SE, _("Missing required specification OCCURS.")); + return CMD_FAILURE; + } + + /* Enforce ID restriction. */ + if ((seen & 16) && !(seen & 8)) + { + msg (SE, _("ID specified without CONTINUED.")); + return CMD_FAILURE; + } + + /* Calculate starts_end, cont_end if necessary. */ + if (rpd.starts_end.num == 0 && rpd.starts_end.var == NULL) + rpd.starts_end.num = fh_record_width (rpd.handle); + if (rpd.cont_end.num == 0 && rpd.starts_end.var == NULL) + rpd.cont_end.num = fh_record_width (rpd.handle); + + /* Calculate length if possible. */ + if ((seen & 4) == 0) + { + struct dls_var_spec *iter; + + for (iter = rpd.spec; iter; iter = iter->next) + { + if (iter->lc > rpd.length.num) + rpd.length.num = iter->lc; + } + assert (rpd.length.num != 0); + } + + lex_match ('='); + if (!parse_repeating_data ()) + return CMD_FAILURE; + + if (table) + dump_fixed_table (); + + { + struct repeating_data_trns *new_trns; + + rpd.h.proc = read_one_set_of_repetitions; + rpd.h.free = destroy_dls; + + new_trns = xmalloc (sizeof *new_trns); + memcpy (new_trns, &rpd, sizeof *new_trns); + add_transformation ((struct trns_header *) new_trns); + } + + return lex_end_of_command (); +} + +/* Because of the way that DATA LIST is structured, it's not trivial + to determine what input format is associated with a given variable. + This function finds the input format specification for variable V + and puts it in SPEC. */ +static void +find_variable_input_spec (struct variable *v, struct fmt_spec *spec) +{ + int i; + + for (i = 0; i < n_trns; i++) + { + struct data_list_pgm *pgm = (struct data_list_pgm *) t_trns[i]; + + if (pgm->h.proc == read_one_case) + { + struct dls_var_spec *iter; + + for (iter = pgm->spec; iter; iter = iter->next) + if (iter->v == v) + { + *spec = iter->input; + return; + } + } + } + + assert (0); +} + +/* Parses a number or a variable name from the syntax file and puts + the results in VALUE. Ensures that the number is at least 1; else + emits an error based on MESSAGE. Returns nonzero only if + successful. */ +static int +parse_num_or_var (struct rpd_num_or_var *value, const char *message) +{ + if (token == T_ID) + { + value->num = 0; + value->var = parse_variable (); + if (value->var == NULL) + return 0; + if (value->var->type == ALPHA) + { + msg (SE, _("String variable not allowed here.")); + return 0; + } + } + else if (lex_integer_p ()) + { + value->num = lex_integer (); + + if (value->num < 1) + { + msg (SE, _("%s (%d) must be at least 1."), message, value->num); + return 0; + } + + lex_get (); + } else { + msg (SE, _("Variable or integer expected for %s."), message); + return 0; + } + return 1; +} + +/* Parses data specifications for repeating data groups. Taken from + parse_fixed(). Returns nonzero only if successful. */ +static int +parse_repeating_data (void) +{ + int i; + + fx.recno = 0; + fx.sc = 1; + + while (token != '.') + { + fx.spec.rec = fx.recno; + + if (!parse_DATA_LIST_vars (&fx.name, &fx.nname, PV_NONE)) + return 0; + + if (token == T_NUM) + { + if (!fixed_parse_compatible ()) + goto fail; + } + else if (token == '(') + { + fx.level = 0; + fx.cname = 0; + if (!fixed_parse_fortran ()) + goto fail; + } + else + { + msg (SE, _("SPSS-like or FORTRAN-like format " + "specification expected after variable names.")); + goto fail; + } + + for (i = 0; i < fx.nname; i++) + free (fx.name[i]); + free (fx.name); + } + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + + return 1; + +fail: + for (i = 0; i < fx.nname; i++) + free (fx.name[i]); + free (fx.name); + return 0; +} + +/* Obtains the real value for rpd_num_or_var N in case C and returns + it. The valid range is nonnegative numbers, but numbers outside + this range can be returned and should be handled by the caller as + invalid. */ +static int +realize_value (struct rpd_num_or_var *n, struct ccase *c) +{ + if (n->num > 0) + return n->num; + + assert (n->num == 0); + if (n->var != NULL) + { + double v = c->data[n->var->fv].f; + + if (v == SYSMIS || v <= INT_MIN || v >= INT_MAX) + return -1; + else + return v; + } + else + return 0; +} + +/* Parses one record of repeated data and outputs corresponding cases. + Repeating data is present in line LINE having length LEN. + Repeating data begins in column BEG and continues through column + END inclusive (1-based columns); occurrences are offset OFS columns + from each other. C is the case that will be filled in; T is the + REPEATING DATA transformation. The record ID will be verified if + COMPARE_ID is nonzero; if it is zero, then the record ID is + initialized to the ID present in the case (assuming that ID + location was specified by the user). Returns number of occurrences + parsed up to the specified maximum of MAX_OCCURS. */ +static int +rpd_parse_record (int beg, int end, int ofs, struct ccase *c, + struct repeating_data_trns *t, + char *line, int len, int compare_id, int max_occurs) +{ + int occurrences; + int cur = beg; + + /* Handle record ID values. */ + if (t->id_beg != 0) + { + static union value comparator; + union value v; + + { + struct data_in di; + + data_in_finite_line (&di, line, len, t->id_beg, t->id_end); + di.v = &v; + di.flags = 0; + di.f1 = t->id_beg; + di.format = t->id_spec; + + if (!data_in (&di)) + return 0; + } + + if (compare_id == 0) + comparator = v; + else if ((t->id_var->type == NUMERIC && comparator.f != v.f) + || (t->id_var->type == ALPHA + && strncmp (comparator.s, v.s, t->id_var->width))) + { + char comp_str [64]; + char v_str [64]; + + if (!data_out (comp_str, &t->id_var->print, &comparator)) + comp_str[0] = 0; + if (!data_out (v_str, &t->id_var->print, &v)) + v_str[0] = 0; + + comp_str[t->id_var->print.w] = v_str[t->id_var->print.w] = 0; + + tmsg (SE, RPD_ERR, + _("Mismatched case ID (%s). Expected value was %s."), + v_str, comp_str); + + return 0; + } + } + + /* Iterate over the set of expected occurrences and record each of + them as a separate case. FIXME: We need to execute any + transformations that follow the current one. */ + { + int warned = 0; + + for (occurrences = 0; occurrences < max_occurs; ) + { + if (cur + ofs > end + 1) + break; + occurrences++; + + { + struct dls_var_spec *var_spec = t->spec; + + for (; var_spec; var_spec = var_spec->next) + { + int fc = var_spec->fc - 1 + cur; + int lc = var_spec->lc - 1 + cur; + + if (fc > len && !warned && var_spec->input.type != FMT_A) + { + warned = 1; + + tmsg (SW, RPD_ERR, + _("Variable %s startging in column %d extends " + "beyond physical record length of %d."), + var_spec->v->name, fc, len); + } + + { + struct data_in di; + + data_in_finite_line (&di, line, len, fc, lc); + di.v = &c->data[var_spec->fv]; + di.flags = 0; + di.f1 = fc + 1; + di.format = var_spec->input; + + if (!data_in (&di)) + return 0; + } + } + } + + cur += ofs; + + if (!write_case ()) + return 0; + } + } + + return occurrences; +} + +/* Analogous to read_one_case; reads one set of repetitions of the + elements in the REPEATING DATA structure. Returns -1 on success, + -2 on end of file or on failure. */ +static int +read_one_set_of_repetitions (struct trns_header *trns, struct ccase *c) +{ + dfm_push (dlsp->handle); + + { + struct repeating_data_trns *t = (struct repeating_data_trns *) trns; + + char *line; /* Current record. */ + int len; /* Length of current record. */ + + int starts_beg; /* Starting column. */ + int starts_end; /* Ending column. */ + int occurs; /* Number of repetitions. */ + int length; /* Length of each occurrence. */ + int cont_beg; /* Starting column for continuation lines. */ + int cont_end; /* Ending column for continuation lines. */ + + int occurs_left; /* Number of occurrences remaining. */ + + int code; /* Return value from rpd_parse_record(). */ + + int skip_first_record = 0; + + /* Read the current record. */ + dfm_bkwd_record (dlsp->handle, 1); + line = dfm_get_record (dlsp->handle, &len); + if (line == NULL) + return -2; + dfm_fwd_record (dlsp->handle); + + /* Calculate occurs, length. */ + occurs_left = occurs = realize_value (&t->occurs, c); + if (occurs <= 0) + { + tmsg (SE, RPD_ERR, _("Invalid value %d for OCCURS."), occurs); + return -3; + } + starts_beg = realize_value (&t->starts_beg, c); + if (starts_beg <= 0) + { + tmsg (SE, RPD_ERR, _("Beginning column for STARTS (%d) must be " + "at least 1."), + starts_beg); + return -3; + } + starts_end = realize_value (&t->starts_end, c); + if (starts_end < starts_beg) + { + tmsg (SE, RPD_ERR, _("Ending column for STARTS (%d) is less than " + "beginning column (%d)."), + starts_end, starts_beg); + skip_first_record = 1; + } + length = realize_value (&t->length, c); + if (length < 0) + { + tmsg (SE, RPD_ERR, _("Invalid value %d for LENGTH."), length); + length = 1; + occurs = occurs_left = 1; + } + cont_beg = realize_value (&t->cont_beg, c); + if (cont_beg < 0) + { + tmsg (SE, RPD_ERR, _("Beginning column for CONTINUED (%d) must be " + "at least 1."), + cont_beg); + return -2; + } + cont_end = realize_value (&t->cont_end, c); + if (cont_end < cont_beg) + { + tmsg (SE, RPD_ERR, _("Ending column for CONTINUED (%d) is less than " + "beginning column (%d)."), + cont_end, cont_beg); + return -2; + } + + /* Parse the first record. */ + if (!skip_first_record) + { + code = rpd_parse_record (starts_beg, starts_end, length, c, t, line, + len, 0, occurs_left); + if (!code) + return -2; + } + else if (cont_beg == 0) + return -3; + + /* Make sure, if some occurrences are left, that we have + continuation records. */ + occurs_left -= code; + if (occurs_left != 0 && cont_beg == 0) + { + tmsg (SE, RPD_ERR, + _("Number of repetitions specified on OCCURS (%d) " + "exceed number of repetitions available in " + "space on STARTS (%d), and CONTINUED not specified."), + occurs, code); + return -2; + } + + /* Go on to additional records. */ + while (occurs_left != 0) + { + assert (occurs_left >= 0); + + /* Read in another record. */ + line = dfm_get_record (dlsp->handle, &len); + if (line == NULL) + { + tmsg (SE, RPD_ERR, + _("Unexpected end of file with %d repetitions " + "remaining out of %d."), + occurs_left, occurs); + return -2; + } + dfm_fwd_record (dlsp->handle); + + /* Parse this record. */ + code = rpd_parse_record (cont_beg, cont_end, length, c, t, line, + len, 1, occurs_left); + if (!code) + return -2; + occurs_left -= code; + } + } + + dfm_pop (dlsp->handle); + + /* FIXME: This is a kluge until we've implemented multiplexing of + transformations. */ + return -3; +} diff --git a/src/data-out.c b/src/data-out.c new file mode 100644 index 00000000..24428c6a --- /dev/null +++ b/src/data-out.c @@ -0,0 +1,1231 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include "approx.h" +#include "error.h" +#include "format.h" +#include "julcal/julcal.h" +#include "magic.h" +#include "misc.h" +#include "misc.h" +#include "settings.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* In older versions, numbers got their trailing zeros stripped. + Newer versions leave them on when there's room. Comment this next + line out for retro styling. */ +#define NEW_STYLE 1 + +/* Public functions. */ + +typedef int convert_func (char *, const struct fmt_spec *, + const union value *); + +static convert_func convert_F, convert_N, convert_E, convert_F_plus; +static convert_func convert_Z, convert_A, convert_AHEX, convert_IB; +static convert_func convert_P, convert_PIB, convert_PIBHEX, convert_PK; +static convert_func convert_RB, convert_RBHEX, convert_CCx, convert_date; +static convert_func convert_time, convert_WKDAY, convert_MONTH; +static convert_func try_F; + +/* Converts binary value V into printable form in string S according + to format specification FP. The string as written has exactly + FP->W characters. It is not null-terminated. Returns 1 on + success, 0 on failure. */ +int +data_out (char *s, const struct fmt_spec *fp, const union value *v) +{ + union value tmp_val; + + { + int cat = formats[fp->type].cat; + if ((cat & FCAT_BLANKS_SYSMIS) && v->f == SYSMIS) + { + memset (s, ' ', fp->w); + s[fp->w - fp->d - 1] = '.'; + return 1; + } + if ((cat & FCAT_SHIFT_DECIMAL) && v->f != SYSMIS && fp->d) + { + tmp_val.f = v->f * pow (10.0, fp->d); + v = &tmp_val; + } + } + + { + static convert_func *const handlers[FMT_NUMBER_OF_FORMATS] = + { + convert_F, convert_N, convert_E, convert_F_plus, + convert_F_plus, convert_F_plus, convert_F_plus, + convert_Z, convert_A, convert_AHEX, convert_IB, convert_P, convert_PIB, + convert_PIBHEX, convert_PK, convert_RB, convert_RBHEX, + convert_CCx, convert_CCx, convert_CCx, convert_CCx, convert_CCx, + convert_date, convert_date, convert_date, convert_date, convert_date, + convert_date, convert_date, convert_date, convert_date, + convert_time, convert_time, + convert_WKDAY, convert_MONTH, + }; + + return handlers[fp->type] (s, fp, v); + } +} + +/* Converts V into S in F format with width W and D decimal places, + then deletes trailing zeros. S is not null-terminated. */ +void +num_to_string (double v, char *s, int w, int d) +{ + /* Dummies to pass to convert_F. */ + union value val; + struct fmt_spec f; + +#if !NEW_STYLE + /* Pointer to `.' in S. */ + char *decp; + + /* Pointer to `E' in S. */ + char *expp; + + /* Number of characters to delete. */ + int n = 0; +#endif + + f.w = w; + f.d = d; + val.f = v; + + /* Cut out the jokers. */ + if (!finite (v)) + { + char temp[9]; + int len; + + if (isnan (v)) + { + memcpy (temp, "NaN", 3); + len = 3; + } + else if (isinf (v)) + { + memcpy (temp, "+Infinity", 9); + if (v < 0) + temp[0] = '-'; + len = 9; + } + else + { + memcpy (temp, _("Unknown"), 7); + len = 7; + } + if (w > len) + { + int pad = w - len; + memset (s, ' ', pad); + s += pad; + w -= pad; + } + memcpy (s, temp, w); + return; + } + + try_F (s, &f, &val); + +#if !NEW_STYLE + decp = memchr (s, set_decimal, w); + if (!decp) + return; + + /* If there's an `E' we can only delete 0s before the E. */ + expp = memchr (s, 'E', w); + if (expp) + { + while (expp[-n - 1] == '0') + n++; + if (expp[-n - 1] == set_decimal) + n++; + memmove (&s[n], s, expp - s - n); + memset (s, ' ', n); + return; + } + + /* Otherwise delete all trailing 0s. */ + n++; + while (s[w - n] == '0') + n++; + if (s[w - n] != set_decimal) + { + /* Avoid stripping `.0' to `'. */ + if (w == n || !isdigit ((unsigned char) s[w - n - 1])) + n -= 2; + } + else + n--; + memmove (&s[n], s, w - n); + memset (s, ' ', n); +#endif +} + +/* Main conversion functions. */ + +static void insert_commas (char *dst, const char *src, + const struct fmt_spec *fp); +static int year4 (int year); +static int try_CCx (char *s, const struct fmt_spec *fp, double v); + +#if FLT_RADIX!=2 +#error Write your own floating-point output routines. +#endif + +/* PORTME: + + Some of the routines in this file are likely very specific to + base-2 representation of floating-point numbers, most notably the + routines that use frexp() or ldexp(). These attempt to extract + individual digits by setting the base-2 exponent and + multiplying/dividing by powers of 2. In base-2 numeration systems, + this just nudges the exponent up or down, but in base-10 floating + point, such multiplications/division can cause catastrophic loss of + precision. + + The author has never personally used a machine that didn't use + binary floating point formats, so he is unwilling, and perhaps + unable, to code around this "problem". */ + +/* Converts a number between 0 and 15 inclusive to a `hexit' + [0-9A-F]. */ +#define MAKE_HEXIT(X) ("0123456789ABCDEF"[X]) + +/* Table of powers of 10. */ +static const double power10[] = + { + 0, /* Not used. */ + 1e01, 1e02, 1e03, 1e04, 1e05, 1e06, 1e07, 1e08, 1e09, 1e10, + 1e11, 1e12, 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20, + 1e21, 1e22, 1e23, 1e24, 1e25, 1e26, 1e27, 1e28, 1e29, 1e30, + 1e31, 1e32, 1e33, 1e34, 1e35, 1e36, 1e37, 1e38, 1e39, 1e40, + }; + +/* Handles F format. */ +static int +convert_F (char *dst, const struct fmt_spec *fp, const union value *v) +{ + if (!try_F (dst, fp, v)) + convert_E (dst, fp, v); + return 1; +} + +/* Handles N format. */ +static int +convert_N (char *dst, const struct fmt_spec *fp, const union value *v) +{ + double d = floor (v->f); + + if (d < 0 || d == SYSMIS) + { + msg (ME, _("The N output format cannot be used to output a " + "negative number or the system-missing value.")); + return 0; + } + + if (d < power10[fp->w]) + { + char buf[128]; + sprintf (buf, "%0*.0f", fp->w, v->f); + memcpy (dst, buf, fp->w); + } + else + memset (dst, '*', fp->w); + + return 1; +} + +/* Handles E format. Also operates as fallback for some other + formats. */ +static int +convert_E (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Temporary buffer. */ + char buf[128]; + + /* Ranged number of decimal places. */ + int d; + + /* Check that the format is width enough. + Although PSPP generally checks this, convert_E() can be called as + a fallback from other formats which do not check. */ + if (fp->w < 6) + { + memset (dst, '*', fp->w); + return 1; + } + + /* Put decimal places in usable range. */ + d = min (fp->d, fp->w - 6); + if (v->f < 0) + d--; + if (d < 0) + d = 0; + sprintf (buf, "%*.*E", fp->w, d, v->f); + + /* What we do here is force the exponent part to have four + characters whenever possible. That is, 1.00E+99 is okay (`E+99') + but 1.00E+100 (`E+100') must be coerced to 1.00+100 (`+100'). On + the other hand, 1.00E1000 (`E+100') cannot be canonicalized. + Note that ANSI C guarantees at least two digits in the + exponent. */ + if (fabs (v->f) > 1e99) + { + /* Pointer to the `E' in buf. */ + char *cp; + + cp = strchr (buf, 'E'); + if (cp) + { + /* Exponent better not be bigger than an int. */ + int exp = atoi (cp + 1); + + if (abs (exp) > 99 && abs (exp) < 1000) + { + /* Shift everything left one place: 1.00e+100 -> 1.00+100. */ + cp[0] = cp[1]; + cp[1] = cp[2]; + cp[2] = cp[3]; + cp[3] = cp[4]; + } + else if (abs (exp) >= 1000) + memset (buf, '*', fp->w); + } + } + + /* The C locale always uses a period `.' as a decimal point. + Translate to comma if necessary. */ + if ((set_decimal == ',' && fp->type != FMT_DOT) + || (set_decimal == '.' && fp->type == FMT_DOT)) + { + char *cp = strchr (buf, '.'); + if (cp) + *cp = ','; + } + + memcpy (dst, buf, fp->w); + return 1; +} + +/* Handles COMMA, DOT, DOLLAR, and PCT formats. */ +static int +convert_F_plus (char *dst, const struct fmt_spec *fp, const union value *v) +{ + char buf[40]; + + if (try_F (buf, fp, v)) + insert_commas (dst, buf, fp); + else + convert_E (dst, fp, v); + + return 1; +} + +static int +convert_Z (char *dst, const struct fmt_spec *fp, const union value *v) +{ + static int warned = 0; + + if (!warned) + { + msg (MW, _("Quality of zoned decimal (Z) output format code is " + "suspect. Check your results, report bugs to author.")); + warned = 1; + } + + if (v->f == SYSMIS) + { + msg (ME, _("The system-missing value cannot be output as a zoned " + "decimal number.")); + return 0; + } + + { + char buf[41]; + double d; + int i; + + d = fabs (floor (v->f)); + if (d >= power10[fp->w]) + { + msg (ME, _("Number %g too big to fit in field with format Z%d.%d."), + v->f, fp->w, fp->d); + return 0; + } + + sprintf (buf, "%*.0f", fp->w, v->f); + for (i = 0; i < fp->w; i++) + dst[i] = (buf[i] - '0') | 0xf0; + if (v->f < 0) + dst[fp->w - 1] &= 0xdf; + } + + return 1; +} + +static int +convert_A (char *dst, const struct fmt_spec *fp, const union value *v) +{ + memcpy (dst, v->c, fp->w); + return 1; +} + +static int +convert_AHEX (char *dst, const struct fmt_spec *fp, const union value *v) +{ + int i; + + for (i = 0; i < fp->w / 2; i++) + { + ((unsigned char *) dst)[i * 2] = MAKE_HEXIT ((v->c[i]) >> 4); + ((unsigned char *) dst)[i * 2 + 1] = MAKE_HEXIT ((v->c[i]) & 0xf); + } + + return 1; +} + +static int +convert_IB (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Strategy: Basically the same as convert_PIBHEX() but with base + 256. Then it's necessary to negate the two's-complement result if + v->f is negative. */ + + /* Used for constructing the two's-complement result. */ + unsigned temp[8]; + + /* Fraction (mantissa). */ + double frac; + + /* Exponent. */ + int exp; + + /* Difference between exponent and (-8*fp->w-1). */ + int diff; + + /* Counter. */ + int i; + + /* Make the exponent (-8*fp->w-1). */ + frac = frexp (fabs (v->f), &exp); + diff = exp - (-8 * fp->w - 1); + exp -= diff; + frac *= ldexp (1.0, diff); + + /* Extract each base-256 digit. */ + for (i = 0; i < fp->w; i++) + { + modf (frac, &frac); + frac *= 256.0; + temp[i] = floor (frac); + } + + /* Perform two's-complement negation if v->f is negative. */ + if (v->f < 0) + { + /* Perform NOT operation. */ + for (i = 0; i < fp->w; i++) + temp[i] = ~temp[i]; + /* Add 1 to the whole number. */ + for (i = fp->w - 1; i >= 0; i--) + { + temp[i]++; + if (temp[i]) + break; + } + } + memcpy (dst, temp, fp->w); + if (endian == LITTLE) + mm_reverse (dst, fp->w); + + return 1; +} + +static int +convert_P (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Buffer for v->f*2-1 characters + a decimal point if library is + not quite compliant + a null. */ + char buf[17]; + + /* Counter. */ + int i; + + /* Main extraction. */ + sprintf (buf, "%0*.0f", fp->w * 2 - 1, floor (fabs (v->f))); + + for (i = 0; i < fp->w; i++) + ((unsigned char *) dst)[i] + = ((buf[i * 2] - '0') << 4) + buf[i * 2 + 1] - '0'; + + /* Set sign. */ + dst[fp->w - 1] &= 0xf0; + if (v->f >= 0.0) + dst[fp->w - 1] |= 0xf; + else + dst[fp->w - 1] |= 0xd; + + return 1; +} + +static int +convert_PIB (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Strategy: Basically the same as convert_IB(). */ + + /* Fraction (mantissa). */ + double frac; + + /* Exponent. */ + int exp; + + /* Difference between exponent and (-8*fp->w). */ + int diff; + + /* Counter. */ + int i; + + /* Make the exponent (-8*fp->w). */ + frac = frexp (fabs (v->f), &exp); + diff = exp - (-8 * fp->w); + exp -= diff; + frac *= ldexp (1.0, diff); + + /* Extract each base-256 digit. */ + for (i = 0; i < fp->w; i++) + { + modf (frac, &frac); + frac *= 256.0; + ((unsigned char *) dst)[i] = floor (frac); + } + if (endian == LITTLE) + mm_reverse (dst, fp->w); + + return 1; +} + +static int +convert_PIBHEX (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Strategy: Use frexp() to create a normalized result (but mostly + to find the base-2 exponent), then change the base-2 exponent to + (-4*fp->w) using multiplication and division by powers of two. + Extract each hexit by multiplying by 16. */ + + /* Fraction (mantissa). */ + double frac; + + /* Exponent. */ + int exp; + + /* Difference between exponent and (-4*fp->w). */ + int diff; + + /* Counter. */ + int i; + + /* Make the exponent (-4*fp->w). */ + frac = frexp (fabs (v->f), &exp); + diff = exp - (-4 * fp->w); + exp -= diff; + frac *= ldexp (1.0, diff); + + /* Extract each hexit. */ + for (i = 0; i < fp->w; i++) + { + modf (frac, &frac); + frac *= 16.0; + *dst++ = MAKE_HEXIT ((int) floor (frac)); + } + + return 1; +} + +static int +convert_PK (char *dst, const struct fmt_spec *fp, const union value *v) +{ + /* Buffer for v->f*2 characters + a decimal point if library is not + quite compliant + a null. */ + char buf[18]; + + /* Counter. */ + int i; + + /* Main extraction. */ + sprintf (buf, "%0*.0f", fp->w * 2, floor (fabs (v->f))); + + for (i = 0; i < fp->w; i++) + ((unsigned char *) dst)[i] + = ((buf[i * 2] - '0') << 4) + buf[i * 2 + 1] - '0'; + + return 1; +} + +static int +convert_RB (char *dst, const struct fmt_spec *fp, const union value *v) +{ + union + { + double d; + char c[8]; + } + u; + + u.d = v->f; + memcpy (dst, u.c, fp->w); + + return 1; +} + +static int +convert_RBHEX (char *dst, const struct fmt_spec *fp, const union value *v) +{ + union + { + double d; + char c[8]; + } + u; + + int i; + + u.d = v->f; + for (i = 0; i < fp->w / 2; i++) + { + *dst++ = MAKE_HEXIT (u.c[i] >> 4); + *dst++ = MAKE_HEXIT (u.c[i] & 15); + } + + return 1; +} + +static int +convert_CCx (char *dst, const struct fmt_spec *fp, const union value *v) +{ + if (try_CCx (dst, fp, v->f)) + return 1; + else + { + struct fmt_spec f; + + f.type = FMT_COMMA; + f.w = fp->w; + f.d = fp->d; + + return convert_F (dst, &f, v); + } +} + +static int +convert_date (char *dst, const struct fmt_spec *fp, const union value *v) +{ + static const char *months[12] = + { + "JAN", "FEB", "MAR", "APR", "MAY", "JUN", + "JUL", "AUG", "SEP", "OCT", "NOV", "DEC", + }; + + char buf[64] = {0}; + int month, day, year; + + julian_to_calendar (v->f / 86400., &year, &month, &day); + switch (fp->type) + { + case FMT_DATE: + if (fp->w >= 11) + sprintf (buf, "%02d-%s-%04d", day, months[month - 1], year); + else + sprintf (buf, "%02d-%s-%02d", day, months[month - 1], year % 100); + break; + case FMT_EDATE: + if (fp->w >= 10) + sprintf (buf, "%02d.%02d.%04d", day, month, year); + else + sprintf (buf, "%02d.%02d.%02d", day, month, year % 100); + break; + case FMT_SDATE: + if (fp->w >= 10) + sprintf (buf, "%04d/%02d/%02d", year, month, day); + else + sprintf (buf, "%02d/%02d/%02d", year % 100, month, day); + break; + case FMT_ADATE: + if (fp->w >= 10) + sprintf (buf, "%02d/%02d/%04d", month, day, year); + else + sprintf (buf, "%02d/%02d/%02d", month, day, year % 100); + break; + case FMT_JDATE: + { + int yday = (v->f / 86400.) - calendar_to_julian (year, 1, 1) + 1; + + if (fp->w >= 7) + { + if (year4 (year)) + sprintf (buf, "%04d%03d", year, yday); + } + else + sprintf (buf, "%02d%03d", year % 100, yday); + break; + } + case FMT_QYR: + if (fp->w >= 8) + sprintf (buf, "%d Q% 04d", (month - 1) / 3 + 1, year); + else + sprintf (buf, "%d Q% 02d", (month - 1) / 3 + 1, year % 100); + break; + case FMT_MOYR: + if (fp->w >= 8) + sprintf (buf, "%s% 04d", months[month - 1], year); + else + sprintf (buf, "%s% 02d", months[month - 1], year % 100); + break; + case FMT_WKYR: + { + int yday = (v->f / 86400.) - calendar_to_julian (year, 1, 1) + 1; + + if (fp->w >= 10) + sprintf (buf, "%02d WK% 04d", (yday - 1) / 7 + 1, year); + else + sprintf (buf, "%02d WK% 02d", (yday - 1) / 7 + 1, year % 100); + } + break; + case FMT_DATETIME: + { + char *cp; + + cp = spprintf (buf, "%02d-%s-%04d %02d:%02d", + day, months[month - 1], year, + (int) fmod (floor (v->f / 60. / 60.), 24.), + (int) fmod (floor (v->f / 60.), 60.)); + if (fp->w >= 20) + { + int w, d; + + if (fp->w >= 22 && fp->d > 0) + { + d = min (fp->d, fp->w - 21); + w = 3 + d; + } + else + { + w = 2; + d = 0; + } + + cp = spprintf (cp, ":%0*.*f", w, d, fmod (v->f, 60.)); + } + } + break; +#if __CHECKER__ + case 42000: + assert (0); +#endif + default: + assert (0); + } + + if (buf[0] == 0) + return 0; + st_bare_pad_copy (dst, buf, fp->w); + return 1; +} + +static int +convert_time (char *dst, const struct fmt_spec *fp, const union value *v) +{ + char temp_buf[40]; + char *cp; + + double time; + int width; + + if (fabs (v->f) > 1e20) + { + msg (ME, _("Time value %g too large in magnitude to convert to " + "alphanumeric time."), v->f); + return 0; + } + + time = v->f; + width = fp->w; + cp = temp_buf; + if (time < 0) + *cp++ = '-', time = -time; + if (fp->type == FMT_DTIME) + { + double days = floor (time / 60. / 60. / 24.); + cp = spprintf (temp_buf, "%02.0f ", days); + time = time - days * 60. * 60. * 24.; + width -= 3; + } + else + cp = temp_buf; + + cp = spprintf (cp, "%02.0f:%02.0f", + fmod (floor (time / 60. / 60.), 24.), + fmod (floor (time / 60.), 60.)); + + if (width >= 8) + { + int w, d; + + if (width >= 10 && fp->d >= 0 && fp->d != 0) + d = min (fp->d, width - 9), w = 3 + d; + else + w = 2, d = 0; + + cp = spprintf (cp, ":%0*.*f", w, d, fmod (time, 60.)); + } + st_bare_pad_copy (dst, temp_buf, fp->w); + + return 1; +} + +static int +convert_WKDAY (char *dst, const struct fmt_spec *fp, const union value *v) +{ + static const char *weekdays[7] = + { + "SUNDAY", "MONDAY", "TUESDAY", "WEDNESDAY", + "THURSDAY", "FRIDAY", "SATURDAY", + }; + + int x = v->f; + + if (x < 1 || x > 7) + { + msg (ME, _("Weekday index %d does not lie between 1 and 7."), x); + return 0; + } + st_bare_pad_copy (dst, weekdays[x - 1], fp->w); + + return 1; +} + +static int +convert_MONTH (char *dst, const struct fmt_spec *fp, const union value *v) +{ + static const char *months[12] = + { + "JANUARY", "FEBRUARY", "MARCH", "APRIL", "MAY", "JUNE", + "JULY", "AUGUST", "SEPTEMBER", "OCTOBER", "NOVEMBER", "DECEMBER", + }; + + int x = v->f; + + if (x < 1 || x > 12) + { + msg (ME, _("Month index %d does not lie between 1 and 12."), x); + return 0; + } + + st_bare_pad_copy (dst, months[x - 1], fp->w); + + return 1; +} + +/* Helper functions. */ + +/* Copies SRC to DST, inserting commas and dollar signs as appropriate + for format spec *FP. */ +static void +insert_commas (char *dst, const char *src, const struct fmt_spec *fp) +{ + /* Number of leading spaces in the number. This is the amount of + room we have for inserting commas and dollar signs. */ + int n_spaces; + + /* Number of digits before the decimal point. This is used to + determine the Number of commas to insert. */ + int n_digits; + + /* Number of commas to insert. */ + int n_commas; + + /* Number of items ,%$ to insert. */ + int n_items; + + /* Number of n_items items not to use for commas. */ + int n_reserved; + + /* Digit iterator. */ + int i; + + /* Source pointer. */ + const char *sp; + + /* Count spaces and digits. */ + sp = src; + while (sp < src + fp->w && *sp == ' ') + sp++; + n_spaces = sp - src; + sp = src + n_spaces; + if (*sp == '-') + sp++; + n_digits = 0; + while (sp + n_digits < src + fp->w && isdigit ((unsigned char) sp[n_digits])) + n_digits++; + n_commas = (n_digits - 1) / 3; + n_items = n_commas + (fp->type == FMT_DOLLAR || fp->type == FMT_PCT); + + /* Check whether we have enough space to do insertions. */ + if (!n_spaces || !n_items) + { + memcpy (dst, src, fp->w); + return; + } + if (n_items > n_spaces) + { + n_items -= n_commas; + if (!n_items) + { + memcpy (dst, src, fp->w); + return; + } + } + + /* Put spaces at the beginning if there's extra room. */ + if (n_spaces > n_items) + { + memset (dst, ' ', n_spaces - n_items); + dst += n_spaces - n_items; + } + + /* Insert $ and reserve space for %. */ + n_reserved = 0; + if (fp->type == FMT_DOLLAR) + { + *dst++ = '$'; + n_items--; + } + else if (fp->type == FMT_PCT) + n_reserved = 1; + + /* Copy negative sign and digits, inserting commas. */ + if (sp - src > n_spaces) + *dst++ = '-'; + for (i = n_digits; i; i--) + { + if (i % 3 == 0 && n_digits > i && n_items > n_reserved) + { + n_items--; + *dst++ = fp->type == FMT_COMMA ? set_grouping : set_decimal; + } + *dst++ = *sp++; + } + + /* Copy decimal places and insert % if necessary. */ + memcpy (dst, sp, fp->w - (sp - src)); + if (fp->type == FMT_PCT && n_items > 0) + dst[fp->w - (sp - src)] = '%'; +} + +/* Returns 1 if YEAR (i.e., 1987) can be represented in four digits, 0 + otherwise. */ +static int +year4 (int year) +{ + if (year >= 1 && year <= 9999) + return 1; + msg (ME, _("Year %d cannot be represented in four digits for " + "output formatting purposes."), year); + return 0; +} + +static int +try_CCx (char *dst, const struct fmt_spec *fp, double v) +{ + struct set_cust_currency *cc = &set_cc[fp->type - FMT_CCA]; + + struct fmt_spec f; + + char buf[64]; + char buf2[64]; + char *cp; + + /* Determine length available, decimal character for number + proper. */ + f.type = cc->decimal == set_decimal ? FMT_COMMA : FMT_DOT; + f.w = fp->w - strlen (cc->prefix) - strlen (cc->suffix); + if (v < 0) + f.w -= strlen (cc->neg_prefix) + strlen (cc->neg_suffix) - 1; + else + /* Convert -0 to +0. */ + v = fabs (v); + f.d = fp->d; + + if (f.w <= 0) + return 0; + + /* There's room for all that currency crap. Let's do the F + conversion first. */ + if (!convert_F (buf, &f, (union value *) &v) || *buf == '*') + return 0; + insert_commas (buf2, buf, &f); + + /* Postprocess back into buf. */ + cp = buf; + if (v < 0) + cp = stpcpy (cp, cc->neg_prefix); + cp = stpcpy (cp, cc->prefix); + { + char *bp = buf2; + while (*bp == ' ') + bp++; + + assert ((v >= 0) ^ (*bp == '-')); + if (v < 0) + bp++; + + memcpy (cp, bp, f.w - (bp - buf2)); + cp += f.w - (bp - buf2); + } + cp = stpcpy (cp, cc->suffix); + if (v < 0) + cp = stpcpy (cp, cc->neg_suffix); + + /* Copy into dst. */ + assert (cp - buf <= fp->w); + if (cp - buf < fp->w) + { + memcpy (&dst[fp->w - (cp - buf)], buf, cp - buf); + memset (dst, ' ', fp->w - (cp - buf)); + } + else + memcpy (dst, buf, fp->w); + + return 1; +} + +/* This routine relies on the underlying implementation of sprintf: + + If the number has a magnitude 1e40 or greater, then we needn't + bother with it, since it's guaranteed to need processing in + scientific notation. + + Otherwise, do a binary search for the base-10 magnitude of the + thing. log10() is not accurate enough, and the alternatives are + frightful. Besides, we never need as many as 6 (pairs of) + comparisons. The algorithm used for searching is Knuth's Algorithm + 6.2.1C (Uniform binary search). + + DON'T CHANGE ANYTHING HERE UNLESS YOU'VE THOUGHT ABOUT IT FOR A + LONG TIME! The rest of the program is heavily dependent on + specific properties of this routine's output. LOG ALL CHANGES! */ +static int +try_F (char *dst, const struct fmt_spec *fp, const union value *value) +{ + /* This is the DELTA array from Knuth. + DELTA[j] = floor((40+2**(j-1))/(2**j)). */ + static const int delta[8] = + { + 0, (40 + 1) / 2, (40 + 2) / 4, (40 + 4) / 8, (40 + 8) / 16, + (40 + 16) / 32, (40 + 32) / 64, (40 + 64) / 128, + }; + + /* The number of digits in floor(v), including sign. This is `i' + from Knuth. */ + int n_int = (40 + 1) / 2; + + /* Used to step through delta[]. This is `j' from Knuth. */ + int j = 2; + + /* Value. */ + double v = value->f; + + /* Magnitude of v. This is `K' from Knuth. */ + double mag; + + /* Number of characters for the fractional part, including the + decimal point. */ + int n_dec; + + /* Pointer into buf used for formatting. */ + char *cp; + + /* Used to count characters formatted by nsprintf(). */ + int n; + + /* Temporary buffer. */ + char buf[128]; + + /* First check for infinities and NaNs. 12/13/96. */ + if (!finite (v)) + { + n = nsprintf (buf, "%f", v); + if (n > fp->w) + memset (buf, '*', fp->w); + else if (n < fp->w) + { + memmove (&buf[fp->w - n], buf, n); + memset (buf, ' ', fp->w - n); + } + memcpy (dst, buf, fp->w); + return 1; + } + + /* Then check for radically out-of-range values. */ + mag = fabs (v); + if (mag >= power10[fp->w]) + return 0; + + if (mag < 1.0) + { + n_int = 0; + + /* Avoid printing `-.000'. 7/6/96. */ + if (approx_eq (v, 0.0)) + v = 0.0; + } + else + /* Now perform a `uniform binary search' based on the tables + power10[] and delta[]. After this step, nint is the number of + digits in floor(v), including any sign. */ + for (;;) + { + if (mag >= power10[n_int]) /* Should this be approx_ge()? */ + { + assert (delta[j]); + n_int += delta[j++]; + } + else if (mag < power10[n_int - 1]) + { + assert (delta[j]); + n_int -= delta[j++]; + } + else + break; + } + + /* If we have any decimal places, then there is a decimal point, + too. */ + n_dec = fp->d; + if (n_dec) + n_dec++; + + /* 1/10/96: If there aren't any digits at all, add one. This occurs + only when fabs(v) < 1.0. */ + if (n_int + n_dec == 0) + n_int++; + + /* Give space for a minus sign. Moved 1/10/96. */ + if (v < 0) + n_int++; + + /* Normally we only go through the loop once; occasionally twice. + Three times or more indicates a very serious bug somewhere. */ + for (;;) + { + /* Check out the total length of the string. */ + cp = buf; + if (n_int + n_dec > fp->w) + { + /* The string is too long. Let's see what can be done. */ + if (n_int <= fp->w) + /* If we can, just reduce the number of decimal places. */ + n_dec = fp->w - n_int; + else + return 0; + } + else if (n_int + n_dec < fp->w) + { + /* The string is too short. Left-pad with spaces. */ + int n_spaces = fp->w - n_int - n_dec; + memset (cp, ' ', n_spaces); + cp += n_spaces; + } + + /* Finally, format the number. */ + if (n_dec) + n = nsprintf (cp, "%.*f", n_dec - 1, v); + else + n = nsprintf (cp, "%.0f", v); + + /* If v is positive and its magnitude is less than 1... */ + if (n_int == 0) + { + if (*cp == '0') + { + /* The value rounds to `.###'. */ + memmove (cp, &cp[1], n - 1); + n--; + } + else + { + /* The value rounds to `1.###'. */ + n_int = 1; + continue; + } + } + /* Else if v is negative and its magnitude is less than 1... */ + else if (v < 0 && n_int == 1) + { + if (cp[1] == '0') + { + /* The value rounds to `-.###'. */ + memmove (&cp[1], &cp[2], n - 2); + n--; + } + else + { + /* The value rounds to `-1.###'. */ + n_int = 2; + continue; + } + } + + /* Check for a correct number of digits & decimal places & stuff. + This is just a desperation check. Hopefully it won't fail too + often, because then we have to run through the whole loop again: + sprintf() is not a fast operation with floating-points! */ + if (n == n_int + n_dec) + { + /* Convert periods `.' to commas `,' for our foreign friends. */ + if ((set_decimal == ',' && fp->type != FMT_DOT) + || (set_decimal == '.' && fp->type == FMT_DOT)) + { + cp = strchr (cp, '.'); + if (cp) + *cp = ','; + } + + memcpy (dst, buf, fp->w); + return 1; + } + + n_int = n - n_dec; /* FIXME? Need an idiot check on resulting n_int? */ + } +} diff --git a/src/debug-print.h b/src/debug-print.h new file mode 100644 index 00000000..061b2195 --- /dev/null +++ b/src/debug-print.h @@ -0,0 +1,54 @@ +/* This file can be included multiple times. It redeclares its macros + appropriately each time, like assert.h. */ + +#undef debug_printf +#undef debug_puts +#undef debug_putc + +#if DEBUGGING + +#define debug_printf(args) \ + do \ + { \ + printf args; \ + fflush (stdout); \ + } \ + while (0) + +#define debug_puts(string) \ + do \ + { \ + puts (string); \ + fflush (stdout); \ + } \ + while (0) + +#define debug_putc(char, stream) \ + do \ + { \ + putc (char, stream); \ + fflush (stdout); \ + } \ + while (0) + +#else /* !DEBUGGING */ + +#define debug_printf(args) \ + do \ + { \ + } \ + while (0) + +#define debug_puts(string) \ + do \ + { \ + } \ + while (0) + +#define debug_putc(char, stream) \ + do \ + { \ + } \ + while (0) + +#endif /* !DEBUGGING */ diff --git a/src/descript.q b/src/descript.q new file mode 100644 index 00000000..168f29aa --- /dev/null +++ b/src/descript.q @@ -0,0 +1,866 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* FIXME: Many possible optimizations. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "bitvector.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "approx.h" +#include "magic.h" +#include "stats.h" +#include "som.h" +#include "tab.h" +#include "var.h" +#include "vfm.h" + +/* (specification) + DESCRIPTIVES (dsc_): + *variables=custom; + +missing=miss:!variable/listwise,incl:!noinclude/include; + +format=labeled:!labels/nolabels,indexed:!noindex/index,lined:!line/serial; + +save=; + +options[op_]=1,2,3,4,5,6,7,8; + +statistics[st_]=all,1|mean,2|semean,5|stddev,6|variance,7|kurtosis, + 8|skewness,9|range,10|minimum,11|maximum,12|sum, + 13|default,14|seskewness,15|sekurtosis; + +sort=sortby:mean/semean/stddev/variance/kurtosis/skewness/range/ + range/minimum/maximum/sum/name/seskewness/sekurtosis/!none, + order:!a/d. +*/ +/* (declarations) */ +/* (functions) */ + +/* DESCRIPTIVES private data. */ + +/* Describes properties of a distribution for the purpose of + calculating a Z-score. */ +struct dsc_z_score + { + struct variable *s, *d; /* Source, destination variable. */ + double mean; /* Distribution mean. */ + double std_dev; /* Distribution standard deviation. */ + }; + +/* DESCRIPTIVES transformation (for calculating Z-scores). */ +struct descriptives_trns + { + struct trns_header h; + int n; /* Number of Z-scores. */ + struct dsc_z_score *z; /* Array of Z-scores. */ + }; + +/* These next three vars, see comment at top of display(). */ +/* Number of cases missing listwise, even if option 5 not selected. */ +static double d_glob_miss_list; + +/* Number of total *cases* valid or missing, as a double. Unless + option 5 is selected, d_glob_missing is 0. */ +static double d_glob_valid, d_glob_missing; + +/* Set when a weighting variable is missing or <=0. */ +static int bad_weight; + +/* Number of generic zvarnames we've generated in this execution. */ +static int z_count; + +/* Variables specified on command. */ +static struct variable **v_variables; +static int n_variables; + +/* Command specifications. */ +static struct cmd_descriptives cmd; + +/* Whether z-scores are computed. */ +static int z_scores; + +/* Statistic to sort by. */ +static int sortby_stat; + +/* Statistics to display. */ +static unsigned long stats; + +/* Easier access to long-named arrays. */ +#define stat cmd.a_statistics +#define opt cmd.a_options + +/* Groups of statistics. */ +#define BI BIT_INDEX + +#define dsc_default \ + (BI (dsc_mean) | BI (dsc_stddev) | BI (dsc_min) | BI (dsc_max)) + +#define dsc_all \ + (BI (dsc_sum) | BI (dsc_min) | BI (dsc_max) \ + | BI (dsc_mean) | BI (dsc_semean) | BI (dsc_stddev) \ + | BI (dsc_variance) | BI (dsc_kurt) | BI (dsc_sekurt) \ + | BI (dsc_skew) | BI (dsc_seskew) | BI (dsc_range) \ + | BI (dsc_range)) + +/* Table of options. */ +#define op_incl_miss DSC_OP_1 /* Honored. */ +#define op_no_varlabs DSC_OP_2 /* Ignored. */ +#define op_zscores DSC_OP_3 /* Honored. */ +#define op_index DSC_OP_4 /* FIXME. */ +#define op_excl_miss DSC_OP_5 /* Honored. */ +#define op_serial DSC_OP_6 /* Honored. */ +#define op_narrow DSC_OP_7 /* Ignored. */ +#define op_no_varnames DSC_OP_8 /* Honored. */ + +/* Describes one statistic that can be calculated. */ +/* FIXME: Currently sm,col_width are not used. */ +struct dsc_info + { + int st_indx; /* Index into st_a_statistics[]. */ + int sb_indx; /* Sort-by index. */ + const char *s10; /* Name, stuffed into 10 columns. */ + const char *s8; /* Name, stuffed into 8 columns. */ + const char *sm; /* Name, stuffed minimally. */ + const char *s; /* Full name. */ + int max_degree; /* Highest degree necessary to calculate this + statistic. */ + int col_width; /* Column width (not incl. spacing between columns) */ + }; + +/* Table of statistics, indexed by dsc_*. */ +static struct dsc_info dsc_info[dsc_n_stats] = +{ + {DSC_ST_MEAN, DSC_MEAN, N_("Mean"), N_("Mean"), N_("Mean"), N_("mean"), 1, 10}, + {DSC_ST_SEMEAN, DSC_SEMEAN, N_("S.E. Mean"), N_("S E Mean"), N_("SE"), + N_("standard error of mean"), 2, 10}, + {DSC_ST_STDDEV, DSC_STDDEV, N_("Std Dev"), N_("Std Dev"), N_("SD"), + N_("standard deviation"), 2, 11}, + {DSC_ST_VARIANCE, DSC_VARIANCE, N_("Variance"), N_("Variance"), + N_("Var"), N_("variance"), 2, 12}, + {DSC_ST_KURTOSIS, DSC_KURTOSIS, N_("Kurtosis"), N_("Kurtosis"), + N_("Kurt"), N_("kurtosis"), 4, 9}, + {DSC_ST_SEKURTOSIS, DSC_SEKURTOSIS, N_("S.E. Kurt"), N_("S E Kurt"), N_("SEKurt"), + N_("standard error of kurtosis"), 0, 9}, + {DSC_ST_SKEWNESS, DSC_SKEWNESS, N_("Skewness"), N_("Skewness"), N_("Skew"), + N_("skewness"), 3, 9}, + {DSC_ST_SESKEWNESS, DSC_SESKEWNESS, N_("S.E. Skew"), N_("S E Skew"), N_("SESkew"), + N_("standard error of skewness"), 0, 9}, + {DSC_ST_RANGE, DSC_RANGE, N_("Range"), N_("Range"), N_("Rng"), N_("range"), 0, 10}, + {DSC_ST_MINIMUM, DSC_MINIMUM, N_("Minimum"), N_("Minimum"), N_("Min"), + N_("minimum"), 0, 10}, + {DSC_ST_MAXIMUM, DSC_MAXIMUM, N_("Maximum"), N_("Maximum"), N_("Max"), + N_("maximum"), 0, 10}, + {DSC_ST_SUM, DSC_SUM, N_("Sum"), N_("Sum"), N_("Sum"), N_("sum"), 1, 13}, +}; + +/* Z-score functions. */ +static int generate_z_varname (struct variable * v); +static void dump_z_table (void); +static void run_z_pass (void); + +/* Procedure execution functions. */ +static int calc (struct ccase *); +static void precalc (void); +static void postcalc (void); +static void display (void); + +/* Parser and outline. */ + +int +cmd_descriptives (void) +{ + struct variable *v; + int i; + + v_variables = NULL; + n_variables = 0; + + lex_match_id ("DESCRIPTIVES"); + lex_match_id ("CONDESCRIPTIVES"); + if (!parse_descriptives (&cmd)) + goto lossage; + + if (n_variables == 0) + goto lossage; + for (i = 0; i < n_variables; i++) + { + v = v_variables[i]; + v->p.dsc.dup = 0; + v->p.dsc.zname[0] = 0; + } + + if (n_variables < 0) + { + msg (SE, _("No variables specified.")); + goto lossage; + } + + if (cmd.sbc_options && (cmd.sbc_save || cmd.sbc_format || cmd.sbc_missing)) + { + msg (SE, _("OPTIONS may not be used with SAVE, FORMAT, or MISSING.")); + goto lossage; + } + + if (!cmd.sbc_options) + { + if (cmd.incl == DSC_INCLUDE) + opt[op_incl_miss] = 1; + if (cmd.labeled == DSC_NOLABELS) + opt[op_no_varlabs] = 1; + if (cmd.sbc_save) + opt[op_zscores] = 1; + if (cmd.miss == DSC_LISTWISE) + opt[op_excl_miss] = 1; + if (cmd.lined == DSC_SERIAL) + opt[op_serial] = 1; + } + + /* Construct z-score varnames, show translation table. */ + if (opt[op_zscores]) + { + z_count = 0; + for (i = 0; i < n_variables; i++) + { + v = v_variables[i]; + if (v->p.dsc.dup++) + continue; + + if (v->p.dsc.zname[0] == 0) + if (!generate_z_varname (v)) + goto lossage; + } + dump_z_table (); + z_scores = 1; + } + + /* Figure out statistics to calculate. */ + stats = 0; + if (stat[DSC_ST_DEFAULT] || !cmd.sbc_statistics) + stats |= dsc_default; + if (stat[DSC_ST_ALL]) + stats |= dsc_all; + for (i = 0; i < dsc_n_stats; i++) + if (stat[dsc_info[i].st_indx]) + stats |= BIT_INDEX (i); + if (stats & dsc_kurt) + stats |= dsc_sekurt; + if (stats & dsc_skew) + stats |= dsc_seskew; + + /* Check the sort order. */ + sortby_stat = -1; + if (cmd.sortby == DSC_NONE) + sortby_stat = -2; + else if (cmd.sortby != DSC_NAME) + { + for (i = 0; i < n_variables; i++) + if (dsc_info[i].sb_indx == cmd.sortby) + { + sortby_stat = i; + if (!(stats & BIT_INDEX (i))) + { + msg (SE, _("It's not possible to sort on `%s' without " + "displaying `%s'."), + gettext (dsc_info[i].s), gettext (dsc_info[i].s)); + goto lossage; + } + } + assert (sortby_stat != -1); + } + + /* Data pass! */ + update_weighting (&default_dict); + bad_weight = 0; + procedure (precalc, calc, postcalc); + + if (bad_weight) + msg (SW, _("At least one case in the data file had a weight value " + "that was system-missing, zero, or negative. These case(s) " + "were ignored.")); + + /* Z-scoring! */ + if (z_scores) + run_z_pass (); + + if (v_variables) + free (v_variables); + return CMD_SUCCESS; + + lossage: + if (v_variables) + free (v_variables); + return CMD_FAILURE; +} + +/* Parses the VARIABLES subcommand. */ +static int +dsc_custom_variables (struct cmd_descriptives *cmd unused) +{ + if (!lex_match_id ("VARIABLES") + && (token != T_ID || !is_varname (tokid)) + && token != T_ALL) + return 2; + lex_match ('='); + + while (token == T_ID || token == T_ALL) + { + int i, n; + + n = n_variables; + if (!parse_variables (NULL, &v_variables, &n_variables, + PV_DUPLICATE | PV_SINGLE | PV_APPEND | PV_NUMERIC + | PV_NO_SCRATCH)) + return 0; + if (lex_match ('(')) + { + if (n_variables - n > 1) + { + msg (SE, _("Names for z-score variables must be given for " + "individual variables, not for groups of " + "variables.")); + return 0; + } + assert (n_variables - n <= 0); + if (token != T_ID) + { + msg (SE, _("Name for z-score variable expected.")); + return 0; + } + if (is_varname (tokid)) + { + msg (SE, _("Z-score variable name `%s' is a " + "duplicate variable name with a current variable."), + tokid); + return 0; + } + for (i = 0; i < n_variables; i++) + if (v_variables[i]->p.dsc.zname[0] + && !strcmp (v_variables[i]->p.dsc.zname, tokid)) + { + msg (SE, _("Z-score variable name `%s' is " + "used multiple times."), tokid); + return 0; + } + strcpy (v_variables[n_variables - 1]->p.dsc.zname, tokid); + lex_get (); + if (token != ')') + { + msg (SE, _("`)' expected after z-score variable name.")); + return 0; + } + + z_scores = 1; + } + lex_match (','); + } + return 1; +} + +/* Z scores. */ + +/* Returns 0 if NAME is a duplicate of any existing variable name or + of any previously-declared z-var name; otherwise returns 1. */ +static int +try_name (char *name) +{ + int i; + + if (is_varname (name)) + return 0; + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + if (!strcmp (v->p.dsc.zname, name)) + return 0; + } + return 1; +} + +static int +generate_z_varname (struct variable * v) +{ + char zname[10]; + + strcpy (&zname[1], v->name); + zname[0] = 'Z'; + zname[8] = '\0'; + if (try_name (zname)) + { + strcpy (v->p.dsc.zname, zname); + return 1; + } + + for (;;) + { + /* Generate variable name. */ + z_count++; + + if (z_count <= 99) + sprintf (zname, "ZSC%03d", z_count); + else if (z_count <= 108) + sprintf (zname, "STDZ%02d", z_count - 99); + else if (z_count <= 117) + sprintf (zname, "ZZZZ%02d", z_count - 108); + else if (z_count <= 126) + sprintf (zname, "ZQZQ%02d", z_count - 117); + else + { + msg (SE, _("Ran out of generic names for Z-score variables. " + "There are only 126 generic names: ZSC001-ZSC0999, " + "STDZ01-STDZ09, ZZZZ01-ZZZZ09, ZQZQ01-ZQZQ09.")); + return 0; + } + + if (try_name (zname)) + { + strcpy (v->p.dsc.zname, zname); + return 1; + } + } +} + +static void +dump_z_table (void) +{ + int count; + struct tab_table *t; + + { + int i; + + for (count = i = 0; i < n_variables; i++) + if (v_variables[i]->p.dsc.zname) + count++; + } + + t = tab_create (2, count + 1, 0); + tab_title (t, 0, _("Mapping of variables to corresponding Z-scores.")); + tab_columns (t, SOM_COL_DOWN, 1); + tab_headers (t, 0, 0, 1, 0); + tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, count); + tab_hline (t, TAL_2, 0, 1, 1); + tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Source")); + tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Target")); + tab_dim (t, tab_natural_dimensions); + + { + int i, y; + + for (i = 0, y = 1; i < n_variables; i++) + if (v_variables[i]->p.dsc.zname) + { + tab_text (t, 0, y, TAB_LEFT, v_variables[i]->name); + tab_text (t, 1, y++, TAB_LEFT, v_variables[i]->p.dsc.zname); + } + } + + tab_submit (t); +} + +/* Transformation function to calculate Z-scores. */ +static int +descriptives_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct descriptives_trns *t = (struct descriptives_trns *) trns; + struct dsc_z_score *z; + int i; + + for (i = t->n, z = t->z; i--; z++) + { + double score = c->data[z->s->fv].f; + + if (z->mean == SYSMIS || score == SYSMIS) + c->data[z->d->fv].f = SYSMIS; + else + c->data[z->d->fv].f = (score - z->mean) / z->std_dev; + } + return -1; +} + +/* Frees a descriptives_trns struct. */ +static void +descriptives_trns_free (struct trns_header * trns) +{ + struct descriptives_trns *t = (struct descriptives_trns *) trns; + + free (t->z); +} + +/* The name is a misnomer: actually this function sets up a + transformation by which scores can be converted into Z-scores. */ +static void +run_z_pass (void) +{ + struct descriptives_trns *t; + int count, i; + + for (i = 0; i < n_variables; i++) + v_variables[i]->p.dsc.dup = 0; + for (count = i = 0; i < n_variables; i++) + { + if (v_variables[i]->p.dsc.dup++) + continue; + if (v_variables[i]->p.dsc.zname) + count++; + } + + t = xmalloc (sizeof *t); + t->h.proc = descriptives_trns_proc; + t->h.free = descriptives_trns_free; + t->n = count; + t->z = xmalloc (count * sizeof *t->z); + + for (i = 0; i < n_variables; i++) + v_variables[i]->p.dsc.dup = 0; + for (count = i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + if (v->p.dsc.dup++ == 0 && v->p.dsc.zname[0]) + { + char *cp; + struct variable *d; + + t->z[count].s = v; + t->z[count].d = d = force_create_variable (&default_dict, + v->p.dsc.zname, + NUMERIC, 0); + if (v->label) + { + d->label = xmalloc (strlen (v->label) + 12); + cp = stpcpy (d->label, _("Z-score of ")); + strcpy (cp, v->label); + } + else + { + d->label = xmalloc (strlen (v->name) + 12); + cp = stpcpy (d->label, _("Z-score of ")); + strcpy (cp, v->name); + } + t->z[count].mean = v->p.dsc.stats[dsc_mean]; + t->z[count].std_dev = v->p.dsc.stats[dsc_stddev]; + if (t->z[count].std_dev == SYSMIS + || approx_eq (t->z[count].std_dev, 0.0)) + t->z[count].mean = SYSMIS; + count++; + } + } + + add_transformation ((struct trns_header *) t); +} + +/* Statistical calculation. */ + +static void +precalc (void) +{ + int i; + + for (i = 0; i < n_variables; i++) + v_variables[i]->p.dsc.dup = -2; + for (i = 0; i < n_variables; i++) + { + struct descriptives_proc *dsc = &v_variables[i]->p.dsc; + + /* Don't need to initialize more than once. */ + if (dsc->dup == -1) + continue; + dsc->dup = -1; + + dsc->valid = dsc->miss = 0.0; + dsc->X_bar = dsc->M2 = dsc->M3 = dsc->M4 = 0.0; + dsc->min = DBL_MAX; + dsc->max = -DBL_MAX; + } + d_glob_valid = d_glob_missing = 0.0; +} + +static int +calc (struct ccase * c) +{ + int i; + + /* Unique case identifier. */ + static int case_id; + + /* Get the weight for this case. */ + double w; + + if (default_dict.weight_index == -1) + w = 1.0; + else + { + w = c->data[default_dict.weight_index].f; + if (w <= 0.0 || w == SYSMIS) + { + w = 0.0; + bad_weight = 1; + } + } + + case_id++; + + /* Handle missing values. */ + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + double X = c->data[v->fv].f; + + if (X == SYSMIS || (!opt[op_incl_miss] && is_num_user_missing (X, v))) + { + if (opt[op_excl_miss]) + { + d_glob_missing += w; + return 1; + } + else + { + d_glob_miss_list += w; + goto iterate; + } + } + } + d_glob_valid += w; + +iterate: + for (i = 0; i < n_variables; i++) + { + struct descriptives_proc *inf = &v_variables[i]->p.dsc; + + double X, v; + double W_old, W_new; + double v2, v3, v4; + double w2, w3, w4; + + if (inf->dup == case_id) + continue; + inf->dup = case_id; + + X = c->data[v_variables[i]->fv].f; + if (X == SYSMIS + || (!opt[op_incl_miss] && is_num_user_missing (X, v_variables[i]))) + { + inf->miss += w; + continue; + } + + /* These formulas taken from _SPSS Statistical Algorithms_. The + names W_old, and W_new are used for W_j-1 and W_j, + respectively, and other variables simply have the subscripts + trimmed off, except for X_bar. + + I am happy that mathematical formulas may not be + copyrighted. */ + W_old = inf->valid; + W_new = inf->valid += w; + v = (w / W_new) * (X - inf->X_bar); + v2 = v * v; + v3 = v2 * v; + v4 = v3 * v; + w2 = w * w; + w3 = w2 * w; + w4 = w3 * w; + inf->M4 += (-4.0 * v * inf->M3 + 6.0 * v2 * inf->M2 + + (W_new * W_new - 3 * w * W_old / w3) * v4 * W_old * W_new); + inf->M3 += (-3.0 * v * inf->M2 + W_new * W_old / w2 + * (W_new - 2 * w) * v3); + inf->M2 += W_new * W_old / w * v2; + inf->X_bar += v; + if (X < inf->min) + inf->min = X; + if (X > inf->max) + inf->max = X; + } + return 1; +} + +static void +postcalc (void) +{ + int i; + + if (opt[op_excl_miss]) + d_glob_miss_list = d_glob_missing; + + for (i = 0; i < n_variables; i++) + { + struct descriptives_proc *dsc = &v_variables[i]->p.dsc; + double W; + + /* Don't duplicate our efforts. */ + if (dsc->dup == -2) + continue; + dsc->dup = -2; + + W = dsc->valid; + + dsc->stats[dsc_mean] = dsc->X_bar; + dsc->stats[dsc_variance] = dsc->M2 / (W - 1); + dsc->stats[dsc_stddev] = sqrt (dsc->stats[dsc_variance]); + dsc->stats[dsc_semean] = dsc->stats[dsc_stddev] / sqrt (W); + dsc->stats[dsc_min] = dsc->min == DBL_MAX ? SYSMIS : dsc->min; + dsc->stats[dsc_max] = dsc->max == -DBL_MAX ? SYSMIS : dsc->max; + dsc->stats[dsc_range] = ((dsc->min == DBL_MAX || dsc->max == -DBL_MAX) + ? SYSMIS : dsc->max - dsc->min); + dsc->stats[dsc_sum] = W * dsc->X_bar; + if (W > 2.0 && dsc->stats[dsc_variance] >= 1e-20) + { + double S = dsc->stats[dsc_stddev]; + dsc->stats[dsc_skew] = (W * dsc->M3 / ((W - 1.0) * (W - 2.0) * S * S * S)); + dsc->stats[dsc_seskew] = + sqrt (6.0 * W * (W - 1.0) / ((W - 2.0) * (W + 1.0) * (W + 3.0))); + } + else + { + dsc->stats[dsc_skew] = dsc->stats[dsc_seskew] = SYSMIS; + } + if (W > 3.0 && dsc->stats[dsc_variance] >= 1e-20) + { + double S2 = dsc->stats[dsc_variance]; + double SE_g1 = dsc->stats[dsc_seskew]; + + dsc->stats[dsc_kurt] = + (W * (W + 1.0) * dsc->M4 - 3.0 * dsc->M2 * dsc->M2 * (W - 1.0)) + / ((W - 1.0) * (W - 2.0) * (W - 3.0) * S2 * S2); + + /* Note that in _SPSS Statistical Algorithms_, the square + root symbol is missing from this formula. */ + dsc->stats[dsc_sekurt] = + sqrt ((4.0 * (W * W - 1.0) * SE_g1 * SE_g1) / ((W - 3.0) * (W + 5.0))); + } + else + { + dsc->stats[dsc_kurt] = dsc->stats[dsc_sekurt] = SYSMIS; + } + } + + display (); +} + +/* Statistical display. */ + +static int compare_func (struct variable ** a, struct variable ** b); + +static void +display (void) +{ + int i, j; + + int nc, n_stats; + struct tab_table *t; + + /* If op_excl_miss is on, d_glob_valid and (potentially) + d_glob_missing are nonzero, and d_glob_missing equals + d_glob_miss_list. + + If op_excl_miss is off, d_glob_valid is nonzero. d_glob_missing + is zero. d_glob_miss_list is (potentially) nonzero. */ + + if (sortby_stat != -2) + qsort (v_variables, n_variables, sizeof (struct variable *), + (int (*)(const void *, const void *)) compare_func); + + for (nc = i = 0; i < dsc_n_stats; i++) + if (stats & BIT_INDEX (i)) + nc++; + n_stats = nc; + if (!opt[op_no_varnames]) + nc++; + nc += opt[op_serial] ? 2 : 1; + + t = tab_create (nc, n_variables + 1, 0); + tab_headers (t, 1, 0, 1, 0); + tab_box (t, TAL_1, TAL_1, -1, -1, 0, 0, nc - 1, n_variables); + tab_box (t, -1, -1, -1, TAL_1, 1, 0, nc - 1, n_variables); + tab_hline (t, TAL_2, 0, nc - 1, 1); + tab_vline (t, TAL_2, 1, 0, n_variables); + tab_dim (t, tab_natural_dimensions); + + nc = 0; + if (!opt[op_no_varnames]) + { + tab_text (t, nc++, 0, TAB_LEFT | TAT_TITLE, _("Variable")); + } + if (opt[op_serial]) + { + tab_text (t, nc++, 0, TAB_CENTER | TAT_TITLE, _("Valid N")); + tab_text (t, nc++, 0, TAB_CENTER | TAT_TITLE, _("Missing N")); + } else { + tab_text (t, nc++, 0, TAB_CENTER | TAT_TITLE, "N"); + } + + for (i = 0; i < dsc_n_stats; i++) + if (stats & BIT_INDEX (i)) + { + const char *title = gettext (dsc_info[i].s8); + tab_text (t, nc++, 0, TAB_CENTER | TAT_TITLE, title); + } + + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + + nc = 0; + if (!opt[op_no_varnames]) + tab_text (t, nc++, i + 1, TAB_LEFT, v->name); + tab_text (t, nc++, i + 1, TAT_PRINTF, "%g", v->p.dsc.valid); + if (opt[op_serial]) + tab_text (t, nc++, i + 1, TAT_PRINTF, "%g", v->p.dsc.miss); + for (j = 0; j < dsc_n_stats; j++) + if (stats & BIT_INDEX (j)) + tab_float (t, nc++, i + 1, TAB_NONE, v->p.dsc.stats[j], 10, 3); + } + + tab_title (t, 1, _("Valid cases = %g; cases with missing value(s) = %g."), + d_glob_valid, d_glob_miss_list); + + tab_submit (t); +} + +static int +compare_func (struct variable ** a, struct variable ** b) +{ + double temp; + + if (cmd.order == DSC_D) + { + struct variable **t; + t = a; + a = b; + b = t; + } + + if (cmd.sortby == DSC_NAME) + return strcmp ((*a)->name, (*b)->name); + temp = ((*a)->p.dsc.stats[sortby_stat] + - (*b)->p.dsc.stats[sortby_stat]); + if (temp > 0) + return 1; + else if (temp < 0) + return -1; + else + return 0; +} + +/* + Local variables: + mode: c + End: +*/ diff --git a/src/dfm.c b/src/dfm.c new file mode 100644 index 00000000..9e9d080c --- /dev/null +++ b/src/dfm.c @@ -0,0 +1,718 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "file-handle.h" +#include "filename.h" +#include "getline.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* file_handle extension structure. */ +struct dfm_fhuser_ext + { + struct file_ext file; /* Associated file. */ + + char *line; /* Current line, not null-terminated. */ + size_t len; /* Length of line. */ + + char *ptr; /* Pointer into line that is returned by + dfm_get_record(). */ + size_t size; /* Number of bytes allocated for line. */ + int advance; /* Nonzero=dfm_get_record() reads a new + record; otherwise returns current record. */ + }; + +/* These are defined at the end of this file. */ +static struct fh_ext_class dfm_r_class; +static struct fh_ext_class dfm_w_class; + +static void read_record (struct file_handle *h); + +/* Internal (low level). */ + +/* Closes the file handle H which was opened by open_file_r() or + open_file_w(). */ +static void +dfm_close (struct file_handle *h) +{ + struct dfm_fhuser_ext *ext = h->ext; + + /* Skip any remaining data on the inline file. */ + if (h == inline_file) + while (ext->line != NULL) + read_record (h); + + msg (VM (2), _("%s: Closing data-file handle %s."), + fh_handle_filename (h), fh_handle_name (h)); + assert (h->class == &dfm_r_class || h->class == &dfm_w_class); + if (ext->file.file) + { + fn_close_ext (&ext->file); + free (ext->file.filename); + ext->file.filename = NULL; + } + free (ext->line); + free (ext); +} + +/* Initializes EXT properly as an inline data file. */ +static void +open_inline_file (struct dfm_fhuser_ext *ext) +{ + /* We want to indicate that the file is open, that we are not at + eof, and that another line needs to be read in. */ +#if __CHECKER__ + memset (&ext->file, 0, sizeof ext->file); +#endif + ext->file.file = NULL; + ext->line = xmalloc (128); +#if !PRODUCTION + strcpy (ext->line, _("<>")); +#endif + ext->len = strlen (ext->line); + ext->ptr = ext->line; + ext->size = 128; + ext->advance = 1; +} + +/* Opens a file handle for reading as a data file. */ +static int +open_file_r (struct file_handle *h) +{ + struct dfm_fhuser_ext ext; + + h->where.line_number = 0; + ext.file.file = NULL; + ext.line = NULL; + ext.len = 0; + ext.ptr = NULL; + ext.size = 0; + ext.advance = 0; + + msg (VM (1), _("%s: Opening data-file handle %s for reading."), + fh_handle_filename (h), fh_handle_name (h)); + + assert (h != NULL); + if (h == inline_file) + { + char *s; + + /* WTF can't this just be done with tokens? + Is this really a special case? + FIXME! */ + do + { + char *cp; + + if (!getl_read_line ()) + { + msg (SE, _("BEGIN DATA expected.")); + err_failure (); + } + + /* Skip leading whitespace, separate out first word, so that + S points to a single word reduced to lowercase. */ + s = ds_value (&getl_buf); + while (isspace ((unsigned char) *s)) + s++; + for (cp = s; isalpha ((unsigned char) *cp); cp++) + *cp = tolower ((unsigned char) (*cp)); + ds_truncate (&getl_buf, cp - s); + } + while (*s == '\0'); + + if (!lex_id_match_len ("begin", 5, s, strcspn (s, " \t\r\v\n"))) + { + msg (SE, _("BEGIN DATA expected.")); + err_cond_fail (); + lex_preprocess_line (); + return 0; + } + getl_prompt = GETL_PRPT_DATA; + + open_inline_file (&ext); + } + else + { + ext.file.filename = xstrdup (h->norm_fn); + ext.file.mode = "rb"; + ext.file.file = NULL; + ext.file.sequence_no = NULL; + ext.file.param = NULL; + ext.file.postopen = NULL; + ext.file.preclose = NULL; + if (!fn_open_ext (&ext.file)) + { + msg (ME, _("An error occurred while opening \"%s\" for reading " + "as a data file: %s."), h->fn, strerror (errno)); + err_cond_fail (); + return 0; + } + } + + h->class = &dfm_r_class; + h->ext = xmalloc (sizeof (struct dfm_fhuser_ext)); + memcpy (h->ext, &ext, sizeof (struct dfm_fhuser_ext)); + + return 1; +} + +/* Opens a file handle for writing as a data file. */ +static int +open_file_w (struct file_handle *h) +{ + struct dfm_fhuser_ext ext; + + ext.file.file = NULL; + ext.line = NULL; + ext.len = 0; + ext.ptr = NULL; + ext.size = 0; + ext.advance = 0; + + h->where.line_number = 0; + + msg (VM (1), _("%s: Opening data-file handle %s for writing."), + fh_handle_filename (h), fh_handle_name (h)); + + assert (h != NULL); + if (h == inline_file) + { + msg (ME, _("Cannot open the inline file for writing.")); + err_cond_fail (); + return 0; + } + + ext.file.filename = xstrdup (h->norm_fn); + ext.file.mode = "wb"; + ext.file.file = NULL; + ext.file.sequence_no = NULL; + ext.file.param = NULL; + ext.file.postopen = NULL; + ext.file.preclose = NULL; + + if (!fn_open_ext (&ext.file)) + { + msg (ME, _("An error occurred while opening \"%s\" for writing " + "as a data file: %s."), h->fn, strerror (errno)); + err_cond_fail (); + return 0; + } + + h->class = &dfm_w_class; + h->ext = xmalloc (sizeof (struct dfm_fhuser_ext)); + memcpy (h->ext, &ext, sizeof (struct dfm_fhuser_ext)); + + return 1; +} + +/* Ensures that the line buffer in file handle with extension EXT is + big enough to hold a line of length EXT->LEN characters not + including null terminator. */ +#define force_line_buffer_expansion() \ + do \ + { \ + if (ext->len + 1 > ext->size) \ + { \ + ext->size = ext->len * 2; \ + ext->line = xrealloc (ext->line, ext->size); \ + } \ + } \ + while (0) + +/* Counts the number of tabs in string STRING of length LEN. */ +static inline int +count_tabs (char *s, size_t len) +{ + int n_tabs = 0; + + for (;;) + { + char *cp = memchr (s, '\t', len); + if (cp == NULL) + return n_tabs; + n_tabs++; + len -= cp - s + 1; + s = cp + 1; + } +} + +/* Converts all the tabs in H->EXT->LINE to an equivalent number of + spaces, if necessary. */ +static void +tabs_to_spaces (struct file_handle *h) +{ + struct dfm_fhuser_ext *ext = h->ext; + + char *first_tab; /* Location of first tab (if any). */ + char *second_tab; /* Location of second tab (if any). */ + size_t orig_len; /* Line length at function entry. */ + + /* If there aren't any tabs then there's nothing to do. */ + first_tab = memchr (ext->line, '\t', ext->len); + if (first_tab == NULL) + return; + orig_len = ext->len; + + /* If there's just one tab then expand it inline. Otherwise do a + full string copy to another buffer. */ + second_tab = memchr (first_tab + 1, '\t', + ext->len - (first_tab - ext->line + 1)); + if (second_tab == NULL) + { + int n_spaces = 8 - (first_tab - ext->line) % 8; + + ext->len += n_spaces - 1; + + /* Expand the line if necessary, keeping the first_tab pointer + valid. */ + { + size_t ofs = first_tab - ext->line; + force_line_buffer_expansion (); + first_tab = ext->line + ofs; + } + + memmove (first_tab + n_spaces, first_tab + 1, + orig_len - (first_tab - ext->line + 1)); + memset (first_tab, ' ', n_spaces); + } else { + /* Make a local copy of original text. */ + char *orig_line = local_alloc (ext->len + 1); + memcpy (orig_line, ext->line, ext->len); + + /* Allocate memory assuming we need to add 8 spaces for every tab. */ + ext->len += 2 + count_tabs (second_tab + 1, + ext->len - (second_tab - ext->line + 1)); + + /* Expand the line if necessary, keeping the first_tab pointer + valid. */ + { + size_t ofs = first_tab - ext->line; + force_line_buffer_expansion (); + first_tab = ext->line + ofs; + } + + /* Walk through orig_line, expanding tabs into ext->line. */ + { + char *src_p = orig_line + (first_tab - ext->line); + char *dest_p = first_tab; + + for (; src_p < orig_line + orig_len; src_p++) + { + /* Most characters simply pass through untouched. */ + if (*src_p != '\t') + { + *dest_p++ = *src_p; + continue; + } + + /* Tabs are expanded into an equivalent number of + spaces. */ + { + int n_spaces = 8 - (dest_p - ext->line) % 8; + + memset (dest_p, ' ', n_spaces); + dest_p += n_spaces; + } + } + + /* Supply null terminator and actual string length. */ + *dest_p = 0; + ext->len = dest_p - ext->line; + } + + local_free (orig_line); + } +} + +/* Reads a record from H->EXT->FILE into H->EXT->LINE, setting + H->EXT->PTR to H->EXT->LINE, and setting H->EXT-LEN to the length + of the line. The line is not null-terminated. If an error occurs + or end-of-file is encountered, H->EXT->LINE is set to NULL. */ +static void +read_record (struct file_handle *h) +{ + struct dfm_fhuser_ext *ext = h->ext; + + if (h == inline_file) + { + if (!getl_read_line ()) + { + msg (SE, _("Unexpected end-of-file while reading data in BEGIN " + "DATA. This probably indicates " + "a missing or misformatted END DATA command. " + "END DATA must appear by itself on a single line " + "with exactly one space between words.")); + err_failure (); + } + + h->where.line_number++; + + if (ds_length (&getl_buf) >= 8 + && !strncasecmp (ds_value (&getl_buf), "end data", 8)) + { + lex_set_prog (ds_value (&getl_buf) + ds_length (&getl_buf)); + goto eof; + } + + ext->len = ds_length (&getl_buf); + force_line_buffer_expansion (); + strcpy (ext->line, ds_value (&getl_buf)); + } + else + { + if (h->recform == FH_RF_VARIABLE) + { + /* PORTME: here you should adapt the routine to your + system's concept of a "line" of text. */ + int read_len = getline (&ext->line, &ext->size, ext->file.file); + + if (read_len == -1) + { + if (ferror (ext->file.file)) + { + msg (ME, _("Error reading file %s: %s."), + fh_handle_name (h), strerror (errno)); + err_cond_fail (); + } + goto eof; + } + ext->len = (size_t) read_len; + } + else if (h->recform == FH_RF_FIXED) + { + size_t amt; + + if (ext->size < h->lrecl) + { + ext->size = h->lrecl; + ext->line = xmalloc (ext->size); + } + amt = fread (ext->line, 1, h->lrecl, ext->file.file); + if (h->lrecl != amt) + { + if (ferror (ext->file.file)) + msg (ME, _("Error reading file %s: %s."), + fh_handle_name (h), strerror (errno)); + else if (amt != 0) + msg (ME, _("%s: Partial record at end of file."), + fh_handle_name (h)); + else + goto eof; + + err_cond_fail (); + goto eof; + } + } + else + assert (0); + + h->where.line_number++; + } + + /* Strip trailing whitespace, I forget why. But there's a good + reason, I'm sure. I'm too scared to eliminate this code. */ + if (h->recform == FH_RF_VARIABLE) + { + while (ext->len && isspace ((unsigned char) ext->line[ext->len - 1])) + ext->len--; + + /* Convert tabs to spaces. */ + tabs_to_spaces (h); + + ext->ptr = ext->line; + } + return; + +eof: + /*hit eof or an error, clean up everything. */ + if (ext->line) + free (ext->line); + ext->size = 0; + ext->line = ext->ptr = NULL; + return; +} + +/* Public (high level). */ + +/* Returns the current record in the file corresponding to HANDLE. + Opens files and reads records, etc., as necessary. Sets *LEN to + the length of the line. The line returned is not null-terminated. + Returns NULL at end of file. Calls fail() on attempt to read past + end of file. */ +char * +dfm_get_record (struct file_handle *h, int *len) +{ + if (h->class == NULL) + { + if (!open_file_r (h)) + return NULL; + read_record (h); + } + else if (h->class != &dfm_r_class) + { + msg (ME, _("Cannot read from file %s already opened for %s."), + fh_handle_name (h), gettext (h->class->name)); + goto lossage; + } + else + { + struct dfm_fhuser_ext *ext = h->ext; + + if (ext->advance) + { + if (ext->line) + read_record (h); + else + { + msg (SE, _("Attempt to read beyond end-of-file on file %s."), + fh_handle_name (h)); + goto lossage; + } + } + } + + { + struct dfm_fhuser_ext *ext = h->ext; + + if (ext) + { + ext->advance = 0; + if (len) + *len = ext->len - (ext->ptr - ext->line); + return ext->ptr; + } + } + + return NULL; + +lossage: + /* Come here on reading beyond eof or reading from a file already + open for something else. */ + err_cond_fail (); + + return NULL; +} + +/* Causes dfm_get_record() to read in the next record the next time it + is executed on file HANDLE. */ +void +dfm_fwd_record (struct file_handle *h) +{ + struct dfm_fhuser_ext *ext = h->ext; + + assert (h->class == &dfm_r_class); + ext->advance = 1; +} + +/* Cancels the effect of any previous dfm_fwd_record() executed on + file HANDLE. Sets the current line to begin in the 1-based column + COLUMN, as with dfm_set_record but based on a column number instead + of a character pointer. */ +void +dfm_bkwd_record (struct file_handle *h, int column) +{ + struct dfm_fhuser_ext *ext = h->ext; + + assert (h->class == &dfm_r_class); + ext->advance = 0; + ext->ptr = ext->line + min ((int) ext->len + 1, column) - 1; +} + +/* Sets the current line in HANDLE to NEW_LINE, which must point + somewhere in the line last returned by dfm_get_record(). Used by + DATA LIST FREE to strip the leading portion off the current line. */ +void +dfm_set_record (struct file_handle *h, char *new_line) +{ + struct dfm_fhuser_ext *ext = h->ext; + + assert (h->class == &dfm_r_class); + ext->ptr = new_line; +} + +/* Returns the 0-based current column to which the line pointer in + HANDLE is set. Unless dfm_set_record() or dfm_bkwd_record() have + been called, this is 0. */ +int +dfm_get_cur_col (struct file_handle *h) +{ + struct dfm_fhuser_ext *ext = h->ext; + + assert (h->class == &dfm_r_class); + return ext->ptr - ext->line; +} + +/* Writes record REC having length LEN to the file corresponding to + HANDLE. REC is not null-terminated. Returns nonzero on success, + zero on failure. */ +int +dfm_put_record (struct file_handle *h, const char *rec, size_t len) +{ + char *ptr; + size_t amt; + + if (h->class == NULL) + { + if (!open_file_w (h)) + return 0; + } + else if (h->class != &dfm_w_class) + { + msg (ME, _("Cannot write to file %s already opened for %s."), + fh_handle_name (h), gettext (h->class->name)); + err_cond_fail (); + return 0; + } + + if (h->recform == FH_RF_FIXED && len < h->lrecl) + { + int ch; + + amt = h->lrecl; + ptr = local_alloc (amt); + memcpy (ptr, rec, len); + ch = h->mode == FH_MD_CHARACTER ? ' ' : 0; + memset (&ptr[len], ch, amt - len); + } + else + { + ptr = (char *) rec; + amt = len; + } + + if (1 != fwrite (ptr, amt, 1, ((struct dfm_fhuser_ext *) h->ext)->file.file)) + { + msg (ME, _("Error writing file %s: %s."), fh_handle_name (h), + strerror (errno)); + err_cond_fail (); + return 0; + } + + if (ptr != rec) + local_free (ptr); + + return 1; +} + +/* Pushes the filename and line number on the fn/ln stack. */ +void +dfm_push (struct file_handle *h) +{ + if (h != inline_file) + err_push_file_locator (&h->where); +} + +/* Pops the filename and line number from the fn/ln stack. */ +void +dfm_pop (struct file_handle *h) +{ + if (h != inline_file) + err_pop_file_locator (&h->where); +} + +/* BEGIN DATA...END DATA procedure. */ + +/* Perform BEGIN DATA...END DATA as a procedure in itself. */ +int +cmd_begin_data (void) +{ + struct dfm_fhuser_ext *ext; + + /* FIXME: figure out the *exact* conditions, not these really + lenient conditions. */ + if (vfm_source == NULL + || vfm_source == &vfm_memory_stream + || vfm_source == &vfm_disk_stream + || vfm_source == &sort_stream) + { + msg (SE, _("This command is not valid here since the current " + "input program does not access the inline file.")); + err_cond_fail (); + return CMD_FAILURE; + } + + /* Initialize inline_file. */ + msg (VM (1), _("inline file: Opening for reading.")); + inline_file->class = &dfm_r_class; + inline_file->ext = xmalloc (sizeof (struct dfm_fhuser_ext)); + open_inline_file (inline_file->ext); + + /* We don't actually read from the inline file. The input procedure + is what reads from it. */ + getl_prompt = GETL_PRPT_DATA; + procedure (NULL, NULL, NULL); + + ext = inline_file->ext; + + if (ext && ext->line) + { + msg (MW, _("Skipping remaining inline data.")); + for (read_record (inline_file); ext->line; read_record (inline_file)) + ; + } + assert (inline_file->ext == NULL); + + return CMD_SUCCESS; +} + +static struct fh_ext_class dfm_r_class = +{ + 1, + N_("reading as a data file"), + dfm_close, +}; + +static struct fh_ext_class dfm_w_class = +{ + 2, + N_("writing as a data file"), + dfm_close, +}; diff --git a/src/dfm.h b/src/dfm.h new file mode 100644 index 00000000..ef915695 --- /dev/null +++ b/src/dfm.h @@ -0,0 +1,44 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !dfm_h +#define dfm_h 1 + +/* Data file manager (dfm). + + This module is in charge of reading and writing data files (other + than system files). dfm is an fhuser, so see file-handle.h for the + fhuser interface. */ + +/* I/O utilities. */ +struct file_handle; +char *dfm_get_record (struct file_handle *handle, int *len); +int dfm_put_record (struct file_handle *handle, const char *rec, size_t len); + +/* Motion control. */ +void dfm_fwd_record (struct file_handle *handle); +void dfm_bkwd_record (struct file_handle *handle, int column); + +/* Weirdness. */ +void dfm_set_record (struct file_handle *handle, char *new_line); +int dfm_get_cur_col (struct file_handle *handle); +void dfm_push (struct file_handle *handle); +void dfm_pop (struct file_handle *handle); + +#endif /* dfm_h */ diff --git a/src/do-if.c b/src/do-if.c new file mode 100644 index 00000000..b42e0eb8 --- /dev/null +++ b/src/do-if.c @@ -0,0 +1,333 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "expr.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +#include +#endif + +/* *INDENT-OFF* */ +/* Description of DO IF transformations: + + DO IF has two transformations. One is a conditional jump around + a false condition. The second is an unconditional jump around + the rest of the code after a true condition. Both of these types + have their destinations backpatched in by the next clause (ELSE IF, + END IF). + + The characters `^V<>' are meant to represent arrows. + + 1. DO IF + V<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>V + V V + >>1. ELSE IF V + V<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>V + V V + >>1. ELSE IF V + V<<<>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>V + V V + >>*. Transformations executed when no condition is true. (ELSE) V + V + *. Transformations after DO IF structure.<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +*/ +/* *INDENT-ON* */ + +#include "do-ifP.h" + +static struct do_if_trns *parse_do_if (void); +static void add_ELSE_IF (struct do_if_trns *); +static int goto_trns_proc (struct trns_header *, struct ccase *); +static int do_if_trns_proc (struct trns_header *, struct ccase *); +static void do_if_trns_free (struct trns_header *); + +/* Parse DO IF. */ +int +cmd_do_if (void) +{ + struct do_if_trns *t; + + /* Parse the transformation. */ + t = parse_do_if (); + if (!t) + return CMD_FAILURE; + + /* Finish up the transformation, add to control stack, add to + transformation list. */ + t->brk = NULL; + t->ctl.type = CST_DO_IF; + t->ctl.down = ctl_stack; + t->ctl.trns = (struct trns_header *) t; + t->ctl.brk = NULL; + t->has_else = 0; + ctl_stack = &t->ctl; + add_transformation ((struct trns_header *) t); + + return CMD_SUCCESS; +} + +/* Parse ELSE IF. */ +int +cmd_else_if (void) +{ + /* Transformation created. */ + struct do_if_trns *t; + + /* Check that we're in a pleasing situation. */ + if (!ctl_stack || ctl_stack->type != CST_DO_IF) + { + msg (SE, _("There is no DO IF to match with this ELSE IF.")); + return CMD_FAILURE; + } + if (((struct do_if_trns *) ctl_stack->trns)->has_else) + { + msg (SE, _("The ELSE command must follow all ELSE IF commands " + "in a DO IF structure.")); + return CMD_FAILURE; + } + + /* Parse the transformation. */ + t = parse_do_if (); + if (!t) + return CMD_FAILURE; + + /* Stick in the breakout transformation. */ + t->brk = xmalloc (sizeof *t->brk); + t->brk->h.proc = goto_trns_proc; + t->brk->h.free = NULL; + + /* Add to list of transformations, add to string of ELSE IFs. */ + add_transformation ((struct trns_header *) t->brk); + add_transformation ((struct trns_header *) t); + + add_ELSE_IF (t); + + if (token != '.') + { + msg (SE, _("End of command expected.")); + return CMD_TRAILING_GARBAGE; + } + + return CMD_SUCCESS; +} + +/* Parse ELSE. */ +int +cmd_else (void) +{ + struct do_if_trns *t; + + lex_match_id ("ELSE"); + + /* Check that we're in a pleasing situation. */ + if (!ctl_stack || ctl_stack->type != CST_DO_IF) + { + msg (SE, _("There is no DO IF to match with this ELSE.")); + return CMD_FAILURE; + } + + if (((struct do_if_trns *) ctl_stack->trns)->has_else) + { + msg (SE, _("There may be at most one ELSE clause in each DO IF " + "structure. It must be the last clause.")); + return CMD_FAILURE; + } + + /* Note that the ELSE transformation is *not* added to the list of + transformations. That's because it doesn't need to do anything. + Its goto transformation *is* added, because that's necessary. + The main DO IF do_if_trns is the destructor for this ELSE + do_if_trns. */ + t = xmalloc (sizeof *t); + t->next = NULL; + t->brk = xmalloc (sizeof *t->brk); + t->brk->h.proc = goto_trns_proc; + t->brk->h.free = NULL; + t->cond = NULL; + add_transformation ((struct trns_header *) t->brk); + t->h.index = t->brk->h.index + 1; + + /* Add to string of ELSE IFs. */ + add_ELSE_IF (t); + + return lex_end_of_command (); +} + +/* Parse END IF. */ +int +cmd_end_if (void) +{ + /* List iterator. */ + struct do_if_trns *iter; + + lex_match_id ("IF"); + + /* Check that we're in a pleasing situation. */ + if (!ctl_stack || ctl_stack->type != CST_DO_IF) + { + msg (SE, _("There is no DO IF to match with this END IF.")); + return CMD_FAILURE; + } + + /* Chain down the list, backpatching destinations for gotos. */ + iter = (struct do_if_trns *) ctl_stack->trns; + for (;;) + { + if (iter->brk) + iter->brk->dest = n_trns; + iter->missing_jump = n_trns; + if (iter->next) + iter = iter->next; + else + break; + } + iter->false_jump = n_trns; + + /* Pop control stack. */ + ctl_stack = ctl_stack->down; + + return lex_end_of_command (); +} + +/* Adds an ELSE IF or ELSE to the chain of them that hangs off the + main DO IF. */ +static void +add_ELSE_IF (struct do_if_trns * t) +{ + /* List iterator. */ + struct do_if_trns *iter; + + iter = (struct do_if_trns *) ctl_stack->trns; + while (iter->next) + iter = iter->next; + assert (iter != NULL); + + iter->next = t; + iter->false_jump = t->h.index; +} + +/* Parses a DO IF or ELSE IF command and returns a pointer to a mostly + filled in transformation. */ +static struct do_if_trns * +parse_do_if (void) +{ + struct do_if_trns *t; + struct expression *e; + + lex_match_id ("IF"); + + e = expr_parse (PXP_BOOLEAN); + if (!e) + return NULL; + if (token != '.') + { + expr_free (e); + lex_error (_("expecting end of command")); + return NULL; + } + + t = xmalloc (sizeof *t); + t->h.proc = do_if_trns_proc; + t->h.free = do_if_trns_free; + t->next = NULL; + t->cond = e; + + return t; +} + +/* Executes a goto transformation. */ +static int +goto_trns_proc (struct trns_header * t, struct ccase * c unused) +{ + return ((struct goto_trns *) t)->dest; +} + +static int +do_if_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct do_if_trns *t = (struct do_if_trns *) trns; + union value bool; + + expr_evaluate (t->cond, c, &bool); + if (bool.f == 1.0) + { + debug_printf ((_("DO IF %d: true\n"), t->h.index)); + return -1; + } + else if (bool.f == 0.0) + { + debug_printf ((_("DO IF %d: false\n"), t->h.index)); + return t->false_jump; + } + else + { + debug_printf ((_("DO IF %d: missing\n"), t->h.index)); + return t->missing_jump; + } +} + +static void +do_if_trns_free (struct trns_header * trns) +{ + struct do_if_trns *t = (struct do_if_trns *) trns; + expr_free (t->cond); + + /* If brk is NULL then this is the main DO IF; therefore we + need to chain down to the ELSE and delete it. */ + if (t->brk == NULL) + { + struct do_if_trns *iter = t->next; + while (iter) + { + if (!iter->cond) + { + /* This is the ELSE. */ + free (iter); + break; + } + iter = iter->next; + } + } +} diff --git a/src/do-ifP.h b/src/do-ifP.h new file mode 100644 index 00000000..6ea1b943 --- /dev/null +++ b/src/do-ifP.h @@ -0,0 +1,83 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !do_ifP_h +#define do_ifP_h 1 + +#include "var.h" + +/* BREAK transformation. */ +struct break_trns + { + struct trns_header h; + + struct break_trns *next; /* Next in chain of BREAKs associated + with a single LOOP. */ + int loop_term; /* t_trns[] index to jump to; backpatched + in by END LOOP. */ + }; + +/* Types of control structures. */ +enum + { + CST_LOOP, + CST_DO_IF + }; + +/* Control structure info. */ +struct ctl_stmt + { + int type; /* One of CST_*. */ + struct ctl_stmt *down; /* Points toward the bottom of ctl_stack. */ + struct trns_header *trns; /* Associated transformation. */ + struct break_trns *brk; /* (LOOP only): Chain of associated BREAKs. */ + }; /* ctl_stmt */ + +/* Goto transformation. */ +struct goto_trns + { + struct trns_header h; + + int dest; /* t_trns[] index of destination of jump. */ + }; + +/* DO IF/ELSE IF/ELSE transformation. */ +struct do_if_trns + { + struct trns_header h; + + struct ctl_stmt ctl; /* DO IF: Control information for nesting. */ + + /* Keeping track of clauses. */ + struct do_if_trns *next; /* Points toward next ELSE IF. */ + struct goto_trns *brk; /* ELSE IF: jumps out of DO IF structure. */ + int has_else; /* DO IF: 1=there's been an ELSE. */ + + /* Runtime info. */ + struct expression *cond; /* Condition. */ + int false_jump; /* t_trns[] index of destination when false. */ + int missing_jump; /* t_trns[] index to break out of DO IF. */ + }; + +/* Top of the control structure stack. */ +extern struct ctl_stmt *ctl_stack; + +void discard_ctl_stack (void); + +#endif /* !do_ifP_h */ diff --git a/src/error.c b/src/error.c new file mode 100644 index 00000000..1983df4d --- /dev/null +++ b/src/error.c @@ -0,0 +1,517 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "getline.h" +#include "main.h" +#include "output.h" +#include "settings.h" +#include "str.h" +#include "var.h" + +int err_error_count; +int err_warning_count; + +int err_already_flagged; + +int err_verbosity; + +/* File locator stack. */ +static const struct file_locator **file_loc; +static int nfile_loc, mfile_loc; + +/* Fairly common public functions. */ + +/* Writes error message in CLASS, with title TITLE and text FORMAT, + formatted with printf, to the standard places. */ +void +tmsg (int class, const char *title, const char *format, ...) +{ + char buf[1024]; + + /* Format the message into BUF. */ + { + va_list args; + + va_start (args, format); + vsnprintf (buf, 1024, format, args); + va_end (args); + } + + /* Output the message. */ + { + struct error e; + + e.class = class; + err_location (&e.where); + e.title = title; + e.text = buf; + err_vmsg (&e); + } +} + +/* Writes error message in CLASS, with text FORMAT, formatted with + printf, to the standard places. */ +void +msg (int class, const char *format, ...) +{ + char buf[1024]; + + /* Format the message into BUF. */ + { + va_list args; + + va_start (args, format); + vsnprintf (buf, 1024, format, args); + va_end (args); + } + + /* Output the message. */ + { + struct error e; + + e.class = class; + err_location (&e.where); + e.title = NULL; + e.text = buf; + err_vmsg (&e); + } +} + +/* Terminate due to fatal error in input. */ +void +err_failure (void) +{ + fflush (stdout); + fflush (stderr); + + fprintf (stderr, "%s: %s\n", pgmname, + _("Terminating NOW due to a fatal error!")); + + err_hcf (0); +} + +/* Terminate unless we're interactive or will go interactive when the + file is over with. */ +void +err_cond_fail (void) +{ + if (getl_reading_script) + { + if (getl_interactive) + getl_close_all (); + else + err_failure (); + } +} + +/* File locator stack functions. */ + +/* Pushes F onto the stack of file locations. */ +void +err_push_file_locator (const struct file_locator *f) +{ + if (nfile_loc >= mfile_loc) + { + if (mfile_loc == 0) + mfile_loc = 8; + else + mfile_loc *= 2; + + file_loc = xrealloc (file_loc, mfile_loc * sizeof *file_loc); + } + + file_loc[nfile_loc++] = f; +} + +/* Pops F off the stack of file locations. + Argument F is only used for verification that that is actually the + item on top of the stack. */ +void +err_pop_file_locator (const struct file_locator *f) +{ + assert (nfile_loc >= 0 && file_loc[nfile_loc - 1] == f); + nfile_loc--; +} + +/* Puts the current file and line number in F, or NULL and -1 if + none. */ +void +err_location (struct file_locator *f) +{ + if (nfile_loc) + *f = *file_loc[nfile_loc - 1]; + else + getl_location (&f->filename, &f->line_number); +} + +/* Obscure public functions. */ + +/* Writes a blank line to the error device(s). + FIXME: currently a no-op. */ +void +err_break (void) +{ +} + +/* Checks whether we've had so many errors that it's time to quit + processing this syntax file. If so, then take appropriate + action. */ +void +err_check_count (void) +{ + int error_class = getl_interactive ? MM : FE; + + if (set_errorbreak && err_error_count) + msg (error_class, _("Terminating execution of syntax file due to error.")); + else if (err_error_count > set_mxerrs) + msg (error_class, _("Errors (%d) exceeds limit (%d)."), + err_error_count, set_mxerrs); + else if (err_error_count + err_warning_count > set_mxwarns) + msg (error_class, _("Warnings (%d) exceed limit (%d)."), + err_error_count + err_warning_count, set_mxwarns); + else + return; + + getl_close_all (); +} + +#if __CHECKER__ +static void induce_segfault (void); +#endif + +/* Some machines are broken. Compensate. */ +#ifndef EXIT_SUCCESS +#define EXIT_SUCCESS 0 +#endif + +#ifndef EXIT_FAILURE +#define EXIT_FAILURE 1 +#endif + +static int terminating; + +/* Halt-catch-fire. SUCCESS should be nonzero if exiting successfully + or zero if not. Despite the name, this is the usual way to finish, + successfully or not. */ +void +err_hcf (int success) +{ + terminating = 1; + + getl_uninitialize (); + + outp_done (); + +#if __CHECKER__ + if (!success) + induce_segfault (); +#endif + + exit (success ? EXIT_SUCCESS : EXIT_FAILURE); +} + +static void puts_stdout (const char *s); +static void dump_message (char *errbuf, unsigned indent, + void (*func) (const char *), unsigned width); + +void +err_vmsg (const struct error *e) +{ + /* Class flags. */ + enum + { + ERR_IN_PROCEDURE = 01, /* 1=Display name of current procedure. */ + ERR_WITH_FILE = 02, /* 1=Display filename and line number. */ + }; + + /* Describes one class of error. */ + struct error_class + { + int flags; /* Zero or more of MSG_*. */ + int *count; /* Counting category. */ + const char *banner; /* Banner. */ + }; + + static const struct error_class error_classes[ERR_CLASS_COUNT] = + { + {0, NULL, N_("fatal")}, /* FE */ + + {3, &err_error_count, N_("error")}, /* SE */ + {3, &err_warning_count, N_("warning")}, /* SW */ + {3, NULL, N_("note")}, /* SM */ + + {0, NULL, N_("installation error")}, /* IE */ + {2, NULL, N_("installation error")}, /* IS */ + + {2, NULL, N_("error")}, /* DE */ + {2, NULL, N_("warning")}, /* DW */ + + {0, NULL, N_("error")}, /* ME */ + {0, NULL, N_("warning")}, /* MW */ + {0, NULL, N_("note")}, /* MM */ + }; + + struct string msg; + int class; + + /* Check verbosity level. */ + class = e->class; + if (((class >> ERR_VERBOSITY_SHIFT) & ERR_VERBOSITY_MASK) > err_verbosity) + return; + class &= ERR_CLASS_MASK; + + assert (class >= 0 && class < ERR_CLASS_COUNT); + assert (e->text != NULL); + + ds_init (NULL, &msg, 64); + if (e->where.filename && (error_classes[class].flags & ERR_WITH_FILE)) + { + ds_printf (&msg, "%s:", e->where.filename); + if (e->where.line_number != -1) + ds_printf (&msg, "%d:", e->where.line_number); + ds_putchar (&msg, ' '); + } + + ds_printf (&msg, "%s: ", gettext (error_classes[class].banner)); + + { + int *count = error_classes[class].count; + if (count) + (*count)++; + } + + if (cur_proc && (error_classes[class].flags & ERR_IN_PROCEDURE)) + ds_printf (&msg, "%s: ", cur_proc); + + if (e->title) + ds_concat (&msg, e->title); + + ds_concat (&msg, e->text); + + /* FIXME: Check set_messages and set_errors to determine where to + send errors and messages. + + Please note that this is not trivial. We have to avoid an + infinite loop in reporting errors that originate in the output + section. */ + dump_message (ds_value (&msg), 8, puts_stdout, set_viewwidth); + + ds_destroy (&msg); + + if (e->class == FE && !terminating) + err_hcf (0); +} + +/* Private functions. */ + +#if 0 +/* Write S followed by a newline to stderr. */ +static void +puts_stderr (const char *s) +{ + fputs (s, stderr); + fputc ('\n', stderr); +} +#endif + +/* Write S followed by a newline to stdout. */ +static void +puts_stdout (const char *s) +{ + puts (s); +} + +/* Returns 1 if C is a `break character', that is, if it is a good + place to break a message into lines. */ +static inline int +char_is_break (int quote, int c) +{ + return ((quote && c == DIR_SEPARATOR) + || (!quote && (isspace (c) || c == '-' || c == '/'))); +} + +/* Returns 1 if C is a break character where the break should be made + BEFORE the character. */ +static inline int +break_before (int quote, int c) +{ + return !quote && isspace (c); +} + +/* If C is a break character, returns 1 if the break should be made + AFTER the character. Does not return a meaningful result if C is + not a break character. */ +static inline int +break_after (int quote, int c) +{ + return !break_before (quote, c); +} + +/* If you want very long words that occur at a bad break point to be + broken into two lines even if they're shorter than a whole line by + themselves, define as 2/3, or 4/5, or whatever fraction of a whole + line you think is necessary in order to consider a word long enough + to break into pieces. Otherwise, define as 0. See code to grok + the details. Do NOT parenthesize the expression! */ +#define BREAK_LONG_WORD 0 +/* #define BREAK_LONG_WORD 2/3 */ +/* #define BREAK_LONG_WORD 4/5 */ + +/* Divides MSG into lines of WIDTH width for the first line and WIDTH + - INDENT width for each succeeding line. Each line is dumped + through FUNC, which may do with the string what it will. */ +static void +dump_message (char *msg, unsigned indent, void (*func) (const char *), + unsigned width) +{ + char *cp; + + /* 1 when at a position inside double quotes ("). */ + int quote = 0; + + /* Buffer for a single line. */ + char *buf; + + /* If the message is short, just print the full thing. */ + if (strlen (msg) < width) + { + func (msg); + return; + } + + /* Make sure the indent isn't too big relative to the page width. */ + if (indent > width / 3) + indent = width / 3; + + buf = local_alloc (width + 1); + + /* Advance WIDTH characters into MSG. + If that's a valid breakpoint, keep it; otherwise, back up. + Output the line. */ + for (cp = msg; (unsigned) (cp - msg) < width - 1; cp++) + if (*cp == '"') + quote ^= 1; + + if (break_after (quote, (unsigned char) *cp)) + { + for (cp--; !char_is_break (quote, (unsigned char) *cp) && cp > msg; cp--) + if (*cp == '"') + quote ^= 1; + + if (break_after (quote, (unsigned char) *cp)) + cp++; + } + + if (cp <= msg + width * BREAK_LONG_WORD) + for (; cp < msg + width - 1; cp++) + if (*cp == '"') + quote ^= 1; + + { + int c = *cp; + *cp = '\0'; + func (msg); + *cp = c; + } + + /* Repeat above procedure for remaining lines. */ + for (;;) + { + char *cp2; + + /* Advance past whitespace. */ + while (isspace ((unsigned char) *cp)) + cp++; + if (*cp == 0) + break; + + /* Advance WIDTH - INDENT characters. */ + for (cp2 = cp; (unsigned) (cp2 - cp) < width - indent && *cp2; cp2++) + if (*cp2 == '"') + quote ^= 1; + + /* Back up if this isn't a breakpoint. */ + { + unsigned w = cp2 - cp; + if (*cp2) + for (cp2--; !char_is_break (quote, (unsigned char) *cp2) && cp2 > cp; + cp2--) + if (*cp2 == '"') + quote ^= 1; + + if (w == width - indent + && (unsigned) (cp2 - cp) <= (width - indent) * BREAK_LONG_WORD) + for (; (unsigned) (cp2 - cp) < width - indent && *cp2; cp2++) + if (*cp2 == '"') + quote ^= 1; + } + + /* Write out the line. */ + memset (buf, ' ', indent); + memcpy (&buf[indent], cp, cp2 - cp); + buf[indent + cp2 - cp] = '\0'; + func (buf); + + cp = cp2; + } + + local_free (buf); +} + +#if __CHECKER__ +/* Causes a segfault in order to force Checker to print a stack + backtrace. */ +static void +induce_segfault (void) +{ + fputs (_("\n" + "\t*********************\n" + "\t* INDUCING SEGFAULT *\n" + "\t*********************\n"), stdout); + fflush (stdout); + fflush (stderr); + abort (); +} +#endif diff --git a/src/error.h b/src/error.h new file mode 100644 index 00000000..6eb77a14 --- /dev/null +++ b/src/error.h @@ -0,0 +1,90 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !error_h +#define error_h 1 + +#include + +/* Message classes. */ +enum + { + FE, /* Fatal errors. */ + SE, SW, SM, /* Script error/warning/message. */ + IE, IS, /* Installation error/script error. */ + DE, DW, /* Data-file error/warning. */ + ME, MW, MM, /* General error/warning/message. */ + ERR_CLASS_COUNT, /* Number of message classes. */ + ERR_CLASS_MASK = 0xf, /* Bitmask for class. */ + ERR_VERBOSITY_SHIFT = 4, /* Shift count for verbosity. */ + ERR_VERBOSITY_MASK = 0xf, /* Bitmask for verbosity. */ + }; + +/* If passed to msg() as CLASS, the return value will cause the message + to be displayed only if `verbosity' is at least LEVEL. */ +#define VM(LEVEL) (MM | ((LEVEL) << ERR_VERBOSITY_SHIFT)) + +/* A file location. */ +struct file_locator + { + const char *filename; /* Filename. */ + int line_number; /* Line number. */ + }; + +/* An error message. */ +struct error + { + int class; /* One of the classes above. */ + struct file_locator where; /* File location, or (NULL, -1). */ + const char *title; /* Special text inserted if not null. */ + const char *text; /* Error text. */ + }; + +/* Number of errors, warnings reported. */ +extern int err_error_count; +extern int err_warning_count; + +/* If number of allowable errors/warnings is exceeded, then a message + is displayed and this flag is set to suppress subsequent + messages. */ +extern int err_already_flagged; + +/* Nonnegative verbosity level. Higher value == more verbose. */ +extern int err_verbosity; + +/* Functions. */ +void msg (int class, const char *format, ...) + __attribute__ ((format (printf, 2, 3))); +void tmsg (int class, const char *title, const char *format, ...) + __attribute__ ((format (printf, 3, 4))); +void err_failure (void); +void err_cond_fail (void); + +/* File-locator stack. */ +void err_push_file_locator (const struct file_locator *); +void err_pop_file_locator (const struct file_locator *); +void err_location (struct file_locator *); + +/* Obscure functions. */ +void err_break (void); +void err_check_count (void); +void err_hcf (int exit_code) __attribute__ ((noreturn)); +void err_vmsg (const struct error *); + +#endif /* error.h */ diff --git a/src/expr-evl.c b/src/expr-evl.c new file mode 100644 index 00000000..15b4434c --- /dev/null +++ b/src/expr-evl.c @@ -0,0 +1,1395 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#if TIME_WITH_SYS_TIME +#include +#include +#else +#if HAVE_SYS_TIME_H +#include +#else +#include +#endif +#endif + +#include +#include +#include +#include +#include +#include "approx.h" +#include "data-in.h" +#include "error.h" +#include "expr.h" +#include "exprP.h" +#include "julcal/julcal.h" +#include "magic.h" +#include "random.h" +#include "stats.h" +#include "str.h" +#include "var.h" +#include "vector.h" +#include "vfm.h" +#include "vfmP.h" + +/* FIXME: This could be even more efficient if we caught SYSMIS when + it first reared its ugly head, then threw it into an entirely new + switch that handled SYSMIS aggressively like all the code does now. + But I've spent a couple of weeks on the expression code, and that's + enough to make anyone sick. For that matter, it could be more + efficient if I hand-coded it in assembly for a dozen processors, + but I'm not going to do that either. */ + +/* These macros are defined differently depending on the way that + the stack is managed. (i.e., I have to adapt the code to inferior + environments.) + + void CHECK_STRING_SPACE(int x): Assure that at least X+1 bytes of + space are available in the string evaluation stack. + + unsigned char *ALLOC_STRING_SPACE(int x): Return a pointer to X+1 + bytes of space. CHECK_STRING_SPACE must have previously been + called with an argument of at least X. */ + +#if PAGED_STACK +#define CHECK_STRING_SPACE(X) /* nothing to do! */ +#define ALLOC_STRING_SPACE(X) \ + alloca((X) + 1) +#else /* !PAGED_STACK */ +#define CHECK_STRING_SPACE(X) \ + do \ + { \ + if (str_stk + X >= str_end) \ + { \ + e->str_size += 1024; \ + e->str_stk = xrealloc (e->str_stk, e->str_size); \ + str_end = e->str_stk + e->str_size - 1; \ + } \ + } \ + while (0) + +#define ALLOC_STRING_SPACE(X) \ + (str_stk += X + 1, str_stk - X - 1) +#endif /* !PAGED_STACK */ + +double +expr_evaluate (struct expression *e, struct ccase *c, union value *v) +{ + unsigned char *op = e->op; + double *dbl = e->num; + unsigned char *str = e->str; +#if !PAGED_STACK + unsigned char *str_stk = e->str_stk; + unsigned char *str_end = e->str_stk + e->str_size - 1; +#endif + struct variable **vars = e->var; + int i, j; + + /* Stack pointer. */ + union value *sp = e->stack; + + for (;;) + { + switch (*op++) + { + case OP_PLUS: + sp -= *op - 1; + if (sp->f != SYSMIS) + for (i = 1; i < *op; i++) + { + if (sp[i].f == SYSMIS) + { + sp->f = SYSMIS; + break; + } + else + sp->f += sp[i].f; + } + op++; + break; + case OP_MUL: + sp -= *op - 1; + if (sp->f != SYSMIS) + for (i = 1; i < *op; i++) + { + if (sp[i].f == SYSMIS) + { + sp->f = SYSMIS; + break; + } + else + sp->f *= sp[i].f; + } + op++; + break; + case OP_POW: + sp--; + if (sp[0].f == SYSMIS) + { + if (approx_eq (sp[1].f, 0.0)) + sp->f = 1.0; + } + else if (sp[1].f == SYSMIS) + { + if (sp[0].f == 0.0) + /* SYSMIS**0 */ + sp->f = 0.0; + else + sp->f = SYSMIS; + } + else if (approx_eq (sp[0].f, 0.0) && approx_eq (sp[1].f, 0.0)) + sp->f = SYSMIS; + else + sp->f = pow (sp[0].f, sp[1].f); + break; + + case OP_AND: + /* Note that the equality operator (==) may be used here + (instead of approx_eq) because booleans are always + *exactly* 0, 1, or SYSMIS. + + Truth table (in order of detection): + + 1: + 0 and 0 = 0 + 0 and 1 = 0 + 0 and SYSMIS = 0 + + 2: + 1 and 0 = 0 + SYSMIS and 0 = 0 + + 3: + 1 and SYSMIS = SYSMIS + SYSMIS and SYSMIS = SYSMIS + + 4: + 1 and 1 = 1 + SYSMIS and 1 = SYSMIS + + */ + sp--; + if (sp[0].f == 0.0); /* 1 */ + else if (sp[1].f == 0.0) + sp->f = 0.0; /* 2 */ + else if (sp[1].f == SYSMIS) + sp->f = SYSMIS; /* 3 */ + break; + case OP_OR: + /* Truth table (in order of detection): + + 1: + 1 or 1 = 1 + 1 or 0 = 1 + 1 or SYSMIS = 1 + + 2: + 0 or 1 = 1 + SYSMIS or 1 = 1 + + 3: + 0 or SYSMIS = SYSMIS + SYSMIS or SYSMIS = SYSMIS + + 4: + 0 or 0 = 0 + SYSMIS or 0 = SYSMIS + + */ + sp--; + if (sp[0].f == 1.0); /* 1 */ + else if (sp[1].f == 1.0) + sp->f = 1.0; /* 2 */ + else if (sp[1].f == SYSMIS) + sp->f = SYSMIS; /* 3 */ + break; + case OP_NOT: + if (sp[0].f == 0.0) + sp->f = 1.0; + else if (sp[0].f == 1.0) + sp->f = 0.0; + break; + + case OP_EQ: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_eq (sp[0].f, sp[1].f); + } + break; + case OP_GE: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_ge (sp[0].f, sp[1].f); + } + break; + case OP_GT: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_gt (sp[0].f, sp[1].f); + } + break; + case OP_LE: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_le (sp[0].f, sp[1].f); + } + break; + case OP_LT: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_lt (sp[0].f, sp[1].f); + } + break; + case OP_NE: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = approx_ne (sp[0].f, sp[1].f); + } + break; + + /* String operators. */ + case OP_STRING_EQ: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) == 0; + break; + case OP_STRING_GE: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) >= 0; + break; + case OP_STRING_GT: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) > 0; + break; + case OP_STRING_LE: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) <= 0; + break; + case OP_STRING_LT: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) < 0; + break; + case OP_STRING_NE: + sp--; + sp[0].f = st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[1].c[1], sp[1].c[0]) != 0; + break; + + /* Unary functions. */ + case OP_NEG: + if (sp->f != SYSMIS) + sp->f = -sp->f; + break; + case OP_ABS: + if (sp->f != SYSMIS) + sp->f = fabs (sp->f); + break; + case OP_ARCOS: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = acos (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_ARSIN: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = asin (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_ARTAN: + if (sp->f != SYSMIS) + sp->f = atan (sp->f); + break; + case OP_COS: + if (sp->f != SYSMIS) + sp->f = cos (sp->f); + break; + case OP_EXP: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = exp (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_LG10: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = log10 (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_LN: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = log10 (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_MOD10: + if (sp->f != SYSMIS) + sp->f = fmod (sp->f, 10); + break; + case OP_RND: + if (sp->f != SYSMIS) + { + if (sp->f >= 0.0) + sp->f = floor (sp->f + 0.5); + else + sp->f = -floor (-sp->f + 0.5); + } + break; + case OP_SIN: + if (sp->f != SYSMIS) + sp->f = sin (sp->f); + break; + case OP_SQRT: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = sqrt (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_TAN: + if (sp->f != SYSMIS) + { + errno = 0; + sp->f = tan (sp->f); + if (errno) + sp->f = SYSMIS; + } + break; + case OP_TRUNC: + if (sp->f != SYSMIS) + { + if (sp->f >= 0.0) + sp->f = floor (sp->f); + else + sp->f = -floor (-sp->f); + } + break; + + /* N-ary numeric functions. */ + case OP_ANY: + { + int n_args = *op++; + int sysmis = 1; + + sp -= n_args - 1; + if (sp->f == SYSMIS) + break; + for (i = 1; i <= n_args; i++) + if (approx_eq (sp[0].f, sp[i].f)) + { + sp->f = 1.0; + goto main_loop; + } + else if (sp[i].f != SYSMIS) + sysmis = 0; + sp->f = sysmis ? SYSMIS : 0.0; + } + break; + case OP_ANY_STRING: + { + int n_args = *op++; + + sp -= n_args - 1; + for (i = 1; i <= n_args; i++) + if (!st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[i].c[1], sp[i].c[0])) + { + sp->f = 1.0; + goto main_loop; + } + sp->f = 0.0; + } + break; + case OP_CFVAR: + { + int n_args = *op++; + int nv = 0; + double sum[2] = + {0.0, 0.0}; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + sum[0] += sp[i].f; + sum[1] += sp[i].f * sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = calc_cfvar (sum, nv); + } + break; + case OP_MAX: + { + int n_args = *op++; + int nv = 0; + double max = -DBL_MAX; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + if (sp[i].f > max) + max = sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = max; + } + break; + case OP_MEAN: + { + int n_args = *op++; + int nv = 0; + double sum[1] = + {0.0}; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + sum[0] += sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = calc_mean (sum, nv); + } + break; + case OP_MIN: + { + int n_args = *op++; + int nv = 0; + double min = DBL_MAX; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + if (sp[i].f < min) + min = sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = min; + } + break; + case OP_NMISS: + { + int n_args = *op++; + int n_missing = 0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f == SYSMIS) + n_missing++; + sp->f = n_missing; + } + break; + case OP_NVALID: + { + int n_args = *op++; + int n_valid = 0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + n_valid++; + sp->f = n_valid; + } + break; + case OP_RANGE: + { + int n_args = *op++; + int sysmis = 1; + + sp -= n_args - 1; + if (sp->f == SYSMIS) + break; + for (i = 1; i <= n_args; i += 2) + if (sp[i].f == SYSMIS || sp[i + 1].f == SYSMIS) + continue; + else if (approx_ge (sp[0].f, sp[i].f) + && approx_le (sp[0].f, sp[i + 1].f)) + { + sp->f = 1.0; + goto main_loop; + } + else + sysmis = 0; + sp->f = sysmis ? SYSMIS : 0.0; + } + break; + case OP_RANGE_STRING: + { + int n_args = *op++; + + sp -= n_args - 1; + for (i = 1; i <= n_args; i += 2) + if (st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[i].c[1], sp[i].c[0]) >= 0 + && st_compare_pad (&sp[0].c[1], sp[0].c[0], + &sp[i + 1].c[1], sp[i + 1].c[0]) <= 0) + { + sp->f = 1.0; + goto main_loop; + } + sp->f = 0.0; + } + break; + case OP_SD: + { + int n_args = *op++; + int nv = 0; + double sum[2]; + + sum[0] = sum[1] = 0.0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + sum[0] += sp[i].f; + sum[1] += sp[i].f * sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = calc_stddev (calc_variance (sum, nv)); + } + break; + case OP_SUM: + { + int n_args = *op++; + int nv = 0; + double sum = 0.0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + sum += sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = sum; + } + break; + case OP_VARIANCE: + { + int n_args = *op++; + int nv = 0; + double sum[2]; + + sum[0] = sum[1] = 0.0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].f != SYSMIS) + { + nv++; + sum[0] += sp[i].f; + sum[1] += sp[i].f * sp[i].f; + } + if (nv < *op++) + sp->f = SYSMIS; + else + sp->f = calc_variance (sum, nv); + } + break; + + /* Time construction function. */ + case OP_TIME_HMS: + sp -= 2; + if (sp[0].f == SYSMIS || sp[1].f == SYSMIS || sp[2].f == SYSMIS) + sp->f = SYSMIS; + else + sp->f = 60. * (60. * sp[0].f + sp[1].f) + sp[2].f; + break; + + /* Date construction functions. */ + case OP_DATE_DMY: + sp -= 2; + sp->f = yrmoda (sp[2].f, sp[1].f, sp[0].f); + if (sp->f != SYSMIS) + sp->f *= 60. * 60. * 24.; + break; + case OP_DATE_MDY: + sp -= 2; + sp->f = yrmoda (sp[2].f, sp[0].f, sp[1].f); + if (sp->f != SYSMIS) + sp->f *= 60. * 60. * 24.; + break; + case OP_DATE_MOYR: + (--sp)->f = yrmoda (sp[1].f, sp[0].f, 1); + if (sp->f != SYSMIS) + sp->f *= 60. * 60. * 24.; + break; + case OP_DATE_QYR: + sp--; + if (sp[0].f == SYSMIS) + sp->f = SYSMIS; + else + { + sp->f = yrmoda (sp[1].f, sp[0].f * 3 - 2, 1); + if (sp->f != SYSMIS) + sp->f *= 60. * 60. * 24.; + } + break; + case OP_DATE_WKYR: + sp--; + if (sp[0].f == SYSMIS) + sp->f = SYSMIS; + else + { + sp[1].f = yrmoda (sp[1].f, 1, 1); + if (sp->f != SYSMIS) + sp[1].f = 60. * 60. * 24. * (sp[1].f + 7. * (floor (sp[0].f) - 1.)); + sp->f = sp[1].f; + } + break; + case OP_DATE_YRDAY: + sp--; + if (sp[1].f == SYSMIS) + sp->f = SYSMIS; + else + { + sp->f = yrmoda (sp[0].f, 1, 1); + if (sp->f != SYSMIS) + sp->f = 60. * 60. * 24. * (sp->f + floor (sp[1].f) - 1); + } + break; + case OP_YRMODA: + sp -= 2; + sp->f = yrmoda (sp[0].f, sp[1].f, sp[2].f); + break; + + /* Date extraction functions. */ + case OP_XDATE_DATE: + if (sp->f != SYSMIS) + sp->f = floor (sp->f / 60. / 60. / 24.) * 60. * 60. * 24.; + break; + case OP_XDATE_HOUR: + if (sp->f != SYSMIS) + sp->f = fmod (floor (sp->f / 60. / 60.), 24.); + break; + case OP_XDATE_JDAY: + if (sp->f != SYSMIS) + sp->f = 86400. * julian_to_jday (sp->f / 86400.); + break; + case OP_XDATE_MDAY: + if (sp->f != SYSMIS) + { + int day; + julian_to_calendar (sp->f / 86400., NULL, NULL, &day); + sp->f = day; + } + break; + case OP_XDATE_MINUTE: + if (sp->f != SYSMIS) + sp->f = fmod (floor (sp->f / 60.), 60.); + break; + case OP_XDATE_MONTH: + if (sp->f != SYSMIS) + { + int month; + julian_to_calendar (sp->f / 86400., NULL, &month, NULL); + sp->f = month; + } + break; + case OP_XDATE_QUARTER: + if (sp->f != SYSMIS) + { + int month; + julian_to_calendar (sp->f / 86400., NULL, &month, NULL); + sp->f = (month - 1) / 3 + 1; + } + break; + case OP_XDATE_SECOND: + if (sp->f != SYSMIS) + sp->f = fmod (sp->f, 60.); + break; + case OP_XDATE_TDAY: + if (sp->f != SYSMIS) + sp->f = floor (sp->f / 60. / 60. / 24.); + break; + case OP_XDATE_TIME: + if (sp->f != SYSMIS) + sp->f -= floor (sp->f / 60. / 60. / 24.) * 60. * 60. * 24.; + break; + case OP_XDATE_WEEK: + if (sp->f != SYSMIS) + sp->f = (julian_to_jday (sp->f / 86400.) - 1) / 7 + 1; + break; + case OP_XDATE_WKDAY: + if (sp->f != SYSMIS) + sp->f = julian_to_wday (sp->f / 86400.); + break; + case OP_XDATE_YEAR: + if (sp->f != SYSMIS) + { + int year; + julian_to_calendar (sp->f / 86400., &year, NULL, NULL); + sp->f = year; + } + break; + + /* String functions. */ + case OP_CONCAT: + { + int n_args = *op++; + unsigned char *dest; + + CHECK_STRING_SPACE (255); + dest = ALLOC_STRING_SPACE (255); + dest[0] = 0; + + sp -= n_args - 1; + for (i = 0; i < n_args; i++) + if (sp[i].c[0] != 0) + { + if (sp[i].c[0] + dest[0] < 255) + { + memcpy (&dest[dest[0] + 1], &sp[i].c[1], sp[i].c[0]); + dest[0] += sp[i].c[0]; + } + else + { + memcpy (&dest[dest[0] + 1], &sp[i].c[1], 255 - dest[0]); + dest[0] = 255; + break; + } + } + sp[0].c = dest; + } + break; + case OP_INDEX: + sp--; + if (sp[1].c[0] == 0) + sp->f = SYSMIS; + else + { + int last = sp[0].c[0] - sp[1].c[0]; + for (i = 0; i <= last; i++) + if (!memcmp (&sp[0].c[i + 1], &sp[0].c[1], sp[0].c[0])) + { + sp->f = i + 1; + goto main_loop; + } + sp->f = 0.0; + } + break; + case OP_INDEX_OPT: + { + /* Length of each search string. */ + int part_len = sp[2].f; + + sp -= 2; + if (sp[1].c[0] == 0 || part_len <= 0 || sp[2].f == SYSMIS + || sp[1].c[0] % part_len != 0) + sp->f = SYSMIS; + else + { + /* Last possible index. */ + int last = sp[0].c[0] - part_len; + + for (i = 0; i <= last; i++) + for (j = 0; j < sp[1].c[0]; j += part_len) + if (!memcmp (&sp[0].c[i], &sp[1].c[j], part_len)) + { + sp->f = i + 1; + goto main_loop; + } + sp->f = 0.0; + } + } + break; + case OP_RINDEX: + sp--; + if (sp[1].c[0] == 0) + sp->f = SYSMIS; + else + { + for (i = sp[0].c[0] - sp[1].c[0]; i >= 0; i--) + if (!memcmp (&sp[0].c[i + 1], &sp[0].c[1], sp[0].c[0])) + { + sp->f = i + 1; + goto main_loop; + } + sp->f = 0.0; + } + break; + case OP_RINDEX_OPT: + { + /* Length of each search string. */ + int part_len = sp[2].f; + + sp -= 2; + if (sp[1].c[0] == 0 || part_len <= 0 || sp[2].f == SYSMIS + || sp[1].c[0] % part_len != 0) + sp->f = SYSMIS; + else + { + for (i = sp[0].c[0] - part_len; i >= 0; i--) + for (j = 0; j < sp[1].c[0]; j += part_len) + if (!memcmp (&sp[0].c[i], &sp[1].c[j], part_len)) + { + sp->f = i + 1; + goto main_loop; + } + sp->f = 0.0; + } + } + break; + case OP_LENGTH: + sp->f = sp[0].c[0]; + break; + case OP_LOWER: + for (i = sp[0].c[0]; i >= 1; i--) + sp[0].c[i] = tolower ((unsigned char) (sp[0].c[i])); + break; + case OP_UPPER: + for (i = sp[0].c[0]; i >= 1; i--) + sp[0].c[i] = toupper ((unsigned char) (sp[0].c[i])); + break; + case OP_LPAD: + { + int len; + sp--; + len = sp[1].f; + if (sp[1].f == SYSMIS || len < 0 || len > 255) + sp->c[0] = 0; + else if (len > sp[0].c[0]) + { + unsigned char *dest; + + CHECK_STRING_SPACE (len); + dest = ALLOC_STRING_SPACE (len); + dest[0] = len; + memset (&dest[1], ' ', len - sp->c[0]); + memcpy (&dest[len - sp->c[0] + 1], &sp->c[1], sp->c[0]); + sp->c = dest; + } + } + break; + case OP_LPAD_OPT: + { + int len; + sp -= 2; + len = sp[1].f; + if (sp[1].f == SYSMIS || len < 0 || len > 255 || sp[2].c[0] != 1) + sp->c[0] = 0; + else if (len > sp[0].c[0]) + { + unsigned char *dest; + + CHECK_STRING_SPACE (len); + dest = ALLOC_STRING_SPACE (len); + dest[0] = len; + memset (&dest[1], sp[2].c[1], len - sp->c[0]); + memcpy (&dest[len - sp->c[0] + 1], &sp->c[1], sp->c[0]); + sp->c = dest; + } + } + break; + case OP_RPAD: + { + int len; + sp--; + len = sp[1].f; + if (sp[1].f == SYSMIS || len < 0 || len > 255) + sp->c[0] = 0; + else if (len > sp[0].c[0]) + { + unsigned char *dest; + + CHECK_STRING_SPACE (len); + dest = ALLOC_STRING_SPACE (len); + dest[0] = len; + memcpy (&dest[1], &sp->c[1], sp->c[0]); + memset (&dest[sp->c[0] + 1], ' ', len - sp->c[0]); + sp->c = dest; + } + } + break; + case OP_RPAD_OPT: + { + int len; + sp -= 2; + len = sp[1].f; + if (len < 0 || len > 255 || sp[2].c[0] != 1) + sp->c[0] = 0; + else if (len > sp[0].c[0]) + { + unsigned char *dest; + + CHECK_STRING_SPACE (len); + dest = ALLOC_STRING_SPACE (len); + dest[0] = len; + memcpy (&dest[1], &sp->c[1], sp->c[0]); + memset (&dest[sp->c[0] + 1], sp[2].c[1], len - sp->c[0]); + sp->c = dest; + } + } + break; + case OP_LTRIM: + { + int len = sp[0].c[0]; + + i = 1; + while (i <= len && sp[0].c[i] == ' ') + i++; + if (--i) + { + sp[0].c[i] = sp[0].c[0] - i; + sp->c = &sp[0].c[i]; + } + } + break; + case OP_LTRIM_OPT: + { + sp--; + if (sp[1].c[0] != 1) + sp[0].c[0] = 0; + else + { + int len = sp[0].c[0]; + int cmp = sp[1].c[1]; + + i = 1; + while (i <= len && sp[0].c[i] == cmp) + i++; + if (--i) + { + sp[0].c[i] = sp[0].c[0] - i; + sp->c = &sp[0].c[i]; + } + } + } + break; + case OP_RTRIM: + assert (' ' != 0); + while (sp[0].c[sp[0].c[0]] == ' ') + sp[0].c[0]--; + break; + case OP_RTRIM_OPT: + sp--; + if (sp[1].c[0] != 1) + sp[0].c[0] = 0; + else + { + /* Note that NULs are not allowed in strings. This code + needs to change if this decision is changed. */ + int cmp = sp[1].c[1]; + while (sp[0].c[sp[0].c[0]] == cmp) + sp[0].c[0]--; + } + break; + case OP_NUMBER: + { + struct data_in di; + + di.s = &sp->c[1]; + di.e = &sp->c[1] + sp->c[0]; + di.v = sp; + di.flags = DI_IGNORE_ERROR; + di.f1 = 1; + di.format.type = FMT_F; + di.format.w = sp->c[0]; + di.format.d = 0; + data_in (&di); + } + break; + case OP_NUMBER_OPT: + { + struct data_in di; + di.s = &sp->c[1]; + di.e = &sp->c[1] + sp->c[0]; + di.v = sp; + di.flags = DI_IGNORE_ERROR; + di.f1 = 1; + di.format.type = *op++; + di.format.w = *op++; + di.format.d = *op++; + data_in (&di); + } + break; + case OP_STRING: + { + struct fmt_spec f; + unsigned char *dest; + + f.type = *op++; + f.w = *op++; + f.d = *op++; + + CHECK_STRING_SPACE (f.w); + dest = ALLOC_STRING_SPACE (f.w); + dest[0] = f.w; + + data_out (&dest[1], &f, sp); + sp->c = dest; + } + break; + case OP_SUBSTR: + { + int index; + + sp--; + index = sp[1].f; + if (index < 1 || index > sp[0].c[0]) + sp->c[0] = 0; + else if (index > 1) + { + index--; + sp->c[index] = sp->c[0] - index; + sp->c += index; + } + } + break; + case OP_SUBSTR_OPT: + { + int index; + int n; + + sp -= 2; + index = sp[1].f; + n = sp[2].f; + if (sp[1].f == SYSMIS || sp[2].f == SYSMIS || index < 1 + || index > sp[0].c[0] || n < 1) + sp->c[0] = 0; + else + { + if (index > 1) + { + index--; + sp->c[index] = sp->c[0] - index; + sp->c += index; + } + if (sp->c[0] > n) + sp->c[0] = n; + } + } + break; + + /* Artificial. */ + case OP_INV: + if (sp->f != SYSMIS) + sp->f = 1. / sp->f; + break; + case OP_SQUARE: + if (sp->f != SYSMIS) + sp->f *= sp->f; + break; + case OP_NUM_TO_BOOL: + if (approx_eq (sp->f, 0.0)) + sp->f = 0.0; + else if (approx_eq (sp->f, 1.0)) + sp->f = 1.0; + else if (sp->f != SYSMIS) + { + msg (SE, _("A number being treated as a Boolean in an " + "expression was found to have a value other than " + "0 (false), 1 (true), or the system-missing value. " + "The result was forced to 0.")); + sp->f = 0.0; + } + break; + + /* Weirdness. */ + case OP_MOD: + sp--; + if (sp[0].f != SYSMIS) + { + if (sp[1].f == SYSMIS) + { + if (approx_ne (sp[0].f, 0.0)) + sp->f = SYSMIS; + } + else + sp->f = fmod (sp[0].f, sp[1].f); + } + break; + case OP_NORMAL: + if (sp->f != SYSMIS) + sp->f = rand_normal (sp->f); + break; + case OP_UNIFORM: + if (sp->f != SYSMIS) + sp->f = rand_uniform (sp->f); + break; + case OP_SYSMIS: + if (sp[0].f == SYSMIS || !finite (sp[0].f)) + sp->f = 1.0; + else + sp->f = 0.0; + break; + case OP_VEC_ELEM_NUM: + { + int rindx = sp[0].f + EPSILON; + struct vector *v = &vec[*op++]; + + if (sp[0].f == SYSMIS || rindx < 1 || rindx > v->nv) + { + if (sp[0].f == SYSMIS) + msg (SE, _("SYSMIS is not a valid index value for vector " + "%s. The result will be set to SYSMIS."), + v->name); + else + msg (SE, _("%g is not a valid index value for vector %s. " + "The result will be set to SYSMIS."), + sp[0].f, v->name); + sp->f = SYSMIS; + break; + } + sp->f = c->data[v->v[rindx - 1]->fv].f; + } + break; + case OP_VEC_ELEM_STR: + { + int rindx = sp[0].f + EPSILON; + struct vector *vect = &vec[*op++]; + struct variable *v; + + if (sp[0].f == SYSMIS || rindx < 1 || rindx > vect->nv) + { + if (sp[0].f == SYSMIS) + msg (SE, _("SYSMIS is not a valid index value for vector " + "%s. The result will be set to the empty " + "string."), + vect->name); + else + msg (SE, _("%g is not a valid index value for vector %s. " + "The result will be set to the empty string."), + sp[0].f, vect->name); + CHECK_STRING_SPACE (0); + sp->c = ALLOC_STRING_SPACE (0); + sp->c[0] = 0; + break; + } + + v = vect->v[rindx - 1]; + CHECK_STRING_SPACE (v->width); + sp->c = ALLOC_STRING_SPACE (v->width); + sp->c[0] = v->width; + memcpy (&sp->c[1], c->data[v->fv].s, v->width); + } + break; + + /* Terminals. */ + case OP_NUM_CON: + sp++; + sp->f = *dbl++; + break; + case OP_STR_CON: + sp++; + CHECK_STRING_SPACE (*str); + sp->c = ALLOC_STRING_SPACE (*str); + memcpy (sp->c, str, *str + 1); + str += *str + 1; + break; + case OP_NUM_VAR: + sp++; + sp->f = c->data[(*vars)->fv].f; + if (is_num_user_missing (sp->f, *vars)) + sp->f = SYSMIS; + vars++; + break; + case OP_STR_VAR: + { + int width = (*vars)->width; + + sp++; + CHECK_STRING_SPACE (width); + sp->c = ALLOC_STRING_SPACE (width); + sp->c[0] = width; + memcpy (&sp->c[1], &c->data[(*vars)->fv], width); + vars++; + } + break; + case OP_NUM_LAG: + { + struct ccase *c = lagged_case (*op++); + + sp++; + if (c == NULL) + sp->f = SYSMIS; + else + { + sp->f = c->data[(*vars)->fv].f; + if (is_num_user_missing (sp->f, *vars)) + sp->f = SYSMIS; + } + vars++; + break; + } + case OP_STR_LAG: + { + struct ccase *c = lagged_case (*op++); + int width = (*vars)->width; + + sp++; + CHECK_STRING_SPACE (width); + sp->c = ALLOC_STRING_SPACE (width); + sp->c[0] = width; + + if (c == NULL) + memset (sp->c, ' ', width); + else + memcpy (&sp->c[1], &c->data[(*vars)->fv], width); + + vars++; + } + break; + case OP_NUM_SYS: + sp++; + sp->f = c->data[*op++].f == SYSMIS; + break; + case OP_STR_MIS: + sp++; + sp->f = is_str_user_missing (c->data[(*vars)->fv].s, *vars); + vars++; + break; + case OP_NUM_VAL: + sp++; + sp->f = c->data[*op++].f; + break; + case OP_CASENUM: + sp++; + sp->f = vfm_sink_info.ncases + 1; + break; + + case OP_SENTINEL: + goto finished; + +#if __CHECKER__ + /* This case prevents Checker from choking. */ + case 42000: + assert (0); +#endif + + default: +#if GLOBAL_DEBUGGING + printf (_("evaluate_expression(): not implemented: %s\n"), + ops[op[-1]].name); +#else + printf (_("evaluate_expression(): not implemented: %d\n"), op[-1]); +#endif + assert (0); + } + + main_loop: ; + } +finished: + if (e->type != EX_STRING) + { + double value = sp->f; + if (!finite (value)) + value = SYSMIS; + if (v) + v->f = value; + return value; + } + else + { + assert (v); + +#if PAGED_STACK + memcpy (e->str_stack, sp->c, sp->c[0] + 1); + v->c = e->str_stack; +#else + v->c = sp->c; +#endif + + return 0.0; + } +} diff --git a/src/expr-opt.c b/src/expr-opt.c new file mode 100644 index 00000000..e221d4e2 --- /dev/null +++ b/src/expr-opt.c @@ -0,0 +1,1142 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "data-in.h" +#include "error.h" +#include "expr.h" +#include "exprP.h" +#include "julcal/julcal.h" +#include "misc.h" +#include "stats.h" +#include "str.h" +#include "var.h" + +/* + Expression "optimizer" + + Operates on the tree representation of expressions. + optimize_expression() performs the optimizations listed below: + + 1. Constant folding + Any operation with constant operands is replaced by its value. + (Exception: random-number-generator functions.) + + 2. Strength reduction (x is any expression; a is a numeric constant) + x/0 => SYSMIS + x*0 => 0 + x**0 => 1 + x**1, x+0, x-0, x*1 => x + x**2 => sqr(x) + x/a => x*(1/a) (where 1/a is evaluated at optimization time) + + I thought about adding additional optimizations but decided that what + is here could already be considered overkill. + */ + +static struct nonterm_node *evaluate_tree (struct nonterm_node * n); +static struct nonterm_node *optimize_tree (struct nonterm_node * n); + +struct nonterm_node * +optimize_expression (struct nonterm_node * n) +{ + int i; + + /* Set to 1 if a child is nonconstant. */ + int nonconst = 0; + + /* Number of system-missing children. */ + int sysmis = 0; + + /* We can't optimize a terminal node. */ + if (n->type > OP_TERMINAL) + return n; + + /* Start by optimizing all the children. */ + for (i = 0; i < n->n; i++) + { + n->arg[i] = ((union any_node *) + optimize_expression ((struct nonterm_node *) n->arg[i])); + if (n->arg[i]->type == OP_NUM_CON) + { + if (n->arg[i]->num_con.value == SYSMIS) + sysmis++; + } + else if (n->arg[i]->type != OP_STR_CON) + nonconst = 1; + } + + if (sysmis && !(ops[n->type].flags & OP_ABSORB_MISS)) + /* Just about any operation produces SYSMIS when given any SYSMIS + arguments. */ + { + struct num_con_node *num = xmalloc (sizeof *num); + free_node ((union any_node *) n); + num->type = OP_NUM_CON; + num->value = SYSMIS; + n = (struct nonterm_node *) num; + } + else if (!nonconst) + /* If all the children of this node are constants, then there are + obvious optimizations. */ + n = evaluate_tree (n); + else + /* Otherwise, we may be able to make certain optimizations + anyway. */ + n = optimize_tree (n); + return n; +} + +static struct nonterm_node *repl_num_con (struct nonterm_node *, double); +static struct nonterm_node *force_repl_num_con (struct nonterm_node *, double); +static struct nonterm_node *repl_str_con (struct nonterm_node *, char *, int); + +#define n0 n->arg[0]->num_con.value +#define n1 n->arg[1]->num_con.value +#define n2 n->arg[2]->num_con.value + +#define s0 n->arg[0]->str_con.s +#define s0l n->arg[0]->str_con.len +#define s1 n->arg[1]->str_con.s +#define s1l n->arg[1]->str_con.len +#define s2 n->arg[2]->str_con.s +#define s2l n->arg[2]->str_con.len +#define s(X) n->arg[X]->str_con.s +#define sl(X) n->arg[X]->str_con.len + +static struct nonterm_node * +optimize_tree (struct nonterm_node * n) +{ + int i; + + errno = 0; + if (n->type == OP_PLUS || n->type == OP_MUL) + { + /* Default constant value. */ + double def = n->type == OP_MUL ? 1.0 : 0.0; + + /* Total value of all the constants. */ + double cval = def; + + /* Number of nonconst arguments. */ + int nvar = 0; + + /* New node. */ + struct nonterm_node *m; + + /* Argument copying counter. */ + int c; + + /* 1=SYSMIS encountered */ + int sysmis = 0; + + for (i = 0; i < n->n; i++) + if (n->arg[i]->type == OP_NUM_CON) + { + if (n->arg[i]->num_con.value != SYSMIS) + { + if (n->type == OP_MUL) + cval *= n->arg[i]->num_con.value; + else + cval += n->arg[i]->num_con.value; + } + else + sysmis++; + } + else + nvar++; + + /* 0*SYSMIS=0, 0/SYSMIS=0; otherwise, SYSMIS and infinities + produce SYSMIS. */ + if (approx_eq (cval, 0.0) && n->type == OP_MUL) + nvar = 0; + else if (sysmis || !finite (cval)) + { + nvar = 0; + cval = SYSMIS; + } + + /* If no nonconstant terms, replace with a constant node. */ + if (nvar == 0) + return force_repl_num_con (n, cval); + + if (nvar == 1 && cval == def) + { + /* If there is exactly one nonconstant term and no constant + terms, replace with the nonconstant term. */ + for (i = 0; i < n->n; i++) + if (n->arg[i]->type != OP_NUM_CON) + m = (struct nonterm_node *) n->arg[i]; + else + free_node (n->arg[i]); + } + else + { + /* Otherwise consolidate all the nonconstant terms. */ + m = xmalloc (sizeof (struct nonterm_node) + + ((nvar + approx_ne (cval, def) - 1) + * sizeof (union any_node *))); + for (i = c = 0; i < n->n; i++) + if (n->arg[i]->type != OP_NUM_CON) + m->arg[c++] = n->arg[i]; + else + free_node (n->arg[i]); + + if (approx_ne (cval, def)) + { + m->arg[c] = xmalloc (sizeof (struct num_con_node)); + m->arg[c]->num_con.type = OP_NUM_CON; + m->arg[c]->num_con.value = cval; + c++; + } + + m->type = n->type; + m->n = c; + } + free (n); + n = m; + } + else if (n->type == OP_POW) + { + if (n->arg[1]->type == OP_NUM_CON) + { + if (approx_eq (n1, 1.0)) + { + struct nonterm_node *m = (struct nonterm_node *) n->arg[0]; + + free_node (n->arg[1]); + free (n); + return m; + } + else if (approx_eq (n1, 2.0)) + { + n = xrealloc (n, sizeof (struct nonterm_node)); + n->type = OP_SQUARE; + n->n = 1; + } + } + } + return n; +} + +#define rnc(D) \ + (n = repl_num_con (n, D)) + +#define frnc(D) \ + (n = force_repl_num_con (n, D)) + +/* Finds the first NEEDLE of length NEEDLE_LEN in a HAYSTACK of length + HAYSTACK_LEN. Returns a 1-based index, 0 on failure. */ +static inline int +str_search (char *haystack, int haystack_len, char *needle, int needle_len) +{ + char *p = memmem (haystack, haystack_len, needle, needle_len); + return p ? p - haystack + 1 : 0; +} + +/* Finds the last NEEDLE of length NEEDLE_LEN in a HAYSTACK of length + HAYSTACK_LEN. Returns a 1-based index, 0 on failure. */ +static inline int +str_rsearch (char *haystack, int haystack_len, char *needle, int needle_len) +{ + char *p = mm_find_reverse (haystack, haystack_len, needle, needle_len); + return p ? p - haystack + 1 : 0; +} + +static struct nonterm_node * +evaluate_tree (struct nonterm_node * n) +{ + static char *strbuf; + int add; + int len; + int i; + + if (!strbuf) + strbuf = xmalloc (256); + errno = 0; + + switch (n->type) + { + case OP_PLUS: + case OP_MUL: + return optimize_tree (n); + + case OP_POW: + if (approx_eq (n0, 0.0) && approx_eq (n1, 0.0)) + frnc (SYSMIS); + else if (n0 == SYSMIS && n1 == 0.0) + frnc (1.0); + else if (n0 == 0.0 && n1 == SYSMIS) + frnc (0.0); + else + rnc (pow (n0, n1)); + break; + + case OP_AND: + if (n0 == 0.0 || n1 == 0.0) + frnc (0.0); + else if (n0 == SYSMIS || n1 == SYSMIS) + frnc (SYSMIS); + else + frnc (1.0); + break; + case OP_OR: + if (n0 == 1.0 || n1 == 1.0) + frnc (1.0); + else if (n0 == SYSMIS || n1 == SYSMIS) + frnc (SYSMIS); + else + frnc (0.0); + break; + case OP_NOT: + rnc (n0 == 0.0 ? 1.0 : 0.0); + break; + + case OP_EQ: + rnc (approx_eq (n0, n1)); + break; + case OP_GE: + rnc (approx_ge (n0, n1)); + break; + case OP_GT: + rnc (approx_gt (n0, n1)); + break; + case OP_LE: + rnc (approx_le (n0, n1)); + break; + case OP_LT: + rnc (approx_lt (n0, n1)); + break; + case OP_NE: + rnc (approx_ne (n0, n1)); + break; + + /* String operators. */ + case OP_STRING_EQ: + rnc (st_compare_pad (s0, s0l, s1, s1l) == 0); + break; + case OP_STRING_GE: + rnc (st_compare_pad (s0, s0l, s1, s1l) >= 0); + break; + case OP_STRING_GT: + rnc (st_compare_pad (s0, s0l, s1, s1l) > 0); + break; + case OP_STRING_LE: + rnc (st_compare_pad (s0, s0l, s1, s1l) <= 0); + break; + case OP_STRING_LT: + rnc (st_compare_pad (s0, s0l, s1, s1l) < 0); + break; + case OP_STRING_NE: + rnc (st_compare_pad (s0, s0l, s1, s1l) != 0); + break; + + /* Unary functions. */ + case OP_NEG: + rnc (-n0); + break; + case OP_ABS: + rnc (fabs (n0)); + break; + case OP_ARCOS: + rnc (acos (n0)); + break; + case OP_ARSIN: + rnc (asin (n0)); + break; + case OP_ARTAN: + rnc (atan (n0)); + break; + case OP_COS: + rnc (cos (n0)); + break; + case OP_EXP: + rnc (exp (n0)); + break; + case OP_LG10: + rnc (log10 (n0)); + break; + case OP_LN: + rnc (log (n0)); + break; + case OP_MOD10: + rnc (fmod (n0, 10)); + break; + case OP_RND: + rnc (n0 >= 0.0 ? floor (n0 + 0.5) : -floor (-n0 + 0.5)); + break; + case OP_SIN: + rnc (sin (n0)); + break; + case OP_SQRT: + rnc (sqrt (n0)); + break; + case OP_TAN: + rnc (tan (n0)); + break; + case OP_TRUNC: + rnc (n0 >= 0.0 ? floor (n0) : -floor (-n0)); + break; + + /* N-ary numeric functions. */ + case OP_ANY: + if (n0 == SYSMIS) + frnc (SYSMIS); + else + { + int sysmis = 1; + double ni; + + for (i = 1; i < n->n; i++) + { + ni = n->arg[i]->num_con.value; + if (approx_eq (n0, ni)) + { + frnc (1.0); + goto any_done; + } + if (ni != SYSMIS) + sysmis = 0; + } + frnc (sysmis ? SYSMIS : 0.0); + } + any_done: + break; + case OP_ANY_STRING: + for (i = 1; i < n->n; i++) + if (!st_compare_pad (n->arg[0]->str_con.s, n->arg[0]->str_con.len, + n->arg[i]->str_con.s, n->arg[i]->str_con.len)) + { + frnc (1.0); + goto any_string_done; + } + frnc (0.0); + any_string_done: + break; + + case OP_CFVAR: + case OP_MAX: + case OP_MEAN: + case OP_MIN: + case OP_NMISS: + case OP_NVALID: + case OP_SD: + case OP_SUM: + case OP_VARIANCE: + { + double d[2] = + {0.0, 0.0}; /* sum, sum of squares */ + double min = DBL_MAX; /* minimum value */ + double max = -DBL_MAX; /* maximum value */ + double ni; /* value of i'th argument */ + int nv = 0; /* number of valid arguments */ + + for (i = 0; i < n->n; i++) + { + ni = n->arg[i]->num_con.value; + if (ni != SYSMIS) + { + nv++; + d[0] += ni; + d[1] += ni * ni; + if (ni < min) + min = ni; + if (ni > max) + max = ni; + } + } + if (n->type == OP_NMISS) + frnc (i - nv); + else if (n->type == OP_NVALID) + frnc (nv); + else if (nv >= (int) n->arg[i]) + { + switch (n->type) + { + case OP_CFVAR: + frnc (calc_cfvar (d, nv)); + break; + case OP_MAX: + frnc (max); + break; + case OP_MEAN: + frnc (calc_mean (d, nv)); + break; + case OP_MIN: + frnc (min); + break; + case OP_SD: + frnc (calc_stddev (calc_variance (d, nv))); + break; + case OP_SUM: + frnc (d[0]); + break; + case OP_VARIANCE: + frnc (calc_variance (d, nv)); + break; + } + } + else + frnc (SYSMIS); + } + break; + case OP_RANGE: + if (n0 == SYSMIS) + frnc (SYSMIS); + else + { + double min, max; + int sysmis = 1; + + for (i = 1; i < n->n; i += 2) + { + min = n->arg[i]->num_con.value; + max = n->arg[i + 1]->num_con.value; + if (min == SYSMIS || max == SYSMIS) + continue; + sysmis = 0; + if (approx_ge (n0, min) && approx_le (n0, max)) + { + frnc (1.0); + goto range_done; + } + } + frnc (sysmis ? SYSMIS : 0.0); + } + range_done: + break; + case OP_RANGE_STRING: + for (i = 1; i < n->n; i += 2) + if (st_compare_pad (n->arg[0]->str_con.s, n->arg[0]->str_con.len, + n->arg[i]->str_con.s, n->arg[i]->str_con.len) >= 0 + && st_compare_pad (n->arg[0]->str_con.s, n->arg[0]->str_con.len, + n->arg[i + 1]->str_con.s, + n->arg[i + 1]->str_con.len) <= 0) + { + frnc (1.0); + goto range_str_done; + } + frnc (0.0); + range_str_done: + break; + + /* Time function. */ + case OP_TIME_HMS: + rnc (60. * (60. * n0 + n1) + n2); + break; + + /* Date construction functions. */ + case OP_DATE_DMY: + rnc (60. * 60. * 24. * yrmoda (n2, n1, n0)); + break; + case OP_DATE_MDY: + rnc (60. * 60. * 24. * yrmoda (n2, n0, n1)); + break; + case OP_DATE_MOYR: + rnc (60. * 60. * 24. * yrmoda (n1, n0, 1)); + break; + case OP_DATE_QYR: + rnc (60. * 60. * 24. * yrmoda (n1, 3 * (int) n0 - 2, 1)); + break; + case OP_DATE_WKYR: + { + double t = yrmoda (n1, 1, 1); + if (t != SYSMIS) + t = 60. * 60. * 24. * (t + 7. * (n0 - 1)); + rnc (t); + } + break; + case OP_DATE_YRDAY: + { + double t = yrmoda (n0, 1, 1); + if (t != SYSMIS) + t = 60. * 60. * 24. * (t + n0 - 1); + rnc (t); + } + break; + case OP_YRMODA: + rnc (yrmoda (n0, n1, n2)); + break; + /* Date extraction functions. */ + case OP_XDATE_DATE: + rnc (floor (n0 / 60. / 60. / 24.) * 60. * 60. * 24.); + break; + case OP_XDATE_HOUR: + rnc (fmod (floor (n0 / 60. / 60.), 24.)); + break; + case OP_XDATE_JDAY: + rnc (julian_to_jday (n0 / 86400.)); + break; + case OP_XDATE_MDAY: + { + int day; + julian_to_calendar (n0 / 86400., NULL, NULL, &day); + rnc (day); + } + break; + case OP_XDATE_MINUTE: + rnc (fmod (floor (n0 / 60.), 60.)); + break; + case OP_XDATE_MONTH: + { + int month; + julian_to_calendar (n0 / 86400., NULL, &month, NULL); + rnc (month); + } + break; + case OP_XDATE_QUARTER: + { + int month; + julian_to_calendar (n0 / 86400., NULL, &month, NULL); + rnc ((month - 1) / 3 + 1); + } + break; + case OP_XDATE_SECOND: + rnc (fmod (n0, 60.)); + break; + case OP_XDATE_TDAY: + rnc (floor (n0 / 60. / 60. / 24.)); + break; + case OP_XDATE_TIME: + rnc (n0 - floor (n0 / 60. / 60. / 24.) * 60. * 60. * 24.); + break; + case OP_XDATE_WEEK: + rnc ((julian_to_jday (n0) - 1) / 7 + 1); + break; + case OP_XDATE_WKDAY: + rnc (julian_to_wday (n0)); + break; + case OP_XDATE_YEAR: + { + int year; + julian_to_calendar (n0 / 86400., &year, NULL, NULL); + rnc (year); + } + break; + + /* String functions. */ + case OP_CONCAT: + { + len = s0l; + memcpy (strbuf, s0, len); + for (i = 1; i < n->n; i++) + { + add = sl (i); + if (add + len > 255) + add = 255 - len; + memcpy (&strbuf[len], s (i), add); + len += add; + } + n = repl_str_con (n, strbuf, len); + } + break; + case OP_INDEX: + rnc (s1l ? str_search (s0, s0l, s1, s1l) : SYSMIS); + break; + case OP_INDEX_OPT: + if (n2 == SYSMIS || (int) n2 <= 0 || s1l % (int) n2) + { + msg (SW, _("While optimizing a constant expression, there was " + "a bad value for the third argument to INDEX.")); + frnc (SYSMIS); + } + else + { + int pos = 0; + int c = s1l / (int) n2; + int r; + + for (i = 0; i < c; i++) + { + r = str_search (s0, s0l, s (i), sl (i)); + if (r < pos || pos == 0) + pos = r; + } + frnc (pos); + } + break; + case OP_RINDEX: + rnc (str_rsearch (s0, s0l, s1, s1l)); + break; + case OP_RINDEX_OPT: + if (n2 == SYSMIS || (int) n2 <= 0 || s1l % (int) n2) + { + msg (SE, _("While optimizing a constant expression, there was " + "a bad value for the third argument to RINDEX.")); + frnc (SYSMIS); + } + else + { + int pos = 0; + int c = s1l / n2; + int r; + + for (i = 0; i < c; i++) + { + r = str_rsearch (s0, s0l, s (i), sl (i)); + if (r > pos) + pos = r; + } + frnc (pos); + } + break; + case OP_LENGTH: + frnc (s0l); + break; + case OP_LOWER: + { + char *cp; + for (cp = &s0[s0l]; cp >= s0; cp--) + *cp = tolower ((unsigned char) (*cp)); + n = repl_str_con (n, s0, s0l); + } + break; + case OP_UPPER: + { + char *cp; + for (cp = &s0[s0[0] + 1]; cp > s0; cp--) + *cp = toupper ((unsigned char) (*cp)); + n = repl_str_con (n, s0, s0l); + } + break; + case OP_LPAD: + case OP_LPAD_OPT: + case OP_RPAD: + case OP_RPAD_OPT: + { + int c; + + if (n1 == SYSMIS) + { + n = repl_str_con (n, NULL, 0); + break; + } + len = n1; + len = range (len, 1, 255); + add = max (n1 - s0l, 0); + + if (n->type == OP_LPAD_OPT || n->type == OP_RPAD_OPT) + { + if (s2l < 1) + { + c = n->type == OP_LPAD_OPT ? 'L' : 'R'; + msg (SE, _("Third argument to %cPAD() must be at least one " + "character in length."), c); + c = ' '; + } + else + c = s2[0]; + } + else + c = ' '; + + if (n->type == OP_LPAD || n->type == OP_LPAD_OPT) + memmove (&s0[add], s0, len); + if (n->type == OP_LPAD || n->type == OP_LPAD_OPT) + memset (s0, c, add); + else + memset (&s0[s0l], c, add); + + n = repl_str_con (n, s0, len); + } + break; + case OP_LTRIM: + case OP_LTRIM_OPT: + case OP_RTRIM: + case OP_RTRIM_OPT: + { + int c; + char *cp = s0; + + if (n->type == OP_LTRIM_OPT || n->type == OP_RTRIM_OPT) + { + if (s1l < 1) + { + c = n->type == OP_LTRIM_OPT ? 'L' : 'R'; + msg (SE, _("Second argument to %cTRIM() must be at least one " + "character in length."), c); + c = ' '; + } + else + c = s1[0]; + } + len = s0l; + if (n->type == OP_LTRIM || n->type == OP_LTRIM_OPT) + { + while (*cp == c && cp < &s0[len]) + cp++; + len -= cp - s0; + } + else + while (len > 0 && s0[len - 1] == c) + len--; + n = repl_str_con (n, cp, len); + } + break; + case OP_NUMBER: + case OP_NUMBER_OPT: + { + union value v; + struct data_in di; + + di.s = s0; + di.e = s0 + s0l; + di.v = &v; + di.flags = DI_IGNORE_ERROR; + di.f1 = 1; + + if (n->type == OP_NUMBER_OPT) + { + di.format.type = (int) n->arg[1]; + di.format.w = (int) n->arg[2]; + di.format.d = (int) n->arg[3]; + } + else + { + di.format.type = FMT_F; + di.format.w = s0l; + di.format.d = 0; + } + + data_in (&di); + frnc (v.f); + } + break; + case OP_STRING: + { + union value v; + struct fmt_spec f; + f.type = (int) n->arg[1]; + f.w = (int) n->arg[2]; + f.d = (int) n->arg[3]; + v.f = n0; + + data_out (strbuf, &f, &v); + n = repl_str_con (n, strbuf, f.w); + } + break; + case OP_SUBSTR: + case OP_SUBSTR_OPT: + { + int pos = (int) n1; + if (pos > s0l || pos <= 0 || n1 == SYSMIS + || (n->type == OP_SUBSTR_OPT && n2 == SYSMIS)) + n = repl_str_con (n, NULL, 0); + else + { + if (n->type == OP_SUBSTR_OPT) + { + len = (int) n2; + if (len + pos - 1 > s0l) + len = s0l - pos + 1; + } + else + len = s0l - pos + 1; + n = repl_str_con (n, &s0[pos - 1], len); + } + } + break; + + /* Weirdness. */ + case OP_INV: + rnc (1.0 / n0); + break; + case OP_MOD: + if (approx_eq (n0, 0.0) && n1 == SYSMIS) + frnc (0.0); + else + rnc (fmod (n0, n1)); + break; + case OP_NUM_TO_BOOL: + if (approx_eq (n0, 0.0)) + n0 = 0.0; + else if (approx_eq (n0, 1.0)) + n0 = 1.0; + else if (n0 != SYSMIS) + { + msg (SE, _("When optimizing a constant expression, an integer " + "that was being used as an Boolean value was found " + "to have a constant value other than 0, 1, or SYSMIS.")); + n0 = 0.0; + } + rnc (n0); + break; + +#if __CHECKER__ + /* This case prevents Checker from choking. */ + case 42000: + assert (0); +#endif + } + return n; +} + +#undef n0 +#undef n1 +#undef n2 + +#undef s0 +#undef s0l +#undef s1 +#undef s1l +#undef s2 +#undef s2l +#undef s +#undef sl + +#undef rnc +#undef frnc + +static struct nonterm_node * +repl_num_con (struct nonterm_node * n, double d) +{ + int i; + if (!finite (d) || errno) + d = SYSMIS; + else + for (i = 0; i < n->n; i++) + if (n->arg[i]->type == OP_NUM_CON && n->arg[i]->num_con.value == SYSMIS) + { + d = SYSMIS; + break; + } + return force_repl_num_con (n, d); +} + +static struct nonterm_node * +force_repl_num_con (struct nonterm_node * n, double d) +{ + struct num_con_node *num; + + if (!finite (d) || errno) + d = SYSMIS; + free_node ((union any_node *) n); + num = xmalloc (sizeof *num); + num->type = OP_NUM_CON; + num->value = d; + return (struct nonterm_node *) num; +} + +static struct nonterm_node * +repl_str_con (struct nonterm_node * n, char *s, int len) +{ + struct str_con_node *str; + + /* The ordering here is important since the source string may be + part of a subnode of n. */ + str = xmalloc (sizeof *str + len - 1); + str->type = OP_STR_CON; + str->len = len; + memcpy (str->s, s, len); + free_node ((union any_node *) n); + return (struct nonterm_node *) str; +} + +/* Returns the number of days since 10 Oct 1582 for the date + YEAR/MONTH/DAY, where YEAR is in range 0..199 or 1582..19999, MONTH + is in 1..12, and DAY is in 1..31. */ +double +yrmoda (double year, double month, double day) +{ + if (year == SYSMIS || month == SYSMIS || day == SYSMIS) + return SYSMIS; + + /* The addition of EPSILON avoids converting, for example, + 1991.9999997=>1991. */ + year = floor (year + EPSILON); + month = floor (month + EPSILON); + day = floor (day + EPSILON); + + if (year >= 0. && year <= 199.) + year += 1900.; + if ((year < 1582. || year > 19999.) + || (year == 1582. && (month < 10. || (month == 10. && day < 15.))) + || (month < -1 || month > 13) + || (day < -1 || day > 32)) + return SYSMIS; + return calendar_to_julian (year, month, day); +} + +/* Expression dumper. */ + +static struct expression *e; +static int nop, mop; +static int ndbl, mdbl; +static int nstr, mstr; +static int nvars, mvars; + +static void dump_node (union any_node * n); +static void emit (int); +static void emit_num_con (double); +static void emit_str_con (char *, int); +static void emit_var (struct variable *); + +void +dump_expression (union any_node * n, struct expression * expr) +{ + unsigned char *o; + + int height = 0; + + int max_height = 0; + + e = expr; + e->op = NULL; + e->num = NULL; + e->str = NULL; + e->var = NULL; + nop = mop = 0; + ndbl = mdbl = 0; + nstr = mstr = 0; + nvars = mvars = 0; + dump_node (n); + emit (OP_SENTINEL); + + /* Now compute the stack height needed to evaluate the expression. */ + for (o = e->op; *o != OP_SENTINEL; o++) + { + if (ops[*o].flags & OP_VAR_ARGS) + height += 1 - o[1]; + else + height += ops[*o].height; + o += ops[*o].skip; + if (height > max_height) + max_height = height; + } + + /* ANSI says we have to waste space for one `value' since pointers + are not guaranteed to be able to point to a spot *before* a + block. If only all the world were a VAX... */ + max_height++; + + e->stack = xmalloc (max_height * sizeof *e->stack); + +#if PAGED_STACK + e->str_stack = e->type == EX_STRING ? xmalloc (256) : NULL; +#else + e->str_stack = xmalloc (256); + e->str_size = 256; +#endif +} + +static void +dump_node (union any_node * n) +{ + if (n->type == OP_AND || n->type == OP_OR) + { + int i; + + dump_node (n->nonterm.arg[0]); + for (i = 1; i < n->nonterm.n; i++) + { + dump_node (n->nonterm.arg[i]); + emit (n->type); + } + return; + } + else if (n->type < OP_TERMINAL) + { + int i; + for (i = 0; i < n->nonterm.n; i++) + dump_node (n->nonterm.arg[i]); + emit (n->type); + if (ops[n->type].flags & OP_VAR_ARGS) + emit (n->nonterm.n); + if (ops[n->type].flags & OP_MIN_ARGS) + emit ((int) n->nonterm.arg[n->nonterm.n]); + if (ops[n->type].flags & OP_FMT_SPEC) + { + emit ((int) n->nonterm.arg[n->nonterm.n]); + emit ((int) n->nonterm.arg[n->nonterm.n + 1]); + emit ((int) n->nonterm.arg[n->nonterm.n + 2]); + } + return; + } + + emit (n->type); + if (n->type == OP_NUM_CON) + emit_num_con (n->num_con.value); + else if (n->type == OP_STR_CON) + emit_str_con (n->str_con.s, n->str_con.len); + else if (n->type == OP_NUM_VAR || n->type == OP_STR_VAR + || n->type == OP_STR_MIS) + emit_var (n->var.v); + else if (n->type == OP_NUM_LAG || n->type == OP_STR_LAG) + { + emit_var (n->lag.v); + emit (n->lag.lag); + } + else if (n->type == OP_NUM_SYS || n->type == OP_NUM_VAL) + emit (n->var.v->fv); + else + assert (n->type == OP_CASENUM); +} + +static void +emit (int op) +{ + if (nop >= mop) + { + mop += 16; + e->op = xrealloc (e->op, mop * sizeof *e->op); + } + e->op[nop++] = op; +} + +static void +emit_num_con (double dbl) +{ + if (ndbl >= mdbl) + { + mdbl += 16; + e->num = xrealloc (e->num, mdbl * sizeof *e->num); + } + e->num[ndbl++] = dbl; +} + +static void +emit_str_con (char *str, int len) +{ + if (nstr + len + 1 > mstr) + { + mstr += 256; + e->str = xrealloc (e->str, mstr); + } + e->str[nstr++] = len; + memcpy (&e->str[nstr], str, len); + nstr += len; +} + +static void +emit_var (struct variable * v) +{ + if (nvars >= mvars) + { + mvars += 16; + e->var = xrealloc (e->var, mvars * sizeof *e->var); + } + e->var[nvars++] = v; +} diff --git a/src/expr-prs.c b/src/expr-prs.c new file mode 100644 index 00000000..d447afdf --- /dev/null +++ b/src/expr-prs.c @@ -0,0 +1,1805 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "expr.h" +#include "exprP.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vector.h" +#include "vfm.h" + +/* Declarations. */ + +/* Lowest precedence. */ +static int parse_or (union any_node **n); +static int parse_and (union any_node **n); +static int parse_not (union any_node **n); +static int parse_rel (union any_node **n); +static int parse_add (union any_node **n); +static int parse_mul (union any_node **n); +static int parse_neg (union any_node **n); +static int parse_exp (union any_node **n); +static int parse_primary (union any_node **n); +static int parse_function (union any_node **n); +/* Highest precedence. */ + +/* Utility functions. */ +static const char *expr_type_name (int type); +static const char *type_name (int type); +static void make_bool (union any_node **n); +static union any_node *allocate_nonterminal (int op, union any_node *n); +static union any_node *append_nonterminal_arg (union any_node *, + union any_node *); +static int type_check (union any_node **n, int type, int flags); + +static void init_func_tab (void); +static int cmp_func (const void *a, const void *b); + +#if DEBUGGING +static void debug_print_tree (union any_node *, int); +#endif + +#if GLOBAL_DEBUGGING +static void debug_print_postfix (struct expression *); +#endif + +/* Public functions. */ + +void +expr_free (struct expression *e) +{ + if (e == NULL) + return; + + free (e->op); + free (e->var); + free (e->num); + free (e->str); + free (e->stack); + free (e->str_stack); + free (e); +} + +struct expression * +expr_parse (int flags) +{ + struct expression *e; + union any_node *n; + int type; + + /* Make sure the table of functions is initialized. */ + init_func_tab (); + + /* Parse the expression. */ + type = parse_or (&n); + if (type == EX_ERROR) + return NULL; + + /* Enforce type rules. */ + if (!type_check (&n, type, flags)) + { + free_node (n); + return NULL; + } + + /* Optimize the expression as best we can. */ + n = (union any_node *) optimize_expression ((struct nonterm_node *) n); + + /* Dump the tree-based expression to a postfix representation for + best evaluation speed, and destroy the tree. */ + e = xmalloc (sizeof *e); + e->type = type; + dump_expression (n, e); + free_node (n); + + /* If we're debugging or the user requested it, print the postfix + representation. */ +#if GLOBAL_DEBUGGING +#if !DEBUGGING + if (flags & PXP_DUMP) +#endif + debug_print_postfix (e); +#endif + + return e; +} + +static int +type_check (union any_node **n, int type, int flags) +{ + /* Enforce PXP_BOOLEAN flag. */ + if (flags & PXP_BOOLEAN) + { + if (type == EX_STRING) + { + msg (SE, _("A string expression was supplied in a place " + "where a Boolean expression was expected.")); + return 0; + } + else if (type == EX_NUMERIC) + *n = allocate_nonterminal (OP_NUM_TO_BOOL, *n); + } + + /* Enforce PXP_NUMERIC flag. */ + if ((flags & PXP_NUMERIC) && (type != EX_NUMERIC)) + { + msg (SE, _("A numeric expression was expected in a place " + "where one was not supplied.")); + return 0; + } + + /* Enforce PXP_STRING flag. */ + if ((flags & PXP_STRING) && (type != EX_STRING)) + { + msg (SE, _("A string expression was expected in a place " + "where one was not supplied.")); + return 0; + } + + return 1; +} + +/* Recursive-descent expression parser. */ + +/* Parses the OR level. */ +static int +parse_or (union any_node **n) +{ + char typ[] = N_("The OR operator cannot take string operands."); + union any_node *c; + int type; + + type = parse_and (n); + if (type == EX_ERROR || token != T_OR) + return type; + if (type == EX_STRING) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + else if (type == EX_NUMERIC) + make_bool (n); + + c = allocate_nonterminal (OP_OR, *n); + for (;;) + { + lex_get (); + type = parse_and (n); + if (type == EX_ERROR) + goto fail; + else if (type == EX_STRING) + { + msg (SE, gettext (typ)); + goto fail; + } + else if (type == EX_NUMERIC) + make_bool (n); + c = append_nonterminal_arg (c, *n); + + if (token != T_OR) + break; + } + *n = c; + return EX_BOOLEAN; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses the AND level. */ +static int +parse_and (union any_node ** n) +{ + static const char typ[] + = N_("The AND operator cannot take string operands."); + union any_node *c; + int type = parse_not (n); + + if (type == EX_ERROR) + return EX_ERROR; + if (token != T_AND) + return type; + if (type == EX_STRING) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + else if (type == EX_NUMERIC) + make_bool (n); + + c = allocate_nonterminal (OP_AND, *n); + for (;;) + { + lex_get (); + type = parse_not (n); + if (type == EX_ERROR) + goto fail; + else if (type == EX_STRING) + { + msg (SE, gettext (typ)); + goto fail; + } + else if (type == EX_NUMERIC) + make_bool (n); + c = append_nonterminal_arg (c, *n); + + if (token != T_AND) + break; + } + *n = c; + return EX_BOOLEAN; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses the NOT level. */ +static int +parse_not (union any_node ** n) +{ + static const char typ[] + = N_("The NOT operator cannot take a string operand."); + int not = 0; + int type; + + while (lex_match (T_NOT)) + not ^= 1; + type = parse_rel (n); + if (!not || type == EX_ERROR) + return type; + + if (type == EX_STRING) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + else if (type == EX_NUMERIC) + make_bool (n); + + *n = allocate_nonterminal (OP_NOT, *n); + return EX_BOOLEAN; +} + +static int +parse_rel (union any_node ** n) +{ + static const char typ[] + = N_("Strings cannot be compared with numeric or Boolean " + "values with the relational operators " + "= >= > <= < <>."); + union any_node *c; + int type = parse_add (n); + + if (type == EX_ERROR) + return EX_ERROR; + if (token == '=') + token = T_EQ; + if (token < T_EQ || token > T_NE) + return type; + + for (;;) + { + int t; + + c = allocate_nonterminal (token - T_EQ + + (type == EX_NUMERIC ? OP_EQ : OP_STRING_EQ), + *n); + lex_get (); + + t = parse_add (n); + if (t == EX_ERROR) + goto fail; + if (t == EX_BOOLEAN && type == EX_NUMERIC) + make_bool (&c->nonterm.arg[0]); + else if (t == EX_NUMERIC && type == EX_BOOLEAN) + make_bool (n); + else if (t != type) + { + msg (SE, gettext (typ)); + goto fail; + } + + c = append_nonterminal_arg (c, *n); + *n = c; + + if (token == '=') + token = T_EQ; + if (token < T_EQ || token > T_NE) + break; + + type = EX_BOOLEAN; + } + return EX_BOOLEAN; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses the addition and subtraction level. */ +static int +parse_add (union any_node **n) +{ + static const char typ[] + = N_("The `+' and `-' operators may only be used with " + "numeric operands."); + union any_node *c; + int type; + int op; + + type = parse_mul (n); + lex_negative_to_dash (); + if (type == EX_ERROR || (token != '+' && token != '-')) + return type; + if (type != EX_NUMERIC) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + + c = allocate_nonterminal (OP_PLUS, *n); + for (;;) + { + op = token; + lex_get (); + + type = parse_mul (n); + if (type == EX_ERROR) + goto fail; + else if (type != EX_NUMERIC) + { + msg (SE, gettext (typ)); + goto fail; + } + if (op == '-') + *n = allocate_nonterminal (OP_NEG, *n); + c = append_nonterminal_arg (c, *n); + + lex_negative_to_dash (); + if (token != '+' && token != '-') + break; + } + *n = c; + return EX_NUMERIC; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses the multiplication and division level. */ +static int +parse_mul (union any_node ** n) +{ + static const char typ[] + = N_("The `*' and `/' operators may only be used with " + "numeric operands."); + + union any_node *c; + int type; + int op; + + type = parse_neg (n); + if (type == EX_ERROR || (token != '*' && token != '/')) + return type; + if (type != EX_NUMERIC) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + + c = allocate_nonterminal (OP_MUL, *n); + for (;;) + { + op = token; + lex_get (); + + type = parse_neg (n); + if (type == EX_ERROR) + goto fail; + else if (type != EX_NUMERIC) + { + msg (SE, gettext (typ)); + goto fail; + } + if (op == '/') + *n = allocate_nonterminal (OP_INV, *n); + c = append_nonterminal_arg (c, *n); + + if (token != '*' && token != '/') + break; + } + *n = c; + return EX_NUMERIC; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses the unary minus level. */ +static int +parse_neg (union any_node **n) +{ + static const char typ[] + = N_("The unary minus (-) operator can only take a numeric operand."); + + int neg = 0; + int type; + + for (;;) + { + lex_negative_to_dash (); + if (!lex_match ('-')) + break; + neg ^= 1; + } + type = parse_exp (n); + if (!neg || type == EX_ERROR) + return type; + if (type != EX_NUMERIC) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + + *n = allocate_nonterminal (OP_NEG, *n); + return EX_NUMERIC; +} + +static int +parse_exp (union any_node **n) +{ + static const char typ[] + = N_("Both operands to the ** operator must be numeric."); + + union any_node *c; + int type; + + type = parse_primary (n); + if (type == EX_ERROR || token != T_EXP) + return type; + if (type != EX_NUMERIC) + { + free_node (*n); + msg (SE, gettext (typ)); + return 0; + } + + for (;;) + { + c = allocate_nonterminal (OP_POW, *n); + lex_get (); + + type = parse_primary (n); + if (type == EX_ERROR) + goto fail; + else if (type != EX_NUMERIC) + { + msg (SE, gettext (typ)); + goto fail; + } + *n = append_nonterminal_arg (c, *n); + + if (token != T_EXP) + break; + } + return EX_NUMERIC; + +fail: + free_node (c); + return EX_ERROR; +} + +/* Parses system variables. */ +static int +parse_sysvar (union any_node **n) +{ + if (!strcmp (tokid, "$CASENUM")) + { + *n = xmalloc (sizeof (struct casenum_node)); + (*n)->casenum.type = OP_CASENUM; + return EX_NUMERIC; + } + else + { + double d; + + if (!strcmp (tokid, "$SYSMIS")) + d = SYSMIS; + else if (!strcmp (tokid, "$JDATE")) + { + struct tm *time = localtime (&last_vfm_invocation); + d = yrmoda (time->tm_year + 1900, time->tm_mon + 1, time->tm_mday); + } + else if (!strcmp (tokid, "$DATE")) + { + static const char *months[12] = + { + "JAN", "FEB", "MAR", "APR", "MAY", "JUN", + "JUL", "AUG", "SEP", "OCT", "NOV", "DEC", + }; + + struct tm *time; + char temp_buf[10]; + + time = localtime (&last_vfm_invocation); + sprintf (temp_buf, "%02d %s %02d", abs (time->tm_mday) % 100, + months[abs (time->tm_mon) % 12], abs (time->tm_year) % 100); + + *n = xmalloc (sizeof (struct str_con_node) + 8); + (*n)->str_con.type = OP_STR_CON; + (*n)->str_con.len = 9; + memcpy ((*n)->str_con.s, temp_buf, 9); + return EX_STRING; + } + else if (!strcmp (tokid, "$TIME")) + { + struct tm *time; + time = localtime (&last_vfm_invocation); + d = (yrmoda (time->tm_year + 1900, time->tm_mon + 1, + time->tm_mday) * 60. * 60. * 24. + + time->tm_hour * 60 * 60. + + time->tm_min * 60. + + time->tm_sec); + } + else if (!strcmp (tokid, "$LENGTH")) + { + msg (SW, _("Use of $LENGTH is obsolete, returning default of 66.")); + d = 66.0; + } + else if (!strcmp (tokid, "$WIDTH")) + { + msg (SW, _("Use of $WIDTH is obsolete, returning default of 131.")); + d = 131.0; + } + else + { + msg (SE, _("Unknown system variable %s."), tokid); + return EX_ERROR; + } + + *n = xmalloc (sizeof (struct num_con_node)); + (*n)->num_con.type = OP_NUM_CON; + (*n)->num_con.value = d; + return EX_NUMERIC; + } +} + +/* Parses numbers, varnames, etc. */ +static int +parse_primary (union any_node **n) +{ + switch (token) + { + case T_ID: + { + struct variable *v; + + /* An identifier followed by a left parenthesis is a function + call. */ + if (lex_look_ahead () == '(') + return parse_function (n); + + /* $ at the beginning indicates a system variable. */ + if (tokid[0] == '$') + { + int type = parse_sysvar (n); + lex_get (); + return type; + } + + /* Otherwise, it must be a user variable. */ + v = find_variable (tokid); + lex_get (); + if (v == NULL) + { + lex_error (_("expecting variable name")); + return EX_ERROR; + } + + *n = xmalloc (sizeof (struct var_node)); + (*n)->var.type = v->type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR; + (*n)->var.v = v; + return v->type == NUMERIC ? EX_NUMERIC : EX_STRING; + } + + case T_NUM: + *n = xmalloc (sizeof (struct num_con_node)); + (*n)->num_con.type = OP_NUM_CON; + (*n)->num_con.value = tokval; + lex_get (); + return EX_NUMERIC; + + case T_STRING: + { + *n = xmalloc (sizeof (struct str_con_node) + ds_length (&tokstr) - 1); + (*n)->str_con.type = OP_STR_CON; + (*n)->str_con.len = ds_length (&tokstr); + memcpy ((*n)->str_con.s, ds_value (&tokstr), ds_length (&tokstr)); + lex_get (); + return EX_STRING; + } + + case '(': + { + int t; + lex_get (); + t = parse_or (n); + if (!lex_match (')')) + { + lex_error (_("expecting `)'")); + free_node (*n); + return EX_ERROR; + } + return t; + } + + default: + lex_error (_("in expression")); + return EX_ERROR; + } +} + +/* Individual function parsing. */ + +struct function + { + const char *s; + int t; + int (*func) (struct function *, int, union any_node **); + const char *desc; + }; + +static struct function func_tab[]; +static int func_count; + +static int get_num_args (struct function *, int, union any_node **); + +static int +unary_func (struct function * f, int x unused, union any_node ** n) +{ + double divisor; + struct nonterm_node *c; + + if (!get_num_args (f, 1, n)) + return EX_ERROR; + + switch (f->t) + { + case OP_CTIME_DAYS: + divisor = 1 / 60. / 60. / 24.; + goto multiply; + case OP_CTIME_HOURS: + divisor = 1 / 60. / 60.; + goto multiply; + case OP_CTIME_MINUTES: + divisor = 1 / 60.; + goto multiply; + case OP_TIME_DAYS: + divisor = 60. * 60. * 24.; + goto multiply; + + case OP_CTIME_SECONDS: + c = &(*n)->nonterm; + *n = (*n)->nonterm.arg[0]; + free (c); + return EX_NUMERIC; + } + return EX_NUMERIC; + +multiply: + /* Arrive here when we encounter an operation that is just a + glorified version of a multiplication or division. Converts the + operation directly into that multiplication. */ + c = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *)); + c->type = OP_MUL; + c->n = 2; + c->arg[0] = (*n)->nonterm.arg[0]; + c->arg[1] = xmalloc (sizeof (struct num_con_node)); + c->arg[1]->num_con.type = OP_NUM_CON; + c->arg[1]->num_con.value = divisor; + free (*n); + *n = (union any_node *) c; + return EX_NUMERIC; +} + +static int +binary_func (struct function * f, int x unused, union any_node ** n) +{ + if (!get_num_args (f, 2, n)) + return EX_ERROR; + return EX_NUMERIC; +} + +static int +ternary_func (struct function * f, int x unused, union any_node ** n) +{ + if (!get_num_args (f, 3, n)) + return EX_ERROR; + return EX_NUMERIC; +} + +static int +MISSING_func (struct function * f, int x unused, union any_node ** n) +{ + if (token == T_ID && is_varname (tokid) && lex_look_ahead () == ')') + { + struct var_node *c = xmalloc (sizeof *c); + c->v = parse_variable (); + c->type = c->v->type == ALPHA ? OP_STR_MIS : OP_NUM_SYS; + *n = (union any_node *) c; + return EX_BOOLEAN; + } + if (!get_num_args (f, 1, n)) + return EX_ERROR; + return EX_BOOLEAN; +} + +static int +SYSMIS_func (struct function * f unused, int x unused, union any_node ** n) +{ + int t; + + if (token == T_ID && is_varname (tokid) && lex_look_ahead () == ')') + { + struct variable *v; + v = parse_variable (); + if (v->type == ALPHA) + { + struct num_con_node *c = xmalloc (sizeof *c); + c->type = OP_NUM_CON; + c->value = 0; + return EX_BOOLEAN; + } + else + { + struct var_node *c = xmalloc (sizeof *c); + c->type = OP_NUM_SYS; + c->v = v; + return EX_BOOLEAN; + } + } + + t = parse_or (n); + if (t == EX_ERROR) + return t; + else if (t == EX_NUMERIC) + { + *n = allocate_nonterminal (OP_SYSMIS, *n); + return EX_BOOLEAN; + } + else /* EX_STRING or EX_BOOLEAN */ + { + /* Return constant `true' value. */ + free_node (*n); + *n = xmalloc (sizeof (struct num_con_node)); + (*n)->num_con.type = OP_NUM_CON; + (*n)->num_con.value = 1.0; + return EX_BOOLEAN; + } +} + +static int +VALUE_func (struct function *f unused, int x unused, union any_node **n) +{ + struct variable *v = parse_variable (); + + if (!v) + return EX_ERROR; + *n = xmalloc (sizeof (struct var_node)); + (*n)->var.v = v; + if (v->type == NUMERIC) + { + (*n)->var.type = OP_NUM_VAL; + return EX_NUMERIC; + } + else + { + (*n)->var.type = OP_STR_VAR; + return EX_STRING; + } +} + +static int +LAG_func (struct function *f unused, int x unused, union any_node **n) +{ + struct variable *v = parse_variable (); + int nlag = 1; + + if (!v) + return EX_ERROR; + if (lex_match (',')) + { + if (!lex_integer_p () || lex_integer () <= 0 || lex_integer () > 1000) + { + msg (SE, _("Argument 2 to LAG must be a small positive " + "integer constant.")); + return 0; + } + + nlag = lex_integer (); + lex_get (); + } + n_lag = max (nlag, n_lag); + *n = xmalloc (sizeof (struct lag_node)); + (*n)->lag.type = (v->type == NUMERIC ? OP_NUM_LAG : OP_STR_LAG); + (*n)->lag.v = v; + (*n)->lag.lag = nlag; + return (v->type == NUMERIC ? EX_NUMERIC : EX_STRING); +} + +/* This screwball function parses n-ary operators: + 1. NMISS, NVALID, SUM, MEAN, MIN, MAX: any number of (numeric) arguments. + 2. SD, VARIANCE, CFVAR: at least two (numeric) arguments. + 3. RANGE: An odd number of arguments, but at least three. + All arguments must be the same type. + 4. ANY: At least two arguments. All arguments must be the same type. + */ +static int +nary_num_func (struct function *f, int min_args, union any_node **n) +{ + /* Argument number of current argument (used for error messages). */ + int argn = 1; + + /* Number of arguments. */ + int nargs; + + /* Number of arguments allocated. */ + int m = 16; + + /* Type of arguments. */ + int type = (f->t == OP_ANY || f->t == OP_RANGE) ? -1 : NUMERIC; + + *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15])); + (*n)->nonterm.type = f->t; + (*n)->nonterm.n = 0; + for (;;) + { + /* Special case: vara TO varb. */ + + /* FIXME: Is this condition failsafe? Can we _ever_ have two + juxtaposed identifiers otherwise? */ + if (token == T_ID && is_varname (tokid) + && toupper (lex_look_ahead ()) == 'T') + { + struct variable **v; + int nv; + int j; + int opts = PV_SINGLE; + + if (type == NUMERIC) + opts |= PV_NUMERIC; + else if (type == ALPHA) + opts |= PV_STRING; + if (!parse_variables (NULL, &v, &nv, opts)) + goto fail; + if (nv + (*n)->nonterm.n >= m) + { + m += nv + 16; + *n = xrealloc (*n, (sizeof (struct nonterm_node) + + (m - 1) * sizeof (union any_node *))); + } + if (type == -1) + { + type = v[0]->type; + for (j = 1; j < nv; j++) + if (type != v[j]->type) + { + msg (SE, _("Type mismatch in argument %d of %s, which was " + "expected to be of %s type. It was actually " + "of %s type. "), + argn, f->s, type_name (type), type_name (v[j]->type)); + free (v); + goto fail; + } + } + for (j = 0; j < nv; j++) + { + union any_node **c = &(*n)->nonterm.arg[(*n)->nonterm.n++]; + *c = xmalloc (sizeof (struct var_node)); + (*c)->var.type = (type == NUMERIC ? OP_NUM_VAR : OP_STR_VAR); + (*c)->var.v = v[j]; + } + } + else + { + union any_node *c; + int t = parse_or (&c); + + if (t == EX_ERROR) + goto fail; + if (t == EX_BOOLEAN) + { + free_node (c); + msg (SE, _("%s cannot take Boolean operands."), f->s); + goto fail; + } + if (type == -1) + { + if (t == EX_NUMERIC) + type = NUMERIC; + else if (t == EX_STRING) + type = ALPHA; + } + else if ((t == EX_NUMERIC) ^ (type == NUMERIC)) + { + free_node (c); + msg (SE, _("Type mismatch in argument %d of %s, which was " + "expected to be of %s type. It was actually " + "of %s type. "), + argn, f->s, type_name (type), expr_type_name (t)); + goto fail; + } + if ((*n)->nonterm.n + 1 >= m) + { + m += 16; + *n = xrealloc (*n, (sizeof (struct nonterm_node) + + (m - 1) * sizeof (union any_node *))); + } + (*n)->nonterm.arg[(*n)->nonterm.n++] = c; + } + + if (token == ')') + break; + if (!lex_match (',')) + { + lex_error (_("in function call")); + goto fail; + } + + argn++; + } + *n = xrealloc (*n, (sizeof (struct nonterm_node) + + ((*n)->nonterm.n) * sizeof (union any_node *))); + + nargs = (*n)->nonterm.n; + if (f->t == OP_RANGE) + { + if (nargs < 3 || (nargs & 1) == 0) + { + msg (SE, _("RANGE requires an odd number of arguments, but " + "at least three.")); + return 0; + } + } + else if (f->t == OP_SD || f->t == OP_VARIANCE + || f->t == OP_CFVAR || f->t == OP_ANY) + { + if (nargs < 2) + { + msg (SE, _("%s requires at least two arguments."), f->s); + return 0; + } + } + + if (f->t == OP_CFVAR || f->t == OP_SD || f->t == OP_VARIANCE) + min_args = max (min_args, 2); + else + min_args = max (min_args, 1); + + /* Yes, this is admittedly a terrible crock, but it works. */ + (*n)->nonterm.arg[(*n)->nonterm.n] = (union any_node *) min_args; + + if (min_args > nargs) + { + msg (SE, _("%s.%d requires at least %d arguments."), + f->s, min_args, min_args); + return 0; + } + + if (f->t == OP_ANY || f->t == OP_RANGE) + { + if (type == T_STRING) + f->t++; + return EX_BOOLEAN; + } + else + return EX_NUMERIC; + +fail: + free_node (*n); + return EX_ERROR; +} + +static int +CONCAT_func (struct function * f unused, int x unused, union any_node ** n) +{ + int m = 0; + + int type; + + *n = xmalloc (sizeof (struct nonterm_node) + sizeof (union any_node *[15])); + (*n)->nonterm.type = OP_CONCAT; + (*n)->nonterm.n = 0; + for (;;) + { + if ((*n)->nonterm.n >= m) + { + m += 16; + *n = xrealloc (*n, (sizeof (struct nonterm_node) + + (m - 1) * sizeof (union any_node *))); + } + type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]); + if (type == EX_ERROR) + goto fail; + if (type != EX_STRING) + { + msg (SE, _("Argument %d to CONCAT is type %s. All arguments " + "to CONCAT must be strings."), + (*n)->nonterm.n + 1, expr_type_name (type)); + goto fail; + } + (*n)->nonterm.n++; + + if (!lex_match (',')) + break; + } + *n = xrealloc (*n, (sizeof (struct nonterm_node) + + ((*n)->nonterm.n - 1) * sizeof (union any_node *))); + return EX_STRING; + +fail: + free_node (*n); + return EX_ERROR; +} + +/* Parses a string function according to f->desc. f->desc[0] is the + return type of the function. Succeeding characters represent + successive args. Optional args are separated from the required + args by a slash (`/'). Codes are `n', numeric arg; `s', string + arg; and `f', format spec (this must be the last arg). If the + optional args are included, the type becomes f->t+1. */ +static int +generic_str_func (struct function *f, int x unused, union any_node ** n) +{ + int max_args = 0; + int type; + const char *cp; + + /* Count max number of arguments. */ + cp = &f->desc[1]; + while (*cp) + { + if (*cp == 'n' || *cp == 's') + max_args++; + else if (*cp == 'f') + max_args += 3; + cp++; + } + cp = &f->desc[1]; + + *n = xmalloc (sizeof (struct nonterm_node) + + (max_args - 1) * sizeof (union any_node *)); + (*n)->nonterm.type = f->t; + (*n)->nonterm.n = 0; + for (;;) + { + if (*cp == 'n' || *cp == 's') + { + int t = *cp == 'n' ? EX_NUMERIC : EX_STRING; + type = parse_or (&(*n)->nonterm.arg[(*n)->nonterm.n]); + + if (type == EX_ERROR) + goto fail; + if (type != t) + { + msg (SE, _("Argument %d to %s was expected to be of %s type. " + "It was actually of type %s."), + (*n)->nonterm.n + 1, f->s, + *cp == 'n' ? _("numeric") : _("string"), + expr_type_name (type)); + goto fail; + } + (*n)->nonterm.n++; + } + else if (*cp == 'f') + { + /* This is always the very last argument. Also, this code + is a crock. However, it works. */ + struct fmt_spec fmt; + + if (!parse_format_specifier (&fmt, 0)) + goto fail; + if (formats[fmt.type].cat & FCAT_STRING) + { + msg (SE, _("%s is not a numeric format."), fmt_to_string (&fmt)); + goto fail; + } + (*n)->nonterm.arg[(*n)->nonterm.n + 0] = (union any_node *) fmt.type; + (*n)->nonterm.arg[(*n)->nonterm.n + 1] = (union any_node *) fmt.w; + (*n)->nonterm.arg[(*n)->nonterm.n + 2] = (union any_node *) fmt.d; + break; + } + else + assert (0); + + if (*++cp == 0) + break; + if (*cp == '/') + { + cp++; + if (lex_match (',')) + { + (*n)->nonterm.type++; + continue; + } + else + break; + } + else if (!lex_match (',')) + { + msg (SE, _("Too few arguments to function %s."), f->s); + goto fail; + } + } + + return f->desc[0] == 'n' ? EX_NUMERIC : EX_STRING; + +fail: + free_node (*n); + return EX_ERROR; +} + +/* General function parsing. */ + +static int +get_num_args (struct function *f, int num_args, union any_node **n) +{ + int t; + int i; + + *n = xmalloc (sizeof (struct nonterm_node) + + (num_args - 1) * sizeof (union any_node *)); + (*n)->nonterm.type = f->t; + (*n)->nonterm.n = 0; + for (i = 0;;) + { + t = parse_or (&(*n)->nonterm.arg[i]); + if (t == EX_ERROR) + goto fail; + (*n)->nonterm.n++; + if (t != EX_NUMERIC) + { + msg (SE, _("Type mismatch in argument %d of %s, which was expected " + "to be numeric. It was actually type %s."), + i + 1, f->s, expr_type_name (t)); + goto fail; + } + if (++i >= num_args) + return 1; + if (!lex_match (',')) + { + msg (SE, _("Missing comma following argument %d of %s."), i + 1, f->s); + goto fail; + } + } + +fail: + free_node (*n); + return 0; +} + +static int +parse_function (union any_node ** n) +{ + struct function *fp; + char fname[32], *cp; + int t; + int min_args; + struct vector *v; + + /* Check for a vector with this name. */ + v = find_vector (tokid); + if (v) + { + lex_get (); + assert (token == '('); + lex_get (); + + *n = xmalloc (sizeof (struct nonterm_node) + + sizeof (union any_node *[2])); + (*n)->nonterm.type = (v->v[0]->type == NUMERIC + ? OP_VEC_ELEM_NUM : OP_VEC_ELEM_STR); + (*n)->nonterm.n = 0; + + t = parse_or (&(*n)->nonterm.arg[0]); + if (t == EX_ERROR) + goto fail; + if (t != EX_NUMERIC) + { + msg (SE, _("The index value after a vector name must be numeric.")); + goto fail; + } + (*n)->nonterm.n++; + + if (!lex_match (')')) + { + msg (SE, _("`)' expected after a vector index value.")); + goto fail; + } + ((*n)->nonterm.arg[1]) = (union any_node *) v->index; + + return v->v[0]->type == NUMERIC ? EX_NUMERIC : EX_STRING; + } + + ds_truncate (&tokstr, 31); + strcpy (fname, ds_value (&tokstr)); + cp = strrchr (fname, '.'); + if (cp && isdigit ((unsigned char) cp[1])) + { + min_args = atoi (&cp[1]); + *cp = 0; + } + else + min_args = 0; + + lex_get (); + if (!lex_force_match ('(')) + return 0; + + { + struct function f; + f.s = fname; + + fp = bsearch (&f, func_tab, func_count, sizeof *func_tab, cmp_func); + } + + if (!fp) + { + msg (SE, _("There is no function named %s."), fname); + return 0; + } + if (min_args && fp->func != nary_num_func) + { + msg (SE, _("Function %s may not be given a minimum number of " + "arguments."), fname); + return 0; + } + t = fp->func (fp, min_args, n); + if (t == EX_ERROR) + return EX_ERROR; + if (!lex_match (')')) + { + lex_error (_("expecting `)' after %s function"), fname); + goto fail; + } + + return t; + +fail: + free_node (*n); + return EX_ERROR; +} + +#if GLOBAL_DEBUGGING +#define op(a,b,c,d) {a,b,c,d} +#else +#define op(a,b,c,d) {b,c,d} +#endif + +#define varies 0 + +struct op_desc ops[OP_SENTINEL + 1] = +{ + op ("!?ERROR?!", 000, 0, 0), + + op ("plus", 001, varies, 1), + op ("mul", 011, varies, 1), + op ("pow", 010, -1, 0), + op ("and", 010, -1, 0), + op ("or", 010, -1, 0), + op ("not", 000, 0, 0), + op ("eq", 000, -1, 0), + op ("ge", 000, -1, 0), + op ("gt", 000, -1, 0), + op ("le", 000, -1, 0), + op ("lt", 000, -1, 0), + op ("ne", 000, -1, 0), + + op ("string-eq", 000, -1, 0), + op ("string-ge", 000, -1, 0), + op ("string-gt", 000, -1, 0), + op ("string-le", 000, -1, 0), + op ("string-lt", 000, -1, 0), + op ("string-ne", 000, -1, 0), + + op ("neg", 000, 0, 0), + op ("abs", 000, 0, 0), + op ("arcos", 000, 0, 0), + op ("arsin", 000, 0, 0), + op ("artan", 000, 0, 0), + op ("cos", 000, 0, 0), + op ("exp", 000, 0, 0), + op ("lg10", 000, 0, 0), + op ("ln", 000, 0, 0), + op ("mod10", 000, 0, 0), + op ("rnd", 000, 0, 0), + op ("sin", 000, 0, 0), + op ("sqrt", 000, 0, 0), + op ("tan", 000, 0, 0), + op ("trunc", 000, 0, 0), + + op ("any", 011, varies, 1), + op ("any-string", 001, varies, 1), + op ("cfvar", 013, varies, 2), + op ("max", 013, varies, 2), + op ("mean", 013, varies, 2), + op ("min", 013, varies, 2), + op ("nmiss", 011, varies, 1), + op ("nvalid", 011, varies, 1), + op ("range", 011, varies, 1), + op ("range-string", 001, varies, 1), + op ("sd", 013, varies, 2), + op ("sum", 013, varies, 2), + op ("variance", 013, varies, 2), + + op ("time_hms", 000, -2, 0), + op ("ctime_days?!", 000, 0, 0), + op ("ctime_hours?!", 000, 0, 0), + op ("ctime_minutes?!", 000, 0, 0), + op ("ctime_seconds?!", 000, 0, 0), + op ("time_days?!", 000, 0, 0), + + op ("date_dmy", 000, -2, 0), + op ("date_mdy", 000, -2, 0), + op ("date_moyr", 000, -1, 0), + op ("date_qyr", 000, -1, 0), + op ("date_wkyr", 000, -1, 0), + op ("date_yrday", 000, -1, 0), + op ("yrmoda", 000, -2, 0), + + op ("xdate_date", 000, 0, 0), + op ("xdate_hour", 000, 0, 0), + op ("xdate_jday", 000, 0, 0), + op ("xdate_mday", 000, 0, 0), + op ("xdate_minute", 000, 0, 0), + op ("xdate_month", 000, 0, 0), + op ("xdate_quarter", 000, 0, 0), + op ("xdate_second", 000, 0, 0), + op ("xdate_tday", 000, 0, 0), + op ("xdate_time", 000, 0, 0), + op ("xdate_week", 000, 0, 0), + op ("xdate_wkday", 000, 0, 0), + op ("xdate_year", 000, 0, 0), + + op ("concat", 001, varies, 1), + op ("index-2", 000, -1, 0), + op ("index-3", 000, -2, 0), + op ("rindex-2", 000, -1, 0), + op ("rindex-3", 000, -2, 0), + op ("length", 000, 0, 0), + op ("lower", 000, 0, 0), + op ("upcas", 000, 0, 0), + op ("lpad-2", 010, -1, 0), + op ("lpad-3", 010, -2, 0), + op ("rpad-2", 010, -1, 0), + op ("rpad-3", 010, -2, 0), + op ("ltrim-1", 000, 0, 0), + op ("ltrim-2", 000, -1, 0), + op ("rtrim-1", 000, 0, 0), + op ("rtrim-2", 000, -1, 0), + op ("number-1", 010, 0, 0), + op ("number-2", 014, 0, 3), + op ("string", 004, 0, 3), + op ("substr-2", 010, -1, 0), + op ("substr-3", 010, -2, 0), + + op ("inv", 000, 0, 0), + op ("square", 000, 0, 0), + op ("num-to-Bool", 000, 0, 0), + + op ("mod", 010, -1, 0), + op ("normal", 000, 0, 0), + op ("uniform", 000, 0, 0), + op ("sysmis", 010, 0, 0), + op ("vec-elem-num", 002, 0, 1), + op ("vec-elem-str", 002, 0, 1), + + op ("!?TERMINAL?!", 000, 0, 0), + op ("num-con", 000, +1, 0), + op ("str-con", 000, +1, 0), + op ("num-var", 000, +1, 0), + op ("str-var", 000, +1, 0), + op ("num-lag", 000, +1, 1), + op ("str-lag", 000, +1, 1), + op ("num-sys", 000, +1, 1), + op ("num-val", 000, +1, 1), + op ("str-mis", 000, +1, 1), + op ("$casenum", 000, +1, 0), + op ("!?SENTINEL?!", 000, 0, 0), +}; + +#undef op +#undef varies + + +/* Utility functions. */ + +static const char * +expr_type_name (int type) +{ + switch (type) + { + case EX_ERROR: + return _("error"); + + case EX_BOOLEAN: + return _("Boolean"); + + case EX_NUMERIC: + return _("numeric"); + + case EX_STRING: + return _("string"); + + default: + assert (0); + } +#if __GNUC__ || __BORLANDC__ + return 0; +#endif +} + +static const char * +type_name (int type) +{ + switch (type) + { + case NUMERIC: + return _("numeric"); + case ALPHA: + return _("string"); + default: + assert (0); + } +#if __GNUC__ || __BORLANDC__ + return 0; +#endif +} + +static void +make_bool (union any_node **n) +{ + union any_node *c; + + c = xmalloc (sizeof (struct nonterm_node)); + c->nonterm.type = OP_NUM_TO_BOOL; + c->nonterm.n = 1; + c->nonterm.arg[0] = *n; + *n = c; +} + +void +free_node (union any_node *n) +{ + if (n->type < OP_TERMINAL) + { + int i; + + for (i = 0; i < n->nonterm.n; i++) + free_node (n->nonterm.arg[i]); + } + free (n); +} + +union any_node * +allocate_nonterminal (int op, union any_node *n) +{ + union any_node *c; + + c = xmalloc (sizeof c->nonterm); + c->nonterm.type = op; + c->nonterm.n = 1; + c->nonterm.arg[0] = n; + + return c; +} + +union any_node * +append_nonterminal_arg (union any_node *a, union any_node *b) +{ + a = xrealloc (a, sizeof *a + sizeof *a->nonterm.arg * a->nonterm.n); + a->nonterm.arg[a->nonterm.n++] = b; + return a; +} + +static struct function func_tab[] = +{ + {"ABS", OP_ABS, unary_func, NULL}, + {"ACOS", OP_ARCOS, unary_func, NULL}, + {"ARCOS", OP_ARCOS, unary_func, NULL}, + {"ARSIN", OP_ARSIN, unary_func, NULL}, + {"ARTAN", OP_ARTAN, unary_func, NULL}, + {"ASIN", OP_ARSIN, unary_func, NULL}, + {"ATAN", OP_ARTAN, unary_func, NULL}, + {"COS", OP_COS, unary_func, NULL}, + {"EXP", OP_EXP, unary_func, NULL}, + {"LG10", OP_LG10, unary_func, NULL}, + {"LN", OP_LN, unary_func, NULL}, + {"MOD10", OP_MOD10, unary_func, NULL}, + {"NORMAL", OP_NORMAL, unary_func, NULL}, + {"RND", OP_RND, unary_func, NULL}, + {"SIN", OP_SIN, unary_func, NULL}, + {"SQRT", OP_SQRT, unary_func, NULL}, + {"TAN", OP_TAN, unary_func, NULL}, + {"TRUNC", OP_TRUNC, unary_func, NULL}, + {"UNIFORM", OP_UNIFORM, unary_func, NULL}, + + {"TIME.DAYS", OP_TIME_DAYS, unary_func, NULL}, + {"TIME.HMS", OP_TIME_HMS, ternary_func, NULL}, + + {"CTIME.DAYS", OP_CTIME_DAYS, unary_func, NULL}, + {"CTIME.HOURS", OP_CTIME_HOURS, unary_func, NULL}, + {"CTIME.MINUTES", OP_CTIME_MINUTES, unary_func, NULL}, + {"CTIME.SECONDS", OP_CTIME_SECONDS, unary_func, NULL}, + + {"DATE.DMY", OP_DATE_DMY, ternary_func, NULL}, + {"DATE.MDY", OP_DATE_MDY, ternary_func, NULL}, + {"DATE.MOYR", OP_DATE_MOYR, binary_func, NULL}, + {"DATE.QYR", OP_DATE_QYR, binary_func, NULL}, + {"DATE.WKYR", OP_DATE_WKYR, binary_func, NULL}, + {"DATE.YRDAY", OP_DATE_YRDAY, binary_func, NULL}, + + {"XDATE.DATE", OP_XDATE_DATE, unary_func, NULL}, + {"XDATE.HOUR", OP_XDATE_HOUR, unary_func, NULL}, + {"XDATE.JDAY", OP_XDATE_JDAY, unary_func, NULL}, + {"XDATE.MDAY", OP_XDATE_MDAY, unary_func, NULL}, + {"XDATE.MINUTE", OP_XDATE_MINUTE, unary_func, NULL}, + {"XDATE.MONTH", OP_XDATE_MONTH, unary_func, NULL}, + {"XDATE.QUARTER", OP_XDATE_QUARTER, unary_func, NULL}, + {"XDATE.SECOND", OP_XDATE_SECOND, unary_func, NULL}, + {"XDATE.TDAY", OP_XDATE_TDAY, unary_func, NULL}, + {"XDATE.TIME", OP_XDATE_TIME, unary_func, NULL}, + {"XDATE.WEEK", OP_XDATE_WEEK, unary_func, NULL}, + {"XDATE.WKDAY", OP_XDATE_WKDAY, unary_func, NULL}, + {"XDATE.YEAR", OP_XDATE_YEAR, unary_func, NULL}, + + {"MISSING", OP_SYSMIS, MISSING_func, NULL}, + {"MOD", OP_MOD, binary_func, NULL}, + {"SYSMIS", OP_SYSMIS, SYSMIS_func, NULL}, + {"VALUE", OP_NUM_VAL, VALUE_func, NULL}, + {"LAG", OP_NUM_LAG, LAG_func, NULL}, + {"YRMODA", OP_YRMODA, ternary_func, NULL}, + + {"ANY", OP_ANY, nary_num_func, NULL}, + {"CFVAR", OP_CFVAR, nary_num_func, NULL}, + {"MAX", OP_MAX, nary_num_func, NULL}, + {"MEAN", OP_MEAN, nary_num_func, NULL}, + {"MIN", OP_MIN, nary_num_func, NULL}, + {"NMISS", OP_NMISS, nary_num_func, NULL}, + {"NVALID", OP_NVALID, nary_num_func, NULL}, + {"RANGE", OP_RANGE, nary_num_func, NULL}, + {"SD", OP_SD, nary_num_func, NULL}, + {"SUM", OP_SUM, nary_num_func, NULL}, + {"VARIANCE", OP_VARIANCE, nary_num_func, NULL}, + + {"CONCAT", OP_CONCAT, CONCAT_func, NULL}, + {"INDEX", OP_INDEX, generic_str_func, "nss/n"}, + {"RINDEX", OP_RINDEX, generic_str_func, "nss/n"}, + {"LENGTH", OP_LENGTH, generic_str_func, "ns"}, + {"LOWER", OP_LOWER, generic_str_func, "ss"}, + {"UPCAS", OP_UPPER, generic_str_func, "ss"}, + {"LPAD", OP_LPAD, generic_str_func, "ssn/s"}, + {"RPAD", OP_RPAD, generic_str_func, "ssn/s"}, + {"LTRIM", OP_LTRIM, generic_str_func, "ss/s"}, + {"RTRIM", OP_RTRIM, generic_str_func, "ss/s"}, + {"NUMBER", OP_NUMBER, generic_str_func, "ns/f"}, + {"STRING", OP_STRING, generic_str_func, "snf"}, + {"SUBSTR", OP_SUBSTR, generic_str_func, "ssn/n"}, +}; + +static int +cmp_func (const void *a, const void *b) +{ + return strcmp (*(char **) a, *(char **) b); +} + +static void +init_func_tab (void) +{ + { + static int inited; + + if (inited) + return; + inited = 1; + } + + func_count = sizeof func_tab / sizeof *func_tab; + qsort (func_tab, func_count, sizeof *func_tab, cmp_func); +} + +/* Debug output. */ + +#if DEBUGGING +static void +print_type (union any_node * n) +{ + const char *s; + size_t len; + + s = ops[n->type].name; + len = strlen (s); + if (ops[n->type].flags & OP_MIN_ARGS) + printf ("%s.%d\n", s, (int) n->nonterm.arg[n->nonterm.n]); + else if (ops[n->type].flags & OP_FMT_SPEC) + { + struct fmt_spec f; + + f.type = (int) n->nonterm.arg[n->nonterm.n + 0]; + f.w = (int) n->nonterm.arg[n->nonterm.n + 1]; + f.d = (int) n->nonterm.arg[n->nonterm.n + 2]; + printf ("%s(%s)\n", s, fmt_to_string (&f)); + } + else + printf ("%s\n", s); +} + +static void +debug_print_tree (union any_node * n, int level) +{ + int i; + for (i = 0; i < level; i++) + printf (" "); + if (n->type < OP_TERMINAL) + { + print_type (n); + for (i = 0; i < n->nonterm.n; i++) + debug_print_tree (n->nonterm.arg[i], level + 1); + } + else + { + switch (n->type) + { + case OP_TERMINAL: + printf (_("!!TERMINAL!!")); + break; + case OP_NUM_CON: + if (n->num_con.value == SYSMIS) + printf ("SYSMIS"); + else + printf ("%f", n->num_con.value); + break; + case OP_STR_CON: + printf ("\"%.*s\"", n->str_con.len, n->str_con.s); + break; + case OP_NUM_VAR: + case OP_STR_VAR: + printf ("%s", n->var.v->name); + break; + case OP_NUM_LAG: + case OP_STR_LAG: + printf ("LAG(%s,%d)", n->lag.v->name, n->lag.lag); + break; + case OP_NUM_SYS: + printf ("SYSMIS(%s)", n->var.v->name); + break; + case OP_NUM_VAL: + printf ("VALUE(%s)", n->var.v->name); + break; + case OP_SENTINEL: + printf (_("!!SENTINEL!!")); + break; + default: + printf (_("!!ERROR%d!!"), n->type); + assert (0); + } + printf ("\n"); + } +} +#endif /* DEBUGGING */ + +#if GLOBAL_DEBUGGING +static void +debug_print_postfix (struct expression * e) +{ + unsigned char *o; + double *num = e->num; + unsigned char *str = e->str; + struct variable **v = e->var; + int t; + + debug_printf ((_("postfix:"))); + for (o = e->op; *o != OP_SENTINEL;) + { + t = *o++; + if (t < OP_TERMINAL) + { + debug_printf ((" %s", ops[t].name)); + + if (ops[t].flags & OP_VAR_ARGS) + { + debug_printf (("(%d)", *o)); + o++; + } + if (ops[t].flags & OP_MIN_ARGS) + { + debug_printf ((".%d", *o)); + o++; + } + if (ops[t].flags & OP_FMT_SPEC) + { + struct fmt_spec f; + f.type = (int) *o++; + f.w = (int) *o++; + f.d = (int) *o++; + debug_printf (("(%s)", fmt_to_string (&f))); + } + } + else if (t == OP_NUM_CON) + { + if (*num == SYSMIS) + debug_printf ((" SYSMIS")); + else + debug_printf ((" %f", *num)); + num++; + } + else if (t == OP_STR_CON) + { + debug_printf ((" \"%.*s\"", *str, &str[1])); + str += str[0] + 1; + } + else if (t == OP_NUM_VAR || t == OP_STR_VAR) + { + debug_printf ((" %s", (*v)->name)); + v++; + } + else if (t == OP_NUM_SYS) + { + debug_printf ((" SYSMIS(#%d)", *o)); + o++; + } + else if (t == OP_NUM_VAL) + { + debug_printf ((" VALUE(#%d)", *o)); + o++; + } + else if (t == OP_NUM_LAG || t == OP_STR_LAG) + { + debug_printf ((" LAG(%s,%d)", (*v)->name, *o)); + o++; + v++; + } + else + { + printf ("debug_print_postfix(): %d\n", t); + assert (0); + } + } + debug_putc ('\n', stdout); +} +#endif /* GLOBAL_DEBUGGING */ diff --git a/src/expr.h b/src/expr.h new file mode 100644 index 00000000..30824966 --- /dev/null +++ b/src/expr.h @@ -0,0 +1,44 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !expr_h +#define expr_h 1 + +/* Expression parsing flags. */ +enum + { + PXP_NONE = 000, /* No flags. */ + PXP_DUMP = 001, /* Dump postfix representation to screen; + only for use by EVALUATE. */ + + /* Specify expression type. */ + PXP_BOOLEAN = 002, /* Coerce return value to Boolean. */ + PXP_NUMERIC = 004, /* Must be numeric result type. */ + PXP_STRING = 010 /* Must be string result type. */ + }; + +struct expression; +struct ccase; +union value; + +struct expression *expr_parse (int flags); +double expr_evaluate (struct expression *, struct ccase *, union value *); +void expr_free (struct expression *); + +#endif /* expr.h */ diff --git a/src/exprP.h b/src/exprP.h new file mode 100644 index 00000000..873f0ce7 --- /dev/null +++ b/src/exprP.h @@ -0,0 +1,296 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !exprP_h +#define exprP_h 1 + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if GLOBAL_DEBUGGING +void debug_print_expr (struct expression *); +void debug_print_op (short int *); +#endif + +/* Expression types. */ +enum + { + EX_ERROR, /* Error value for propagation. */ + EX_BOOLEAN, /* Numeric value that's 0, 1, or SYSMIS. */ + EX_NUMERIC, /* Numeric value. */ + EX_STRING /* String value. */ + }; + +/* Expression operators. + The ordering below is important. Do not change it. */ +enum + { + OP_ERROR, + + /* Basic operators. */ + OP_PLUS, + OP_MUL, + OP_POW, + OP_AND, + OP_OR, + OP_NOT, + + /* Numeric relational operators. */ + OP_EQ, + OP_GE, + OP_GT, + OP_LE, + OP_LT, + OP_NE, + + /* String relational operators. */ + OP_STRING_EQ, + OP_STRING_GE, + OP_STRING_GT, + OP_STRING_LE, + OP_STRING_LT, + OP_STRING_NE, + + /* Unary functions. */ + OP_NEG, + OP_ABS, + OP_ARCOS, + OP_ARSIN, + OP_ARTAN, + OP_COS, + OP_EXP, + OP_LG10, + OP_LN, + OP_MOD10, + OP_RND, + OP_SIN, + OP_SQRT, + OP_TAN, + OP_TRUNC, + + /* N-ary numeric functions. */ + OP_ANY, + OP_ANY_STRING, + OP_CFVAR, + OP_MAX, + OP_MEAN, + OP_MIN, + OP_NMISS, + OP_NVALID, + OP_RANGE, + OP_RANGE_STRING, + OP_SD, + OP_SUM, + OP_VARIANCE, + + /* Time construction & extraction functions. */ + OP_TIME_HMS, + + /* These never appear in a tree or an expression. + They disappear in parse.c:unary_func(). */ + OP_CTIME_DAYS, + OP_CTIME_HOURS, + OP_CTIME_MINUTES, + OP_CTIME_SECONDS, + OP_TIME_DAYS, + + /* Date construction functions. */ + OP_DATE_DMY, + OP_DATE_MDY, + OP_DATE_MOYR, + OP_DATE_QYR, + OP_DATE_WKYR, + OP_DATE_YRDAY, + OP_YRMODA, + + /* Date extraction functions. */ + OP_XDATE_DATE, + OP_XDATE_HOUR, + OP_XDATE_JDAY, + OP_XDATE_MDAY, + OP_XDATE_MINUTE, + OP_XDATE_MONTH, + OP_XDATE_QUARTER, + OP_XDATE_SECOND, + OP_XDATE_TDAY, + OP_XDATE_TIME, + OP_XDATE_WEEK, + OP_XDATE_WKDAY, + OP_XDATE_YEAR, + + /* String functions. */ + OP_CONCAT, + OP_INDEX, + OP_INDEX_OPT, + OP_RINDEX, + OP_RINDEX_OPT, + OP_LENGTH, + OP_LOWER, + OP_UPPER, + OP_LPAD, + OP_LPAD_OPT, + OP_RPAD, + OP_RPAD_OPT, + OP_LTRIM, + OP_LTRIM_OPT, + OP_RTRIM, + OP_RTRIM_OPT, + OP_NUMBER, + OP_NUMBER_OPT, + OP_STRING, + OP_SUBSTR, + OP_SUBSTR_OPT, + + /* Artificial. */ + OP_INV, /* Reciprocal. */ + OP_SQUARE, /* Squares the argument. */ + OP_NUM_TO_BOOL, /* Converts ~0=>0, ~1=>1, SYSMIS=>SYSMIS, + others=>0 with a warning. */ + + /* Weirdness. */ + OP_MOD, /* Modulo function. */ + OP_NORMAL, /* Normally distributed PRNG. */ + OP_UNIFORM, /* Uniformly distributed PRNG. */ + OP_SYSMIS, /* Tests whether for SYSMIS argument. */ + OP_VEC_ELEM_NUM, /* Element of a numeric vector. */ + OP_VEC_ELEM_STR, /* Element of a string vector. */ + + /* Terminals. */ + OP_TERMINAL, /* Not a valid type. Boundary + between terminals and nonterminals. */ + + OP_NUM_CON, /* Numeric constant. */ + OP_STR_CON, /* String literal. */ + OP_NUM_VAR, /* Numeric variable reference. */ + OP_STR_VAR, /* String variable reference. */ + OP_NUM_LAG, /* Numeric variable from an earlier case. */ + OP_STR_LAG, /* String variable from an earlier case. */ + OP_NUM_SYS, /* SYSMIS(numvar). */ + OP_NUM_VAL, /* VALUE(numvar). */ + OP_STR_MIS, /* MISSING(strvar). */ + OP_CASENUM, /* $CASENUM. */ + OP_SENTINEL /* Sentinel. */ + }; + +/* Flags that describe operators. */ +enum + { + OP_VAR_ARGS = 001, /* 1=Variable number of args. */ + OP_MIN_ARGS = 002, /* 1=Can specific min args with .X. */ + OP_FMT_SPEC = 004, /* 1=Includes a format specifier. */ + OP_ABSORB_MISS = 010, /* 1=May return other than SYSMIS if + given a SYSMIS argument. */ + }; + +/* Describes an operator. */ +struct op_desc + { +#if GLOBAL_DEBUGGING + const char *name; /* Operator name. */ +#endif + unsigned char flags; /* Flags. */ + signed char height; /* Effect on stack height. */ + unsigned char skip; /* Number of operator item arguments. */ + }; + +extern struct op_desc ops[]; + +/* Tree structured expressions. */ + +/* Numeric constant. */ +struct num_con_node + { + int type; /* Always OP_NUM_CON. */ + double value; /* Numeric value. */ + }; + +/* String literal. */ +struct str_con_node + { + int type; /* Always OP_STR_CON. */ + int len; /* Length of string. */ + char s[1]; /* String value. */ + }; + +/* Variable or test for missing values or cancellation of + user-missing. */ +struct var_node + { + int type; /* OP_NUM_VAR, OP_NUM_SYS, OP_NUM_VAL, + OP_STR_MIS, or OP_STR_VAR. */ + struct variable *v; /* Variable. */ + }; + +/* Variable from an earlier case. */ +struct lag_node + { + int type; /* Always OP_NUM_LAG. */ + struct variable *v; /* Relevant variable. */ + int lag; /* Number of cases to lag. */ + }; + +/* $CASENUM. */ +struct casenum_node + { + int type; /* Always OP_CASENUM. */ + }; + +/* Any nonterminal node. */ +struct nonterm_node + { + int type; /* Always greater than OP_TERMINAL. */ + int n; /* Number of arguments. */ + union any_node *arg[1]; /* Arguments. */ + }; + +/* Any node. */ +union any_node + { + int type; + struct nonterm_node nonterm; + struct num_con_node num_con; + struct str_con_node str_con; + struct var_node var; + struct lag_node lag; + struct casenum_node casenum; + }; + +/* An expression. */ +struct expression + { + int type; /* Type of expression result. */ + unsigned char *op; /* Operators. */ + struct variable **var; /* Variables. */ + double *num; /* Numeric operands. */ + unsigned char *str; /* String operands. */ + union value *stack; /* Evaluation stack. */ + unsigned char *str_stack; /* String evaluation stack. */ +#if !PAGED_STACK + size_t str_size; /* Size of string eval stack. */ +#endif + }; + +struct nonterm_node *optimize_expression (struct nonterm_node *); +void dump_expression (union any_node *, struct expression *); +void free_node (union any_node *); + +double yrmoda (double year, double month, double day); + +#endif /* exprP.h */ diff --git a/src/file-handle.h b/src/file-handle.h new file mode 100644 index 00000000..34a85953 --- /dev/null +++ b/src/file-handle.h @@ -0,0 +1,99 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !file_handle_h +#define file_handle_h 1 + +/* File handle provider (fhp). + + This module provides file handles in the form of file_handle + structures to the dfm and sfm modules, which are known as file + handle users (fhusers). fhp does not know anything about file + contents. */ + +#include +#include "error.h" + +/* Record formats. */ +enum + { + FH_RF_FIXED, /* Fixed length records. */ + FH_RF_VARIABLE, /* Variable length records. */ + FH_RF_SPANNED /* ? */ + }; + +/* File modes. */ +enum + { + FH_MD_CHARACTER, /* Character data. */ + FH_MD_IMAGE, /* ? */ + FH_MD_BINARY, /* Character and/or binary data. */ + FH_MD_MULTIPUNCH, /* Column binary data (not supported). */ + FH_MD_360 /* ? */ + }; + +struct file_handle; + +/* Services that fhusers provide to fhp. */ +struct fh_ext_class + { + int magic; /* Magic identifier for fhuser. */ + const char *name; /* String identifier for fhuser. */ + + void (*close) (struct file_handle *); + /* Closes any associated file, etc. */ + }; + +/* Opaque structure. The `ext' member is an exception for use by + subclasses. `where.ln' is also acceptable. */ +struct file_handle + { + /* name must be the first member. */ + const char *name; /* File handle identifier. */ + char *norm_fn; /* Normalized filename. */ + char *fn; /* Filename as provided by user. */ + struct file_locator where; /* Used for reporting error messages. */ + + int recform; /* One of FH_RF_*. */ + size_t lrecl; /* Length of records for FH_RF_FIXED. */ + int mode; /* One of FH_MD_*. */ + + struct fh_ext_class *class; /* Polymorphism support. */ + void *ext; /* Extension struct for fhuser use. */ + }; + +/* All the file handles in the system. */ +extern struct avl_tree *files; + +/* Pointer to the file handle that corresponds to data in the command + file entered via BEGIN DATA/END DATA. */ +extern struct file_handle *inline_file; + +/* Opening and closing handles. */ +struct file_handle *fh_get_handle_by_name (const char name[9]); +struct file_handle *fh_get_handle_by_filename (const char *filename); +struct file_handle *fh_parse_file_handle (void); +void fh_close_handle (struct file_handle *handle); + +/* Handle info. */ +const char *fh_handle_name (struct file_handle *handle); +char *fh_handle_filename (struct file_handle *handle); +size_t fh_record_width (struct file_handle *handle); + +#endif /* !file_handle.h */ diff --git a/src/file-handle.q b/src/file-handle.q new file mode 100644 index 00000000..309c4097 --- /dev/null +++ b/src/file-handle.q @@ -0,0 +1,362 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "filename.h" +#include "file-handle.h" +#include "command.h" +#include "lexer.h" +#include "getline.h" +#include "error.h" +#include "magic.h" +#include "var.h" +/* (headers) */ + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +avl_tree *files; +struct file_handle *inline_file; + +static void init_file_handle (struct file_handle * handle); + +/* (specification) + "FILE HANDLE" (fh_): + name=string; + recform=recform:fixed/!variable/spanned; + lrecl=integer; + mode=mode:!character/image/binary/multipunch/_360. +*/ +/* (declarations) */ +/* (functions) */ + +int +cmd_file_handle (void) +{ + char handle_name[9]; + char *handle_name_p = handle_name; + + struct cmd_file_handle cmd; + struct file_handle *fp; + + lex_get (); + if (!lex_force_id ()) + return CMD_FAILURE; + strcpy (handle_name, tokid); + + fp = NULL; + if (files) + fp = avl_find (files, &handle_name_p); + if (fp) + { + msg (SE, _("File handle %s had already been defined to refer to " + "file %s. It is not possible to redefine a file " + "handle within a session."), + tokid, fp->fn); + return CMD_FAILURE; + } + + lex_get (); + if (!lex_force_match ('/')) + return CMD_FAILURE; + + if (!parse_file_handle (&cmd)) + return CMD_FAILURE; + + if (token != '.') + { + lex_error (_("expecting end of command")); + goto lossage; + } + + if (cmd.s_name == NULL) + { + msg (SE, _("The FILE HANDLE required subcommand NAME " + "is not present.")); + goto lossage; + } + + fp = xmalloc (sizeof *fp); + init_file_handle (fp); + + switch (cmd.recform) + { + case FH_FIXED: + if (cmd.n_lrecl == NOT_LONG) + { + msg (SE, _("Fixed length records were specified on /RECFORM, but " + "record length was not specified on /LRECL. 80-character " + "records will be assumed.")); + cmd.n_lrecl = 80; + } + else if (cmd.n_lrecl < 1) + { + msg (SE, _("Record length (%ld) must be at least one byte. " + "80-character records will be assumed."), cmd.n_lrecl); + cmd.n_lrecl = 80; + } + fp->recform = FH_RF_FIXED; + fp->lrecl = cmd.n_lrecl; + break; + case FH_VARIABLE: + fp->recform = FH_RF_VARIABLE; + break; + case FH_SPANNED: + msg (SE, _("/RECFORM SPANNED is not implemented, as the author doesn't " + "know what it is supposed to do. Send the author a note.")); + break; + default: + assert (0); + } + + switch (cmd.mode) + { + case FH_CHARACTER: + fp->mode = FH_MD_CHARACTER; + break; + case FH_IMAGE: + msg (SE, _("/MODE IMAGE is not implemented, as the author doesn't know " + "what it is supposed to do. Send the author a note.")); + break; + case FH_BINARY: + fp->mode = FH_MD_BINARY; + break; + case FH_MULTIPUNCH: + msg (SE, _("/MODE MULTIPUNCH is not implemented. If you care, " + "complain.")); + break; + case FH__360: + msg (SE, _("/MODE 360 is not implemented. If you care, complain.")); + break; + default: + assert (0); + } + + fp->name = xstrdup (handle_name); + fp->norm_fn = fn_normalize (cmd.s_name); + fp->where.filename = fp->fn = cmd.s_name; + avl_force_insert (files, fp); + + return CMD_SUCCESS; + + lossage: + free_file_handle (&cmd); + return CMD_FAILURE; +} + +/* File handle functions. */ + +/* Sets up some fields in H; caller should fill in + H->{NAME,NORM_FN,FN}. */ +static void +init_file_handle (struct file_handle *h) +{ + h->recform = FH_RF_VARIABLE; + h->mode = FH_MD_CHARACTER; + h->ext = NULL; + h->class = NULL; +} + +/* Returns the handle corresponding to FILENAME. Creates the handle + if no handle exists for that file. All filenames are normalized + first, so different filenames referring to the same file will + return the same file handle. */ +struct file_handle * +fh_get_handle_by_filename (const char *filename) +{ + struct file_handle f, *fp; + char *fn; + char *name; + int len; + + /* Get filename. */ + fn = fn_normalize (filename); + len = strlen (fn); + + /* Create handle name with invalid identifier character to prevent + conflicts with handles created with FILE HANDLE. */ + name = xmalloc (len + 2); + name[0] = '*'; + strcpy (&name[1], fn); + + f.name = name; + fp = avl_find (files, &f); + if (!fp) + { + fp = xmalloc (sizeof *fp); + init_file_handle (fp); + fp->name = name; + fp->norm_fn = fn; + fp->where.filename = fp->fn = xstrdup (filename); + avl_force_insert (files, fp); + } + else + { + free (fn); + free (name); + } + return fp; +} + +/* Returns the handle with identifier NAME, if it exists; otherwise + reports error to user and returns NULL. */ +struct file_handle * +fh_get_handle_by_name (const char name[9]) +{ + struct file_handle f, *fp; + f.name = (char *) name; + fp = avl_find (files, &f); + + if (!fp) + msg (SE, _("File handle `%s' has not been previously declared on " + "FILE HANDLE."), name); + return fp; +} + +/* Returns the identifier of file HANDLE. If HANDLE was created by + referring to a filename (i.e., DATA LIST FILE='yyy' instead of FILE + HANDLE XXX='yyy'), returns the filename, enclosed in double quotes. + Return value is in a static buffer. + + Useful for printing error messages about use of file handles. */ +const char * +fh_handle_name (struct file_handle *h) +{ + static char *buf = NULL; + + if (buf) + { + free (buf); + buf = NULL; + } + if (!h) + return NULL; + + if (h->name[0] == '*') + { + int len = strlen (h->fn); + + buf = xmalloc (len + 3); + strcpy (&buf[1], h->fn); + buf[0] = buf[len + 1] = '"'; + buf[len + 2] = 0; + return buf; + } + return h->name; +} + +/* Closes the stdio FILE associated with handle H. Frees internal + buffers associated with that file. Does *not* destroy the file + handle H. (File handles are permanent during a session.) */ +void +fh_close_handle (struct file_handle *h) +{ + if (h == NULL) + return; + + debug_printf (("Closing %s%s.\n", fh_handle_name (h), + h->class == NULL ? " (already closed)" : "")); + + if (h->class) + h->class->close (h); + h->class = NULL; + h->ext = NULL; +} + +/* Compares names of file handles A and B. */ +static int +cmp_file_handle (const void *a, const void *b, void *foo unused) +{ + return strcmp (((struct file_handle *) a)->name, + ((struct file_handle *) b)->name); +} + +/* Initialize the AVL tree of file handles; inserts the "inline file" + inline_file. */ +void +fh_init_files (void) +{ + /* Create AVL tree. */ + files = avl_create (NULL, cmp_file_handle, NULL); + + /* Insert inline file. */ + inline_file = xmalloc (sizeof *inline_file); + init_file_handle (inline_file); + inline_file->name = "INLINE"; + inline_file->where.filename + = inline_file->fn = inline_file->norm_fn = (char *) _(""); + inline_file->where.line_number = 0; + avl_force_insert (files, inline_file); +} + +/* Parses a file handle name, which may be a filename as a string or + a file handle name as an identifier. Returns the file handle or + NULL on failure. */ +struct file_handle * +fh_parse_file_handle (void) +{ + struct file_handle *handle; + + if (token == T_ID) + handle = fh_get_handle_by_name (tokid); + else if (token == T_STRING) + handle = fh_get_handle_by_filename (ds_value (&tokstr)); + else + { + lex_error (_("expecting a file name or handle")); + return NULL; + } + + if (!handle) + return NULL; + lex_get (); + + return handle; +} + +/* Returns the (normalized) filename associated with file handle H. */ +char * +fh_handle_filename (struct file_handle * h) +{ + return h->norm_fn; +} + +/* Returns the width of a logical record on file handle H. */ +size_t +fh_record_width (struct file_handle *h) +{ + if (h == inline_file) + return 80; + else if (h->recform == FH_RF_FIXED) + return h->lrecl; + else + return 1024; +} + +/* + Local variables: + mode: c + End: +*/ diff --git a/src/file-type.c b/src/file-type.c new file mode 100644 index 00000000..3400c8a0 --- /dev/null +++ b/src/file-type.c @@ -0,0 +1,729 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "command.h" +#include "data-in.h" +#include "dfm.h" +#include "file-handle.h" +#include "format.h" +#include "lexer.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +/* Defines the three types of complex files read by FILE TYPE. */ +enum + { + FTY_MIXED, + FTY_GROUPED, + FTY_NESTED + }; + +/* Limited variable column specifications. */ +struct col_spec + { + char name[9]; /* Variable name. */ + int fc, nc; /* First column (1-based), # of columns. */ + int fmt; /* Format type. */ + struct variable *v; /* Variable. */ + }; + +/* RCT_* record type constants. */ +enum + { + RCT_OTHER = 001, /* 1=OTHER. */ + RCT_SKIP = 002, /* 1=SKIP. */ + RCT_DUPLICATE = 004, /* DUPLICATE: 0=NOWARN, 1=WARN. */ + RCT_MISSING = 010, /* MISSING: 0=NOWARN, 1=WARN. */ + RCT_SPREAD = 020 /* SPREAD: 0=NO, 1=YES. */ + }; + +/* Represents a RECORD TYPE command. */ +struct record_type + { + struct record_type *next; + unsigned flags; /* RCT_* constants. */ + union value *v; /* Vector of values for this record type. */ + int nv; /* Length of vector V. */ + struct col_spec case_sbc; /* CASE subcommand. */ + int ft, lt; /* First, last transformation index. */ + }; /* record_type */ + +/* Represents a FILE TYPE input program. Does not contain a + trns_header because it's never submitted as a transformation. */ +struct file_type_pgm + { + int type; /* One of the FTY_* constants. */ + struct file_handle *handle; /* File handle of input file. */ + struct col_spec record; /* RECORD subcommand. */ + struct col_spec case_sbc; /* CASE subcommand. */ + int wild; /* 0=NOWARN, 1=WARN. */ + int duplicate; /* 0=NOWARN, 1=WARN. */ + int missing; /* 0=NOWARN, 1=WARN, 2=CASE. */ + int ordered; /* 0=NO, 1=YES. */ + int had_rec_type; /* 1=Had a RECORD TYPE command. + RECORD TYPE must precede the first + DATA LIST. */ + struct record_type *recs_head; /* List of record types. */ + struct record_type *recs_tail; /* Last in list of record types. */ + }; + +/* Current FILE TYPE input program. */ +static struct file_type_pgm fty; + +static int parse_col_spec (struct col_spec *, const char *); +static void create_col_var (struct col_spec *c); + +/* Parses FILE TYPE command. */ +int +cmd_file_type (void) +{ + /* Initialize. */ + discard_variables (); + fty.handle = inline_file; + fty.record.name[0] = 0; + fty.case_sbc.name[0] = 0; + fty.wild = fty.duplicate = fty.missing = fty.ordered = 0; + fty.had_rec_type = 0; + fty.recs_head = fty.recs_tail = NULL; + + lex_match_id ("TYPE"); + if (lex_match_id ("MIXED")) + fty.type = FTY_MIXED; + else if (lex_match_id ("GROUPED")) + { + fty.type = FTY_GROUPED; + fty.wild = 1; + fty.duplicate = 1; + fty.missing = 1; + fty.ordered = 1; + } + else if (lex_match_id ("NESTED")) + fty.type = FTY_NESTED; + else + { + msg (SE, _("MIXED, GROUPED, or NESTED expected.")); + return CMD_FAILURE; + } + + while (token != '.') + { + if (lex_match_id ("FILE")) + { + lex_match ('='); + fty.handle = fh_parse_file_handle (); + if (!fty.handle) + return CMD_FAILURE; + } + else if (lex_match_id ("RECORD")) + { + lex_match ('='); + if (!parse_col_spec (&fty.record, "####RECD")) + return CMD_FAILURE; + } + else if (lex_match_id ("CASE")) + { + if (fty.type == FTY_MIXED) + { + msg (SE, _("The CASE subcommand is not valid on FILE TYPE " + "MIXED.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (!parse_col_spec (&fty.case_sbc, "####CASE")) + return CMD_FAILURE; + } + else if (lex_match_id ("WILD")) + { + lex_match ('='); + if (lex_match_id ("WARN")) + fty.wild = 1; + else if (lex_match_id ("NOWARN")) + fty.wild = 0; + else + { + msg (SE, _("WARN or NOWARN expected after WILD.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("DUPLICATE")) + { + if (fty.type == FTY_MIXED) + { + msg (SE, _("The DUPLICATE subcommand is not valid on " + "FILE TYPE MIXED.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (lex_match_id ("WARN")) + fty.duplicate = 1; + else if (lex_match_id ("NOWARN")) + fty.duplicate = 0; + else if (lex_match_id ("CASE")) + { + if (fty.type != FTY_NESTED) + { + msg (SE, _("DUPLICATE=CASE is only valid on " + "FILE TYPE NESTED.")); + return CMD_FAILURE; + } + + fty.duplicate = 2; + } + else + { + msg (SE, _("WARN%s expected after DUPLICATE."), + (fty.type == FTY_NESTED ? _(", NOWARN, or CASE") + : _(" or NOWARN"))); + return CMD_FAILURE; + } + } + else if (lex_match_id ("MISSING")) + { + if (fty.type == FTY_MIXED) + { + msg (SE, _("The MISSING subcommand is not valid on " + "FILE TYPE MIXED.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (lex_match_id ("NOWARN")) + fty.missing = 0; + else if (lex_match_id ("WARN")) + fty.missing = 1; + else + { + msg (SE, _("WARN or NOWARN after MISSING.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("ORDERED")) + { + if (fty.type != FTY_GROUPED) + { + msg (SE, _("ORDERED is only valid on FILE TYPE GROUPED.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (lex_match_id ("YES")) + fty.ordered = 1; + else if (lex_match_id ("NO")) + fty.ordered = 0; + else + { + msg (SE, _("YES or NO expected after ORDERED.")); + return CMD_FAILURE; + } + } + else + { + lex_error (_("while expecting a valid subcommand")); + return CMD_FAILURE; + } + } + + if (fty.record.name[0] == 0) + { + msg (SE, _("The required RECORD subcommand was not present.")); + return CMD_FAILURE; + } + + if (fty.type == FTY_GROUPED) + { + if (fty.case_sbc.name[0] == 0) + { + msg (SE, _("The required CASE subcommand was not present.")); + return CMD_FAILURE; + } + + if (!strcmp (fty.case_sbc.name, fty.record.name)) + { + msg (SE, _("CASE and RECORD must specify different variable " + "names.")); + return CMD_FAILURE; + } + } + + default_handle = fty.handle; + + vfm_source = &file_type_source; + create_col_var (&fty.record); + if (fty.case_sbc.name[0]) + create_col_var (&fty.case_sbc); + + return CMD_SUCCESS; +} + +/* Creates a variable with attributes specified by struct col_spec C, and + stores it into C->V. */ +static void +create_col_var (struct col_spec *c) +{ + int type; + int width; + + type = (formats[c->fmt].cat & FCAT_STRING) ? ALPHA : NUMERIC; + if (type == ALPHA) + width = c->nc; + else + width = 0; + c->v = force_create_variable (&default_dict, c->name, type, width); +} + +/* Parses variable, column, type specifications for a variable. */ +static int +parse_col_spec (struct col_spec *c, const char *def_name) +{ + struct fmt_spec spec; + + if (token == T_ID) + { + strcpy (c->name, tokid); + lex_get (); + } + else + strcpy (c->name, def_name); + + if (!lex_force_int ()) + return 0; + c->fc = lex_integer (); + if (c->fc < 1) + { + msg (SE, _("Column value must be positive.")); + return 0; + } + lex_get (); + + lex_negative_to_dash (); + if (lex_match ('-')) + { + if (!lex_force_int ()) + return 0; + c->nc = lex_integer (); + lex_get (); + + if (c->nc < c->fc) + { + msg (SE, _("Ending column precedes beginning column.")); + return 0; + } + + c->nc -= c->fc - 1; + } + else + c->nc = 1; + + if (lex_match ('(')) + { + const char *cp; + if (!lex_force_id ()) + return 0; + c->fmt = parse_format_specifier_name (&cp, 0); + if (c->fmt == -1) + return 0; + if (*cp) + { + msg (SE, _("Bad format specifier name.")); + return 0; + } + lex_get (); + if (!lex_force_match (')')) + return 0; + } + else + c->fmt = FMT_F; + + spec.type = c->fmt; + spec.w = c->nc; + spec.d = 0; + return check_input_specifier (&spec); +} + +/* RECORD TYPE. */ + +/* Structure being filled in by internal_cmd_record_type. */ +static struct record_type rct; + +static int internal_cmd_record_type (void); + +/* Parse the RECORD TYPE command. */ +int +cmd_record_type (void) +{ + int result = internal_cmd_record_type (); + + if (result == CMD_FAILURE) + { + int i; + + if (formats[fty.record.fmt].cat & FCAT_STRING) + for (i = 0; i < rct.nv; i++) + free (rct.v[i].c); + free (rct.v); + } + + return result; +} + +static int +internal_cmd_record_type (void) +{ + /* Initialize the record_type structure. */ + rct.next = NULL; + rct.flags = 0; + if (fty.duplicate) + rct.flags |= RCT_DUPLICATE; + if (fty.missing) + rct.flags |= RCT_MISSING; + rct.v = NULL; + rct.nv = 0; + rct.ft = n_trns; + if (fty.case_sbc.name[0]) + rct.case_sbc = fty.case_sbc; +#if __CHECKER__ + else + memset (&rct.case_sbc, 0, sizeof rct.case_sbc); + rct.lt = -1; +#endif + + /* Make sure we're inside a FILE TYPE structure. */ + if (pgm_state != STATE_INPUT || vfm_source != &file_type_source) + { + msg (SE, _("This command may only appear within a " + "FILE TYPE/END FILE TYPE structure.")); + return CMD_FAILURE; + } + + if (fty.recs_tail && (fty.recs_tail->flags & RCT_OTHER)) + { + msg (SE, _("OTHER may appear only on the last RECORD TYPE command.")); + return CMD_FAILURE; + } + + if (fty.recs_tail) + { + fty.recs_tail->lt = n_trns - 1; + if (!(fty.recs_tail->flags & RCT_SKIP) + && fty.recs_tail->ft == fty.recs_tail->lt) + { + msg (SE, _("No input commands (DATA LIST, REPEATING DATA) " + "for above RECORD TYPE.")); + return CMD_FAILURE; + } + } + + lex_match_id ("RECORD"); + lex_match_id ("TYPE"); + + /* Parse record type values. */ + if (lex_match_id ("OTHER")) + rct.flags |= RCT_OTHER; + else + { + int mv = 0; + + while (token == T_NUM || token == T_STRING) + { + if (rct.nv >= mv) + { + mv += 16; + rct.v = xrealloc (rct.v, mv * sizeof *rct.v); + } + + if (formats[fty.record.fmt].cat & FCAT_STRING) + { + if (!lex_force_string ()) + return CMD_FAILURE; + rct.v[rct.nv].c = xmalloc (fty.record.nc + 1); + st_bare_pad_copy (rct.v[rct.nv].c, ds_value (&tokstr), + fty.record.nc + 1); + } + else + { + if (!lex_force_num ()) + return CMD_FAILURE; + rct.v[rct.nv].f = tokval; + } + rct.nv++; + lex_get (); + + lex_match (','); + } + } + + /* Parse the rest of the subcommands. */ + while (token != '.') + { + if (lex_match_id ("SKIP")) + rct.flags |= RCT_SKIP; + else if (lex_match_id ("CASE")) + { + if (fty.type == FTY_MIXED) + { + msg (SE, _("The CASE subcommand is not allowed on " + "the RECORD TYPE command for FILE TYPE MIXED.")); + return CMD_FAILURE; + } + + lex_match ('='); + if (!parse_col_spec (&rct.case_sbc, "")) + return CMD_FAILURE; + if (rct.case_sbc.name[0]) + { + msg (SE, _("No variable name may be specified for the " + "CASE subcommand on RECORD TYPE.")); + return CMD_FAILURE; + } + + if ((formats[rct.case_sbc.fmt].cat ^ formats[fty.case_sbc.fmt].cat) + & FCAT_STRING) + { + msg (SE, _("The CASE column specification on RECORD TYPE " + "must give a format specifier that is the " + "same type as that of the CASE column " + "specification given on FILE TYPE.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("DUPLICATE")) + { + lex_match ('='); + if (lex_match_id ("WARN")) + rct.flags |= RCT_DUPLICATE; + else if (lex_match_id ("NOWARN")) + rct.flags &= ~RCT_DUPLICATE; + else + { + msg (SE, _("WARN or NOWARN expected on DUPLICATE " + "subcommand.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("MISSING")) + { + lex_match ('='); + if (lex_match_id ("WARN")) + rct.flags |= RCT_MISSING; + else if (lex_match_id ("NOWARN")) + rct.flags &= ~RCT_MISSING; + else + { + msg (SE, _("WARN or NOWARN expected on MISSING subcommand.")); + return CMD_FAILURE; + } + } + else if (lex_match_id ("SPREAD")) + { + lex_match ('='); + if (lex_match_id ("YES")) + rct.flags |= RCT_SPREAD; + else if (lex_match_id ("NO")) + rct.flags &= ~RCT_SPREAD; + else + { + msg (SE, _("YES or NO expected on SPREAD subcommand.")); + return CMD_FAILURE; + } + } + else + { + lex_error (_("while expecting a valid subcommand")); + return CMD_FAILURE; + } + } + + if (fty.recs_head) + fty.recs_tail = fty.recs_tail->next = xmalloc (sizeof *fty.recs_tail); + else + fty.recs_head = fty.recs_tail = xmalloc (sizeof *fty.recs_tail); + memcpy (fty.recs_tail, &rct, sizeof *fty.recs_tail); + + return CMD_SUCCESS; +} + +/* END FILE TYPE. */ + +int +cmd_end_file_type (void) +{ + if (pgm_state != STATE_INPUT || vfm_source != &file_type_source) + { + msg (SE, _("This command may only appear within a " + "FILE TYPE/END FILE TYPE structure.")); + return CMD_FAILURE; + } + + lex_match_id ("TYPE"); + + if (fty.recs_tail) + { + fty.recs_tail->lt = n_trns - 1; + if (!(fty.recs_tail->flags & RCT_SKIP) + && fty.recs_tail->ft == fty.recs_tail->lt) + { + msg (SE, _("No input commands (DATA LIST, REPEATING DATA) " + "on above RECORD TYPE.")); + goto fail; + } + } + else + { + msg (SE, _("No commands between FILE TYPE and END FILE TYPE.")); + goto fail; + } + + f_trns = n_trns; + + return lex_end_of_command (); + + fail: + /* Come here on discovering catastrophic error. */ + err_cond_fail (); + discard_variables (); + return CMD_FAILURE; +} + +/* FILE TYPE runtime. */ + +/*static void read_from_file_type_mixed(void); + static void read_from_file_type_grouped(void); + static void read_from_file_type_nested(void); */ + +/* Reads any number of cases into temp_case and calls write_case() for + each one. Compare data-list.c:read_from_data_list. */ +static void +file_type_source_read (void) +{ + char *line; + int len; + + struct fmt_spec format; + + dfm_push (fty.handle); + + format.type = fty.record.fmt; + format.w = fty.record.nc; + format.d = 0; + while (NULL != (line = dfm_get_record (fty.handle, &len))) + { + struct record_type *iter; + union value v; + int i; + + if (formats[fty.record.fmt].cat & FCAT_STRING) + { + struct data_in di; + + v.c = temp_case->data[fty.record.v->fv].s; + + data_in_finite_line (&di, line, len, + fty.record.fc, fty.record.fc + fty.record.nc); + di.v = (union value *) v.c; + di.flags = 0; + di.f1 = fty.record.fc; + di.format = format; + data_in (&di); + + for (iter = fty.recs_head; iter; iter = iter->next) + { + if (iter->flags & RCT_OTHER) + goto found; + for (i = 0; i < iter->nv; i++) + if (!memcmp (iter->v[i].c, v.c, fty.record.nc)) + goto found; + } + if (fty.wild) + msg (SW, _("Unknown record type \"%.*s\"."), fty.record.nc, v.c); + } + else + { + struct data_in di; + + data_in_finite_line (&di, line, len, + fty.record.fc, fty.record.fc + fty.record.nc); + di.v = &v; + di.flags = 0; + di.f1 = fty.record.fc; + di.format = format; + data_in (&di); + + memcpy (&temp_case->data[fty.record.v->fv].f, &v.f, sizeof v.f); + for (iter = fty.recs_head; iter; iter = iter->next) + { + if (iter->flags & RCT_OTHER) + goto found; + for (i = 0; i < iter->nv; i++) + if (approx_eq (iter->v[i].f, v.f)) + goto found; + } + if (fty.wild) + msg (SW, _("Unknown record type %g."), v.f); + } + dfm_fwd_record (fty.handle); + continue; + + found: + /* Arrive here if there is a matching record_type, which is in + iter. */ + dfm_fwd_record (fty.handle); + } + +/* switch(fty.type) + { + case FTY_MIXED: read_from_file_type_mixed(); break; + case FTY_GROUPED: read_from_file_type_grouped(); break; + case FTY_NESTED: read_from_file_type_nested(); break; + default: assert(0); + } */ + + dfm_pop (fty.handle); +} + +static void +file_type_source_destroy_source (void) +{ + struct record_type *iter, *next; + + cancel_transformations (); + for (iter = fty.recs_head; iter; iter = next) + { + next = iter->next; + free (iter); + } +} + +struct case_stream file_type_source = + { + NULL, + file_type_source_read, + NULL, + NULL, + file_type_source_destroy_source, + NULL, + "FILE TYPE", + }; diff --git a/src/filename.c b/src/filename.c new file mode 100644 index 00000000..4aaf7d17 --- /dev/null +++ b/src/filename.c @@ -0,0 +1,881 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "settings.h" +#include "str.h" +#include "version.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* PORTME: Everything in this file is system dependent. */ + +#if unix +#include +#if HAVE_UNISTD_H +#include +#endif +#include "stat.h" +#endif + +#if __WIN32__ +#define NOGDI +#define NOUSER +#define NONLS +#include +#endif + +#if __DJGPP__ +#include +#endif + +/* Initialization. */ + +const char *config_path; + +void +fn_init (void) +{ + config_path = fn_getenv_default ("STAT_CONFIG_PATH", default_config_path); +} + +/* Functions for performing operations on filenames. */ + +/* Substitutes $variables as defined by GETENV into INPUT and returns + a copy of the resultant string. Supports $var and ${var} syntaxes; + $$ substitutes as $. */ +char * +fn_interp_vars (const char *input, const char *(*getenv) (const char *)) +{ + struct string output; + + if (NULL == strchr (input, '$')) + return xstrdup (input); + + ds_init (NULL, &output, strlen (input)); + + for (;;) + switch (*input) + { + case '\0': + return ds_value (&output); + + case '$': + input++; + + if (*input == '$') + { + ds_putchar (&output, '$'); + input++; + } + else + { + int stop; + int start; + const char *value; + + start = ds_length (&output); + + if (*input == '(') + { + stop = ')'; + input++; + } + else if (*input == '{') + { + stop = '}'; + input++; + } + else + stop = 0; + + while (*input && *input != stop + && (stop || isalpha ((unsigned char) *input))) + ds_putchar (&output, *input++); + + value = getenv (ds_value (&output) + start); + ds_truncate (&output, start); + ds_concat (&output, value); + + if (stop && *input == stop) + input++; + } + + default: + ds_putchar (&output, *input++); + } +} + +#if unix +/* Expands csh tilde notation from the path INPUT into a malloc()'d + returned string. */ +char * +fn_tilde_expand (const char *input) +{ + const char *ip; + struct string output; + + if (NULL == strchr (input, '~')) + return xstrdup (input); + ds_init (NULL, &output, strlen (input)); + + ip = input; + + for (ip = input; *ip; ) + if (*ip != '~' || (ip != input && ip[-1] != PATH_DELIMITER)) + ds_putchar (&output, *ip++); + else + { + static const char stop_set[3] = {DIR_SEPARATOR, PATH_DELIMITER, 0}; + const char *cp; + + ip++; + + cp = ip + strcspn (ip, stop_set); + + if (cp > ip) + { + struct passwd *pwd; + char username[9]; + + strncpy (username, ip, cp - ip + 1); + username[8] = 0; + pwd = getpwnam (username); + + if (!pwd || !pwd->pw_dir) + ds_putchar (&output, *ip++); + else + ds_concat (&output, pwd->pw_dir); + } + else + { + const char *home = fn_getenv ("HOME"); + if (!home) + ds_putchar (&output, *ip++); + else + ds_concat (&output, home); + } + + ip = cp; + } + + return ds_value (&output); +} +#else /* !unix */ +char * +fn_tilde_expand (char *input) +{ + return xstrdup (input); +} +#endif /* !unix */ + +/* Searches for a configuration file with name NAME in the path given + by PATH, which is tilde- and environment-interpolated. Directories + in PATH are delimited by PATH_DELIMITER, defined in . + Returns the malloc'd full name of the first file found, or NULL if + none is found. + + If PREPEND is non-NULL, then it is prepended to each filename; + i.e., it looks like PREPEND/PATH_COMPONENT/NAME. This is not done + with absolute directories in the path. */ +#if unix || __MSDOS__ || __WIN32__ +char * +fn_search_path (const char *basename, const char *path, const char *prepend) +{ + char *subst_path; + struct string filename; + const char *bp; + + if (fn_absolute_p (basename)) + return fn_tilde_expand (basename); + + { + char *temp = fn_interp_vars (path, fn_getenv); + bp = subst_path = fn_tilde_expand (temp); + free (temp); + } + + msg (VM (4), _("Searching for `%s'..."), basename); + ds_init (NULL, &filename, 64); + + for (;;) + { + const char *ep; + if (0 == *bp) + { + msg (VM (4), _("Search unsuccessful!")); + ds_destroy (&filename); + free (subst_path); + return NULL; + } + + for (ep = bp; *ep && *ep != PATH_DELIMITER; ep++) + ; + + /* Paste together PREPEND/PATH/BASENAME. */ + ds_clear (&filename); + if (prepend && !fn_absolute_p (bp)) + { + ds_concat (&filename, prepend); + ds_putchar (&filename, DIR_SEPARATOR); + } + ds_concat_buffer (&filename, bp, ep - bp); + if (ep - bp + && ds_value (&filename)[ds_length (&filename) - 1] != DIR_SEPARATOR) + ds_putchar (&filename, DIR_SEPARATOR); + ds_concat (&filename, basename); + + msg (VM (5), " - %s", ds_value (&filename)); + if (fn_exists_p (ds_value (&filename))) + { + msg (VM (4), _("Found `%s'."), ds_value (&filename)); + free (subst_path); + return ds_value (&filename); + } + + if (0 == *ep) + { + msg (VM (4), _("Search unsuccessful!")); + free (subst_path); + ds_destroy (&filename); + return NULL; + } + bp = ep + 1; + } +} +#else /* not unix, msdog, lose32 */ +char * +fn_search_path (const char *basename, const char *path, const char *prepend) +{ + size_t size = strlen (path) + 1 + strlen (basename) + 1; + char *string; + char *cp; + + if (prepend) + size += strlen (prepend) + 1; + string = xmalloc (size); + + cp = string; + if (prepend) + { + cp = stpcpy (cp, prepend); + *cp++ = DIR_SEPARATOR; + } + cp = stpcpy (cp, path); + *cp++ = DIR_SEPARATOR; + strcpy (cp, basename); + + return string; +} +#endif /* not unix, msdog, lose32 */ + +/* Prepends directory DIR to filename FILE and returns a malloc()'d + copy of it. */ +char * +fn_prepend_dir (const char *file, const char *dir) +{ + char *temp; + char *cp; + + if (fn_absolute_p (file)) + return xstrdup (file); + + temp = xmalloc (strlen (file) + 1 + strlen (dir) + 1); + cp = stpcpy (temp, dir); + if (cp != temp && cp[-1] != DIR_SEPARATOR) + *cp++ = DIR_SEPARATOR; + cp = stpcpy (cp, file); + + return temp; +} + +/* fn_normalize(): This very OS-dependent routine canonicalizes + filename FN1. The filename should not need to be the name of an + existing file. Returns a malloc()'d copy of the canonical name. + This function must always succeed; if it needs to bail out then it + should return xstrdup(FN1). */ +#if unix +char * +fn_normalize (const char *filename) +{ + const char *src; + char *fn1, *fn2, *dest; + int maxlen; + + if (fn_special_p (filename)) + return xstrdup (filename); + + fn1 = fn_tilde_expand (filename); + + /* Follow symbolic links. */ + for (;;) + { + fn2 = fn1; + fn1 = fn_readlink (fn1); + if (!fn1) + { + fn1 = fn2; + break; + } + free (fn2); + } + + maxlen = strlen (fn1) * 2; + if (maxlen < 31) + maxlen = 31; + dest = fn2 = xmalloc (maxlen + 1); + src = fn1; + + if (*src == DIR_SEPARATOR) + *dest++ = *src++; + else + { + errno = 0; +#if __CHECKER__ + memset (dest, 0, maxlen); +#endif + while (getcwd (dest, maxlen - (dest - fn2)) == NULL && errno == ERANGE) + { + maxlen *= 2; + dest = fn2 = xrealloc (fn2, maxlen + 1); +#if __CHECKER__ + memset (dest, 0, maxlen); +#endif + errno = 0; + } + if (errno) + { + free (fn1); + free (fn2); + return NULL; + } + dest = strchr (fn2, '\0'); + if (dest - fn2 >= maxlen) + { + int ofs = dest - fn2; + maxlen *= 2; + fn2 = xrealloc (fn2, maxlen + 1); + dest = fn2 + ofs; + } + if (dest[-1] != DIR_SEPARATOR) + *dest++ = DIR_SEPARATOR; + } + + for (;;) + { + int c, f; + + c = *src++; + + f = 0; + if (c == DIR_SEPARATOR || c == 0) + { + /* remove `./', `../' from directory */ + if (dest[-1] == '.' && dest[-2] == DIR_SEPARATOR) + dest--; + else if (dest[-1] == '.' && dest[-2] == '.' && dest[-3] == DIR_SEPARATOR) + { + dest -= 3; + if (dest == fn2) + dest++; + while (dest[-1] != DIR_SEPARATOR) + dest--; + } + else if (dest[-1] != DIR_SEPARATOR) /* remove extra slashes */ + f = 1; + + if (c == 0) + { + if (dest[-1] == DIR_SEPARATOR && dest > fn2 + 1) + dest--; + *dest = 0; + free (fn1); + + return xrealloc (fn2, strlen (fn2) + 1); + } + } + else + f = 1; + + if (f) + { + if (dest - fn2 >= maxlen) + { + int ofs = dest - fn2; + maxlen *= 2; + fn2 = xrealloc (fn2, maxlen + 1); + dest = fn2 + ofs; + } + *dest++ = c; + } + } +} +#elif __WIN32__ +char * +fn_normalize (const char *fn1) +{ + DWORD len; + DWORD success; + char *fn2; + + /* Don't change special filenames. */ + if (is_special_filename (filename)) + return xstrdup (filename); + + /* First find the required buffer length. */ + len = GetFullPathName (fn1, 0, NULL, NULL); + if (!len) + { + fn2 = xstrdup (fn1); + return fn2; + } + + /* Then make a buffer that big. */ + fn2 = xmalloc (len); + success = GetFullPathName (fn1, len, fn2, NULL); + if (success >= len || success == 0) + { + free (fn2); + fn2 = xstrdup (fn1); + return fn2; + } + return fn2; +} +#elif __BORLANDC__ +char * +fn_normalize (const char *fn1) +{ + char *fn2 = _fullpath (NULL, fn1, 0); + if (fn2) + { + char *cp; + for (cp = fn2; *cp; cp++) + *cp = toupper ((unsigned char) (*cp)); + return fn2; + } + return xstrdup (fn1); +} +#elif __DJGPP__ +char * +fn_normalize (const char *fn1) +{ + char *fn2 = xmalloc (1024); + _fixpath (fn1, fn2); + fn2 = xrealloc (fn2, strlen (fn2) + 1); + return fn2; +} +#else /* not Lose32, Unix, or DJGPP */ +char * +fn_normalize (const char *fn) +{ + return xstrdup (fn); +} +#endif /* not Lose32, Unix, or DJGPP */ + +/* Returns the directory part of FILENAME, as a malloc()'d + string. */ +char * +fn_dirname (const char *filename) +{ + const char *p; + char *s; + size_t len; + + len = strlen (filename); + if (len == 1 && filename[0] == '/') + p = filename + 1; + else if (len && filename[len - 1] == DIR_SEPARATOR) + p = mm_find_reverse (filename, len - 1, filename + len - 1, 1); + else + p = strrchr (filename, DIR_SEPARATOR); + if (p == NULL) + p = filename; + + s = xmalloc (p - filename + 1); + memcpy (s, filename, p - filename); + s[p - filename] = 0; + + return s; +} + +/* Returns the basename part of FILENAME as a malloc()'d string. */ +#if 0 +char * +fn_basename (const char *filename) +{ + /* Not used, not implemented. */ + abort (); +} +#endif + +/* Returns the current working directory, as a malloc()'d string. + From libc.info. */ +char * +fn_get_cwd (void) +{ + int size = 100; + char *buffer = xmalloc (size); + + for (;;) + { + char *value = getcwd (buffer, size); + if (value != 0) + return buffer; + + size *= 2; + free (buffer); + buffer = xmalloc (size); + } +} + +/* Find out information about files. */ + +/* Returns nonzero iff NAME specifies an absolute filename. */ +int +fn_absolute_p (const char *name) +{ +#if unix + if (name[0] == '/' + || !strncmp (name, "./", 2) + || !strncmp (name, "../", 3) + || name[0] == '~') + return 1; +#elif __MSDOS__ + if (name[0] == '\\' + || !strncmp (name, ".\\", 2) + || !strncmp (name, "..\\", 3) + || (name[0] && name[1] == ':')) + return 1; +#endif + + return 0; +} + +/* Returns 1 if the filename specified is a virtual file that doesn't + really exist on disk, 0 if it's a real filename. */ +int +fn_special_p (const char *filename) +{ + if (!strcmp (filename, "-") || !strcmp (filename, "stdin") + || !strcmp (filename, "stdout") || !strcmp (filename, "stderr") +#if unix + || filename[0] == '|' + || (*filename && filename[strlen (filename) - 1] == '|') +#endif + ) + return 1; + + return 0; +} + +/* Returns nonzero if file with name NAME exists. */ +int +fn_exists_p (const char *name) +{ +#if unix + struct stat temp; + + return stat (name, &temp) == 0; +#else + FILE *f = fopen (name, "r"); + if (!f) + return 0; + fclose (f); + return 1; +#endif +} + +#if unix +/* Stolen from libc.info but heavily modified, this is a wrapper + around readlink() that allows for arbitrary filename length. */ +char * +fn_readlink (const char *filename) +{ + int size = 128; + + for (;;) + { + char *buffer = xmalloc (size); + int nchars = readlink (filename, buffer, size); + if (nchars == -1) + { + free (buffer); + return NULL; + } + + if (nchars < size - 1) + { + buffer[nchars] = 0; + return buffer; + } + free (buffer); + size *= 2; + } +} +#else /* Not UNIX. */ +char * +fn_readlink (const char *filename) +{ + return NULL; +} +#endif /* Not UNIX. */ + +/* Environment variables. */ + +/* Simulates $VER and $ARCH environment variables. */ +const char * +fn_getenv (const char *s) +{ + if (!strcmp (s, "VER")) + return fn_getenv_default ("STAT_VER", bare_version); + else if (!strcmp (s, "ARCH")) + return fn_getenv_default ("STAT_ARCH", host_system); + else + return getenv (s); +} + +/* Returns getenv(KEY) if that's non-NULL; else returns DEF. */ +const char * +fn_getenv_default (const char *key, const char *def) +{ + const char *value = getenv (key); + return value ? value : def; +} + +/* Basic file handling. */ + +/* Used for giving an error message on a set_safer security + violation. */ +static FILE * +safety_violation (const char *fn) +{ + msg (SE, _("Not opening pipe file `%s' because SAFER option set."), fn); + errno = EPERM; + return NULL; +} + +/* As a general comment on the following routines, a `sensible value' + for errno includes 0 if there is no associated system error. The + routines will only set errno to 0 if there is an error in a + callback that sets errno to 0; they themselves won't. */ + +/* File open routine that understands `-' as stdin/stdout and `|cmd' + as a pipe to command `cmd'. Returns resultant FILE on success, + NULL on failure. If NULL is returned then errno is set to a + sensible value. */ +FILE * +fn_open (const char *fn, const char *mode) +{ + assert (mode[0] == 'r' || mode[0] == 'w'); + + if (mode[0] == 'r' && (!strcmp (fn, "stdin") || !strcmp (fn, "-"))) + return stdin; + else if (mode[0] == 'w' && (!strcmp (fn, "stdout") || !strcmp (fn, "-"))) + return stdout; + else if (mode[0] == 'w' && !strcmp (fn, "stderr")) + return stderr; + +#if unix + if (fn[0] == '|') + { + if (set_safer) + return safety_violation (fn); + + return popen (&fn[1], mode); + } + else if (*fn && fn[strlen (fn) - 1] == '|') + { + char *s; + FILE *f; + + if (set_safer) + return safety_violation (fn); + + s = local_alloc (strlen (fn)); + memcpy (s, fn, strlen (fn) - 1); + s[strlen (fn) - 1] = 0; + + f = popen (s, mode); + + local_free (s); + + return f; + } + else +#endif + { + FILE *f = fopen (fn, mode); + + if (f && mode[0] == 'w') + setvbuf (f, NULL, _IOLBF, 0); + + return f; + } +} + +/* Counterpart to fn_open that closes file F with name FN; returns 0 + on success, EOF on failure. If EOF is returned, errno is set to a + sensible value. */ +int +fn_close (const char *fn, FILE *f) +{ + if (!strcmp (fn, "-")) + return 0; +#if unix + else if (fn[0] == '|' || (*fn && fn[strlen (fn) - 1] == '|')) + { + pclose (f); + return 0; + } +#endif + else + return fclose (f); +} + +/* More extensive file handling. */ + +/* File open routine that extends fn_open(). Opens or reopens a + file according to the contents of file_ext F. Returns nonzero on + success. If 0 is returned, errno is set to a sensible value. */ +int +fn_open_ext (struct file_ext *f) +{ + char *p; + + p = strstr (f->filename, "%d"); + if (p) + { + char *s = local_alloc (strlen (f->filename) + INT_DIGITS - 1); + char *cp; + + memcpy (s, f->filename, p - f->filename); + cp = spprintf (&s[p - f->filename], "%d", *f->sequence_no); + strcpy (cp, &p[2]); + + if (f->file) + { + int error = 0; + + if (f->preclose) + if (f->preclose (f) == 0) + error = errno; + + if (EOF == fn_close (f->filename, f->file) || error) + { + f->file = NULL; + local_free (s); + + if (error) + errno = error; + + return 0; + } + + f->file = NULL; + } + + f->file = fn_open (s, f->mode); + local_free (s); + + if (f->file && f->postopen) + if (f->postopen (f) == 0) + { + int error = errno; + fn_close (f->filename, f->file); + errno = error; + + return 0; + } + + return (f->file != NULL); + } + else if (f->file) + return 1; + else + { + f->file = fn_open (f->filename, f->mode); + + if (f->file && f->postopen) + if (f->postopen (f) == 0) + { + int error = errno; + fn_close (f->filename, f->file); + errno = error; + + return 0; + } + + return (f->file != NULL); + } +} + +/* Properly closes the file associated with file_ext F, if any. + Return nonzero on success. If zero is returned, errno is set to a + sensible value. */ +int +fn_close_ext (struct file_ext *f) +{ + if (f->file) + { + int error = 0; + + if (f->preclose) + if (f->preclose (f) == 0) + error = errno; + + if (EOF == fn_close (f->filename, f->file) || error) + { + f->file = NULL; + + if (error) + errno = error; + + return 0; + } + + f->file = NULL; + } + return 1; +} diff --git a/src/filename.h b/src/filename.h new file mode 100644 index 00000000..499e693b --- /dev/null +++ b/src/filename.h @@ -0,0 +1,73 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !filename_h +#define filename_h 1 + +#include + +/* Search path for configuration files. */ +extern const char *config_path; + +void fn_init (void); + +char *fn_interp_vars (const char *input, const char *(*getenv) (const char *)); +char *fn_tilde_expand (const char *fn); +char *fn_search_path (const char *basename, const char *path, + const char *prepend); +char *fn_prepend_dir (const char *filename, const char *directory); +char *fn_normalize (const char *fn); +char *fn_dirname (const char *fn); +char *fn_basename (const char *fn); + +char *fn_get_cwd (void); + +int fn_absolute_p (const char *fn); +int fn_special_p (const char *fn); +int fn_exists_p (const char *fn); +char *fn_readlink (const char *fn); + +const char *fn_getenv (const char *variable); +const char *fn_getenv_default (const char *variable, const char *def); + +FILE *fn_open (const char *fn, const char *mode); +int fn_close (const char *fn, FILE *file); + +/* Extended file routines. */ +struct file_ext; + +typedef int (*file_callback) (struct file_ext *); + +/* File callbacks may not return zero to indicate failure unless they + set errno to a sensible value. */ +struct file_ext + { + char *filename; /* Filename. */ + const char *mode; /* Open mode, i.e, "wb". */ + FILE *file; /* File. */ + int *sequence_no; /* Page number, etc. */ + void *param; /* User data. */ + file_callback postopen; /* Called after FILE opened. */ + file_callback preclose; /* Called before FILE closed. */ + }; + +int fn_open_ext (struct file_ext *file); +int fn_close_ext (struct file_ext *file); + +#endif /* filename_h */ diff --git a/src/flip.c b/src/flip.c new file mode 100644 index 00000000..7ee4e703 --- /dev/null +++ b/src/flip.c @@ -0,0 +1,549 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +/* Variables to transpose. */ +static struct variable **var; +static int nvar; + +/* Variable containing new variable names. */ +static struct variable *newnames; + +/* List of variable names. */ +struct varname + { + struct varname *next; + char name[1]; + }; + +/* New variable names. */ +static struct varname *new_names_head, *new_names_tail; +static int case_count; + +static int build_dictionary (void); + +/* Parses and executes FLIP. */ +int +cmd_flip (void) +{ + lex_match_id ("FLIP"); + lex_match ('/'); + if (lex_match_id ("VARIABLES")) + { + lex_match ('='); + if (!parse_variables (&default_dict, &var, &nvar, PV_NO_DUPLICATE)) + return CMD_FAILURE; + lex_match ('/'); + } + else + fill_all_vars (&var, &nvar, FV_NO_SYSTEM); + + lex_match ('/'); + if (lex_match_id ("NEWNAMES")) + { + lex_match ('='); + newnames = parse_variable (); + if (!newnames) + { + free (var); + return CMD_FAILURE; + } + } + else + newnames = find_variable ("CASE_LBL"); + + if (newnames) + { + int i; + + for (i = 0; i < nvar; i++) + if (var[i] == newnames) + { + memcpy (&var[i], &var[i + 1], sizeof *var * (nvar - i - 1)); + nvar--; + break; + } + } + + case_count = 0; + temp_trns = temporary = 0; + vfm_sink = &flip_stream; + new_names_tail = NULL; + procedure (NULL, NULL, NULL); + + clear_default_dict (); + if (!build_dictionary ()) + { + discard_variables (); + free (var); + return CMD_FAILURE; + } + + free (var); + return lex_end_of_command (); +} + +/* Make a new variable with base name NAME, which is bowdlerized and + mangled until acceptable, and returns success. */ +static int +make_new_var (char name[]) +{ + /* Fix invalid characters. */ + { + char *cp; + + for (cp = name; *cp && !isspace (*cp); cp++) + { + *cp = toupper ((unsigned char) *cp); + if (!isalpha (*cp) && *cp != '@' && *cp != '#' + && (cp == name || (*cp != '.' && *cp != '$' && *cp != '_'))) + { + if (cp == name) + *cp = 'V'; /* _ not valid in first position. */ + else + *cp = '_'; + } + } + *cp = 0; + } + + if (create_variable (&default_dict, name, NUMERIC, 0)) + return 1; + + /* Add numeric extensions until acceptable. */ + { + int len = (int) strlen (name); + char n[9]; + int i; + + for (i = 1; i < 10000000; i++) + { + int ofs = min (7 - intlog10 (i), len); + memcpy (n, name, ofs); + sprintf (&n[ofs], "%d", i); + + if (create_variable (&default_dict, n, NUMERIC, 0)) + return 1; + } + } + + msg (SE, _("Could not create acceptable variant for variable %s."), name); + return 0; +} + +/* Make a new dictionary for all the new variable names. */ +static int +build_dictionary (void) +{ + force_create_variable (&default_dict, "CASE_LBL", ALPHA, 8); + + if (!new_names_tail) + { + int i; + + if (case_count > 99999) + { + msg (SE, _("Cannot create more than 99999 variable names.")); + return 0; + } + + for (i = 0; i < case_count; i++) + { + char s[9]; + + sprintf (s, "VAR%03d", i); + force_create_variable (&default_dict, s, NUMERIC, 0); + } + } + else + { + struct varname *v, *n; + + new_names_tail->next = NULL; + for (v = new_names_head; v; v = n) + { + n = v->next; + if (!make_new_var (v->name)) + { + for (; v; v = n) + { + n = v->next; + free (v); + } + return 0; + } + free (v); + } + } + + return 1; +} + + +/* Each case to be transposed. */ +struct flip_case + { + struct flip_case *next; + double v[1]; + }; + +/* Sink: Cases during transposition. */ +static int internal; /* Internal vs. external flipping. */ +static char *sink_old_names; /* Old variable names. */ +static unsigned long sink_cases; /* Number of cases. */ +static struct flip_case *head, *tail; /* internal == 1: Cases. */ +static FILE *sink_file; /* internal == 0: Temporary file. */ + +/* Source: Cases after transposition. */ +static struct flip_case *src; /* Internal transposition records. */ +static char *src_old_names; /* Old variable names. */ +static unsigned long src_cases; /* Number of cases. */ +static FILE *src_file; /* src == NULL: Temporary file. */ + +/* Initialize the FLIP stream. */ +static void +flip_stream_init (void) +{ + internal = 1; + sink_cases = 0; + tail = NULL; + + { + size_t n = nvar; + char *p; + int i; + + for (i = 0; i < nvar; i++) + n += strlen (var[i]->name); + p = sink_old_names = xmalloc (n); + for (i = 0; i < nvar; i++) + p = stpcpy (p, var[i]->name) + 1; + } +} + +/* Reads the FLIP stream and passes it to write_case(). */ +static void +flip_stream_read (void) +{ + if (src || (src == NULL && src_file == NULL)) + { + /* Internal transposition, or empty file. */ + int i, j; + char *p = src_old_names; + + for (i = 0; i < nvar; i++) + { + struct flip_case *iter; + + st_bare_pad_copy (temp_case->data[0].s, p, 8); + p = strchr (p, 0) + 1; + + for (iter = src, j = 1; iter; iter = iter->next, j++) + temp_case->data[j].f = iter->v[i]; + + if (!write_case ()) + return; + } + } + else + { + int i; + char *p = src_old_names; + + for (i = 0; i < nvar; i++) + { + st_bare_pad_copy (temp_case->data[0].s, p, 8); + p = strchr (p, 0) + 1; + + if (fread (&temp_case->data[1], sizeof (double), src_cases, + src_file) != src_cases) + msg (FE, _("Error reading FLIP source file: %s."), + strerror (errno)); + + if (!write_case ()) + return; + } + } +} + +/* Writes temp_case to the FLIP stream. */ +static void +flip_stream_write (void) +{ + sink_cases++; + + if (newnames) + { + struct varname *v; + char name[INT_DIGITS + 2]; + + if (newnames->type == NUMERIC) + sprintf (name, "V%d", (int) temp_case->data[newnames->fv].f); + else + { + int width = min (newnames->width, 8); + memcpy (name, temp_case->data[newnames->fv].s, width); + name[width] = 0; + } + + v = xmalloc (sizeof (struct varname) + strlen (name) - 1); + strcpy (v->name, name); + + if (new_names_tail == NULL) + new_names_head = v; + else + new_names_tail->next = v; + new_names_tail = v; + } + else + case_count++; + + if (internal) + { +#if 0 + flip_case *c = malloc (sizeof (flip_case) + + sizeof (double) * (nvar - 1)); + + if (c != NULL) + { + /* Write to internal file. */ + int i; + + for (i = 0; i < nvar; i++) + if (var[i]->type == NUMERIC) + c->v[i] = temp_case->data[var[i]->fv].f; + else + c->v[i] = SYSMIS; + + if (tail == NULL) + head = c; + else + tail->next = c; + tail = c; + + return; + } + else +#endif + { + /* Initialize external file. */ + struct flip_case *iter, *next; + + internal = 0; + + sink_file = tmpfile (); + if (!sink_file) + msg (FE, _("Could not create temporary file for FLIP.")); + + if (tail) + tail->next = NULL; + for (iter = head; iter; iter = next) + { + next = iter->next; + + if (fwrite (iter->v, sizeof (double), nvar, sink_file) + != (size_t) nvar) + msg (FE, _("Error writing FLIP file: %s."), + strerror (errno)); + free (iter); + } + } + } + + /* Write to external file. */ + { + double *d = local_alloc (sizeof *d * nvar); + int i; + + for (i = 0; i < nvar; i++) + if (var[i]->type == NUMERIC) + d[i] = temp_case->data[var[i]->fv].f; + else + d[i] = SYSMIS; + + if (fwrite (d, sizeof *d, nvar, sink_file) != (size_t) nvar) + msg (FE, _("Error writing FLIP file: %s."), + strerror (errno)); + + local_free (d); + } +} + +/* Transpose the external file. */ +static void +transpose_external_file (void) +{ + unsigned long n_cases; + unsigned long cur_case; + double *case_buf, *temp_buf; + + n_cases = 4 * 1024 * 1024 / ((nvar + 1) * sizeof *case_buf); + if (n_cases < 2) + n_cases = 2; + for (;;) + { + assert (n_cases >= 2 /* 1 */); + case_buf = ((n_cases <= 2 ? xmalloc : (void *(*)(size_t)) malloc) + ((nvar + 1) * sizeof *case_buf * n_cases)); + if (case_buf) + break; + + n_cases /= 2; + if (n_cases < 2) + n_cases = 2; + } + + /* A temporary buffer that holds n_cases elements. */ + temp_buf = &case_buf[nvar * n_cases]; + + src_file = tmpfile (); + if (!src_file) + msg (FE, _("Error creating FLIP source file.")); + + if (fseek (sink_file, 0, SEEK_SET) != 0) + msg (FE, _("Error rewinding FLIP file: %s."), strerror (errno)); + + for (cur_case = 0; cur_case < sink_cases; ) + { + unsigned long read_cases = min (sink_cases - cur_case, n_cases); + int i; + + if (read_cases != fread (case_buf, sizeof *case_buf * nvar, + read_cases, sink_file)) + msg (FE, _("Error reading FLIP file: %s."), strerror (errno)); + + for (i = 0; i < nvar; i++) + { + unsigned long j; + + for (j = 0; j < read_cases; j++) + temp_buf[j] = case_buf[i + j * nvar]; + + if (fseek (src_file, + sizeof *case_buf * (cur_case + i * sink_cases), + SEEK_SET) != 0) + msg (FE, _("Error seeking FLIP source file: %s."), + strerror (errno)); + + if (fwrite (temp_buf, sizeof *case_buf, read_cases, src_file) + != read_cases) + msg (FE, _("Error writing FLIP source file: %s."), + strerror (errno)); + } + + cur_case += read_cases; + } + + if (fseek (src_file, 0, SEEK_SET) != 0) + msg (FE, _("Error rewind FLIP source file: %s."), strerror (errno)); + + fclose (sink_file); + + free (case_buf); +} + +/* Change the FLIP stream from sink to source mode. */ +static void +flip_stream_mode (void) +{ + src_cases = sink_cases; + src_old_names = sink_old_names; + sink_old_names = NULL; + + if (internal) + { + if (tail) + { + tail->next = NULL; + src = head; + } + else + { + src = NULL; + src_file = NULL; + } + } + else + { + src = NULL; + transpose_external_file (); + } +} + +/* Destroy source's internal data. */ +static void +flip_stream_destroy_source (void) +{ + free (src_old_names); + if (internal) + { + struct flip_case *iter, *next; + + for (iter = src; iter; iter = next) + { + next = iter->next; + free (iter); + } + } + else + fclose (src_file); +} + +/* Destroy sink's internal data. */ +static void +flip_stream_destroy_sink (void) +{ + struct flip_case *iter, *next; + + free (sink_old_names); + if (tail == NULL) + return; + + tail->next = NULL; + for (iter = head; iter; iter = next) + { + next = iter->next; + free (iter); + } +} + +struct case_stream flip_stream = + { + flip_stream_init, + flip_stream_read, + flip_stream_write, + flip_stream_mode, + flip_stream_destroy_source, + flip_stream_destroy_sink, + "FLIP", + }; diff --git a/src/font.h b/src/font.h new file mode 100644 index 00000000..67c276cd --- /dev/null +++ b/src/font.h @@ -0,0 +1,141 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !font_h +#define font_h 1 + +/* Possible ligatures. */ +#define LIG_ff 001 +#define LIG_ffi 002 +#define LIG_ffl 004 +#define LIG_fi 010 +#define LIG_fl 020 + +/* Character type constants. */ +#define CTYP_NONE 000 /* Neither ascenders nor descenders. */ +#define CTYP_ASCENDER 001 /* Character has an ascender. */ +#define CTYP_DESCENDER 002 /* Character has a descender. */ + +/* Font metrics for a single character. */ +struct char_metrics + { + int code; /* Character code. */ + int type; /* CTYP_* constants. */ + int width; /* Width. */ + int height; /* Height above baseline, never negative. */ + int depth; /* Depth below baseline, never negative. */ + + /* These fields are not yet used, so to save memory, they are left + out. */ +#if 0 + int italic_correction; /* Italic correction. */ + int left_italic_correction; /* Left italic correction. */ + int subscript_correction; /* Subscript correction. */ +#endif + }; + +/* Kerning for a pair of characters. */ +struct kern_pair + { + int ch1; /* First character. */ + int ch2; /* Second character. */ + int adjust; /* Kern amount. */ + }; + +/* Font description. */ +struct font_desc + { + /* Housekeeping data. */ + struct pool *owner; /* Containing pool. */ + char *name; /* Font name. FIXME: this field's + role is uncertain. */ + char *filename; /* Normalized filename. */ + + /* PostScript-specific courtesy data. */ + char *internal_name; /* Font internal name. */ + char *encoding; /* Name of encoding file. */ + + /* Basic font characteristics. */ + int space_width; /* Width of a space character. */ + double slant; /* Slant angle, in degrees of forward slant. */ + unsigned ligatures; /* Characters that have ligatures. */ + int special; /* 1=This is a special font that will be + searched when a character is not present in + another font. */ + int ascent, descent; /* Height above, below the baseline. */ + + /* First dereferencing level is font_char_name_to_index(NAME). */ + /* Second dereferencing level. */ + short *deref; /* Each entry is an index into metric. + metric[deref[lookup(NAME)]] is the metric + for character with name NAME. */ + int deref_size; /* Number of spaces for entries in deref. */ + + /* Third dereferencing level. */ + struct char_metrics **metric; /* Metrics for font characters. */ + int metric_size; /* Number of spaces for entries in metric. */ + int metric_used; /* Number of spaces used in metric. */ + + /* Kern pairs. */ + struct kern_pair *kern; /* Hash table for kerns. */ + int kern_size; /* Number of spaces for kerns in kern. */ + int *kern_size_p; /* Next larger hash table size. */ + int kern_used; /* Number of used spaces in kern. */ + int kern_max_used; /* Max number used before rehashing. */ + }; + +/* Index into deref[] of character with name "space". */ +extern int space_index; + +/* A set of fonts. */ +struct font_set + { + struct font_set *next, *prev; /* Next, previous in chain. */ + struct font_desc *font; /* Current font. */ + }; + +/* Functions to work with any font. */ +#define destroy_font(FONT) \ + pool_destroy (FONT->owner) + +int font_char_name_to_index (const char *); +struct char_metrics *font_get_char_metrics (const struct font_desc *font, + int ch); +int font_get_kern_adjust (const struct font_desc *font, int ch1, int ch2); + +/* groff fonts. */ +struct groff_device_info + { + /* See groff_font(5). */ + int res, horiz, vert; + int size_scale, unit_width; + int (*sizes)[2], n_sizes; + char *font_name[4]; /* Names of 4 default fonts. */ + char *family; /* Name of default font family. */ + }; + +struct outp_driver; +struct font_desc *groff_read_font (const char *fn); +struct font_desc *groff_find_font (const char *dev, const char *name); +int groff_read_DESC (const char *dev_name, struct groff_device_info * dev); +void groff_init (void); + +struct font_desc *default_font (void); + +#endif /* font_h */ diff --git a/src/format.c b/src/format.c new file mode 100644 index 00000000..61b223e2 --- /dev/null +++ b/src/format.c @@ -0,0 +1,343 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +#include +#include +#include +#include "error.h" +#include "format.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" + +#define DEFFMT(LABEL, NAME, N_ARGS, IMIN_W, IMAX_W, OMIN_W, OMAX_W, CAT, \ + OUTPUT, SPSS_FMT) \ + {NAME, N_ARGS, IMIN_W, IMAX_W, OMIN_W, OMAX_W, CAT, OUTPUT, SPSS_FMT}, +struct fmt_desc formats[FMT_NUMBER_OF_FORMATS + 1] = +{ +#include "format.def" + {"", -1, -1, -1, -1, -1, 0000, -1, -1}, +}; + +const int translate_fmt[40] = + { + -1, FMT_A, FMT_AHEX, FMT_COMMA, FMT_DOLLAR, FMT_F, FMT_IB, + FMT_PIBHEX, FMT_P, FMT_PIB, FMT_PK, FMT_RB, FMT_RBHEX, -1, + -1, FMT_Z, FMT_N, FMT_E, -1, -1, FMT_DATE, FMT_TIME, + FMT_DATETIME, FMT_ADATE, FMT_JDATE, FMT_DTIME, FMT_WKDAY, + FMT_MONTH, FMT_MOYR, FMT_QYR, FMT_WKYR, FMT_PCT, FMT_DOT, + FMT_CCA, FMT_CCB, FMT_CCC, FMT_CCD, FMT_CCE, FMT_EDATE, + FMT_SDATE, + }; + +int +parse_format_specifier_name (const char **cp, int allow_xt) +{ + struct fmt_desc *f; + char *ep; + int x; + + ep = ds_value (&tokstr); + while (isalpha ((unsigned char) *ep)) + ep++; + x = *ep; + *ep = 0; + + for (f = formats; f->name[0]; f++) + if (!strcmp (f->name, ds_value (&tokstr))) + { + int indx = f - formats; + + *ep = x; + if (cp) + *cp = ep; + + if (!allow_xt && (indx == FMT_T || indx == FMT_X)) + { + msg (SE, _("X and T format specifiers not allowed here.")); + return -1; + } + return indx; + } + + msg (SE, _("%s is not a valid data format."), ds_value (&tokstr)); + *ep = x; + return -1; +} + +/* Converts F to its string representation (for instance, "F8.2") and + returns a pointer to a static buffer containing that string. */ +char * +fmt_to_string (const struct fmt_spec *f) +{ + static char buf[32]; + + if (formats[f->type].n_args >= 2) + sprintf (buf, "%s%d.%d", formats[f->type].name, f->w, f->d); + else + sprintf (buf, "%s%d", formats[f->type].name, f->w); + return buf; +} + +int +check_input_specifier (const struct fmt_spec *spec) +{ + struct fmt_desc *f; + char *str; + + f = &formats[spec->type]; + str = fmt_to_string (spec); + if (spec->type == FMT_X) + return 1; + if (f->cat & FCAT_OUTPUT_ONLY) + { + msg (SE, _("Format %s may not be used as an input format."), f->name); + return 0; + } + if (spec->w < f->Imin_w || spec->w > f->Imax_w) + { + msg (SE, _("Input format %s specifies a bad width %d. " + "Format %s requires a width between %d and %d."), + str, spec->w, f->name, f->Imin_w, f->Imax_w); + return 0; + } + if ((f->cat & FCAT_EVEN_WIDTH) && spec->w % 2) + { + msg (SE, _("Input format %s specifies an odd width %d, but " + "format %s requires an even width between %d and " + "%d."), str, spec->w, f->name, f->Imin_w, f->Imax_w); + return 0; + } + if (f->n_args > 1 && (spec->d < 0 || spec->d > 16)) + { + msg (SE, _("Input format %s specifies a bad number of " + "implied decimal places %d. Input format %s allows " + "up to 16 implied decimal places."), str, spec->d, f->name); + return 0; + } + return 1; +} + +int +check_output_specifier (const struct fmt_spec *spec) +{ + struct fmt_desc *f; + char *str; + + f = &formats[spec->type]; + str = fmt_to_string (spec); + if (spec->type == FMT_X) + return 1; + if (spec->w < f->Omin_w || spec->w > f->Omax_w) + { + msg (SE, _("Output format %s specifies a bad width %d. " + "Format %s requires a width between %d and %d."), + str, spec->w, f->name, f->Omin_w, f->Omax_w); + return 0; + } + if (spec->d > 1 + && (spec->type == FMT_F || spec->type == FMT_COMMA + || spec->type == FMT_DOLLAR) + && spec->w < f->Omin_w + 1 + spec->d) + { + msg (SE, _("Output format %s requires minimum width %d to allow " + "%d decimal places. Try %s%d.%d instead of %s."), + f->name, f->Omin_w + 1 + spec->d, spec->d, f->name, + f->Omin_w + 1 + spec->d, spec->d, str); + return 0; + } + if ((f->cat & FCAT_EVEN_WIDTH) && spec->w % 2) + { + msg (SE, _("Output format %s specifies an odd width %d, but " + "output format %s requires an even width between %d and " + "%d."), str, spec->w, f->name, f->Omin_w, f->Omax_w); + return 0; + } + if (f->n_args > 1 && (spec->d < 0 || spec->d > 16)) + { + msg (SE, _("Output format %s specifies a bad number of " + "implied decimal places %d. Output format %s allows " + "a number of implied decimal places between 1 " + "and 16."), str, spec->d, f->name); + return 0; + } + return 1; +} + +/* If a string variable has width W, you can't display it with a + format specifier with a required width MIN_LEN>W. */ +int +check_string_specifier (const struct fmt_spec *f, int min_len) +{ + if ((f->type == FMT_A && min_len > f->w) + || (f->type == FMT_AHEX && min_len * 2 > f->w)) + { + msg (SE, _("Can't display a string variable of width %d with " + "format specifier %s."), min_len, fmt_to_string (f)); + return 0; + } + return 1; +} + +void +convert_fmt_ItoO (const struct fmt_spec *input, struct fmt_spec *output) +{ + output->type = formats[input->type].output; + output->w = input->w; + if (output->w > formats[output->type].Omax_w) + output->w = formats[output->type].Omax_w; + output->d = input->d; + + switch (input->type) + { + case FMT_F: + case FMT_N: + if (output->d > 1 && output->w < 2 + output->d) + output->w = 2 + output->d; + break; + case FMT_E: + output->w = max (max (input->w, input->d+7), 10); + output->d = max (input->d, 3); + break; + case FMT_COMMA: + case FMT_DOT: + /* nothing is necessary */ + break; + case FMT_DOLLAR: + case FMT_PCT: + if (output->w < 2) + output->w = 2; + break; + case FMT_PIBHEX: + { + static const int map[] = {4, 6, 9, 11, 14, 16, 18, 21}; + assert (input->w % 2 == 0 && input->w >= 2 && input->w <= 16); + output->w = map[input->w / 2 - 1]; + break; + } + case FMT_RBHEX: + output->w = 8, output->d = 2; /* FIXME */ + break; + case FMT_IB: + case FMT_PIB: + case FMT_P: + case FMT_PK: + case FMT_RB: + if (input->d < 1) + output->w = 8, output->d = 2; + else + output->w = 9 + input->d; + break; + case FMT_CCA: + case FMT_CCB: + case FMT_CCC: + case FMT_CCD: + case FMT_CCE: + assert (0); + case FMT_Z: + case FMT_A: + /* nothing is necessary */ + break; + case FMT_AHEX: + output->w = input->w / 2; + break; + case FMT_DATE: + case FMT_EDATE: + case FMT_SDATE: + case FMT_ADATE: + case FMT_JDATE: + /* nothing is necessary */ + break; + case FMT_QYR: + if (output->w < 6) + output->w = 6; + break; + case FMT_MOYR: + /* nothing is necessary */ + break; + case FMT_WKYR: + if (output->w < 8) + output->w = 8; + break; + case FMT_TIME: + case FMT_DTIME: + case FMT_DATETIME: + case FMT_WKDAY: + case FMT_MONTH: + /* nothing is necessary */ + break; + default: + assert (0); + } +} + +int +parse_format_specifier (struct fmt_spec *input, int allow_xt) +{ + struct fmt_spec spec; + struct fmt_desc *f; + const char *cp; + char *cp2; + int type, w, d; + + if (token != T_ID) + { + msg (SE, _("Format specifier expected.")); + return 0; + } + type = parse_format_specifier_name (&cp, allow_xt); + if (type == -1) + return 0; + f = &formats[type]; + + w = strtol (cp, &cp2, 10); + if (cp2 == cp && type != FMT_X) + { + msg (SE, _("Data format %s does not specify a width."), + ds_value (&tokstr)); + return 0; + } + + cp = cp2; + if (f->n_args > 1 && *cp == '.') + { + cp++; + d = strtol (cp, &cp2, 10); + cp = cp2; + } + else + d = 0; + + if (*cp) + { + msg (SE, _("Data format %s is not valid."), ds_value (&tokstr)); + return 0; + } + lex_get (); + + spec.type = type; + spec.w = w; + spec.d = d; + *input = spec; + + return 1; +} + diff --git a/src/format.def b/src/format.def new file mode 100644 index 00000000..fda776df --- /dev/null +++ b/src/format.def @@ -0,0 +1,65 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* Numeric and string formats. */ +DEFFMT (FMT_F, "F", 2, 1, 40, 1, 40, 0001, FMT_F, 5) +DEFFMT (FMT_N, "N", 2, 1, 40, 1, 40, 0011, FMT_F, 16) +DEFFMT (FMT_E, "E", 2, 1, 40, 6, 40, 0001, FMT_E, 17) +DEFFMT (FMT_COMMA, "COMMA", 2, 1, 40, 1, 40, 0001, FMT_COMMA, 3) +DEFFMT (FMT_DOT, "DOT", 2, 1, 40, 1, 40, 0001, FMT_DOT, 32) +DEFFMT (FMT_DOLLAR, "DOLLAR", 2, 1, 40, 2, 40, 0001, FMT_DOLLAR, 4) +DEFFMT (FMT_PCT, "PCT", 2, 1, 40, 2, 40, 0001, FMT_PCT, 31) +DEFFMT (FMT_Z, "Z", 2, 1, 40, 1, 40, 0011, FMT_F, 15) +DEFFMT (FMT_A, "A", 1, 1, 255, 1, 254, 0004, FMT_A, 1) +DEFFMT (FMT_AHEX, "AHEX", 1, 2, 254, 2, 510, 0006, FMT_A, 2) +DEFFMT (FMT_IB, "IB", 2, 1, 8, 1, 8, 0010, FMT_F, 6) +DEFFMT (FMT_P, "P", 2, 1, 16, 1, 16, 0011, FMT_F, 8) +DEFFMT (FMT_PIB, "PIB", 2, 1, 8, 1, 8, 0010, FMT_F, 9) +DEFFMT (FMT_PIBHEX, "PIBHEX", 2, 2, 16, 2, 16, 0002, FMT_F, 7) +DEFFMT (FMT_PK, "PK", 2, 1, 16, 1, 16, 0010, FMT_F, 10) +DEFFMT (FMT_RB, "RB", 1, 2, 8, 2, 8, 0002, FMT_F, 11) +DEFFMT (FMT_RBHEX, "RBHEX", 1, 4, 16, 4, 16, 0002, FMT_F, 12) + +/* Custom currency. */ +DEFFMT (FMT_CCA, "CCA", 2, -1, -1, 1, 40, 0020, FMT_CCA, 33) +DEFFMT (FMT_CCB, "CCB", 2, -1, -1, 1, 40, 0020, FMT_CCB, 34) +DEFFMT (FMT_CCC, "CCC", 2, -1, -1, 1, 40, 0020, FMT_CCC, 35) +DEFFMT (FMT_CCD, "CCD", 2, -1, -1, 1, 40, 0020, FMT_CCD, 36) +DEFFMT (FMT_CCE, "CCE", 2, -1, -1, 1, 40, 0020, FMT_CCE, 37) + +/* Date/time formats. */ +DEFFMT (FMT_DATE, "DATE", 1, 9, 40, 9, 40, 0001, FMT_DATE, 20) +DEFFMT (FMT_EDATE, "EDATE", 1, 8, 40, 8, 40, 0001, FMT_EDATE, 23) +DEFFMT (FMT_SDATE, "SDATE", 1, 8, 40, 8, 40, 0001, FMT_SDATE, 24) +DEFFMT (FMT_ADATE, "ADATE", 1, 8, 40, 8, 40, 0001, FMT_ADATE, 29) +DEFFMT (FMT_JDATE, "JDATE", 1, 5, 40, 5, 40, 0001, FMT_JDATE, 28) +DEFFMT (FMT_QYR, "QYR", 1, 4, 40, 6, 40, 0001, FMT_QYR, 30) +DEFFMT (FMT_MOYR, "MOYR", 1, 6, 40, 6, 40, 0001, FMT_MOYR, 22) +DEFFMT (FMT_WKYR, "WKYR", 1, 6, 40, 8, 40, 0001, FMT_WKYR, 21) +DEFFMT (FMT_DATETIME, "DATETIME", 2, 17, 40, 17, 40, 0001, FMT_DATETIME, 38) +DEFFMT (FMT_TIME, "TIME", 2, 5, 40, 5, 40, 0001, FMT_TIME, 39) +DEFFMT (FMT_DTIME, "DTIME", 2, 11, 40, 8, 40, 0001, FMT_DTIME, 25) +DEFFMT (FMT_WKDAY, "WKDAY", 1, 2, 40, 2, 40, 0001, FMT_WKDAY, 26) +DEFFMT (FMT_MONTH, "MONTH", 1, 3, 40, 3, 40, 0001, FMT_MONTH, 27) + +/* These aren't real formats. They're used by DATA LIST. */ +DEFFMT (FMT_T, "T", 1, 1,99999, 1,99999, 0000, FMT_T, -1) +DEFFMT (FMT_X, "X", 1, 1,99999, 1,99999, 0000, FMT_X, -1) +DEFFMT (FMT_DESCEND, "***", 1, 1,99999, 1,99999, 0000, -1, -1) +DEFFMT (FMT_NEWREC, "***", 1, 1,99999, 1,99999, 0000, -1, -1) diff --git a/src/format.h b/src/format.h new file mode 100644 index 00000000..ad6d2f7b --- /dev/null +++ b/src/format.h @@ -0,0 +1,92 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !format_h +#define format_h 1 + +/* Display format types. */ +/* See the definitions of these functions and variables when modifying + this list: + misc.c:convert_fmt_ItoO() + sfm-read.c:parse_format_spec() + data-in.c:parse_string_as_format() + data-out.c:convert_format_to_string(). */ +#define DEFFMT(LABEL, NAME, N_ARGS, IMIN_W, IMAX_W, OMIN_W, OMAX_W, \ + CAT, OUTPUT, SPSS_FMT) \ + LABEL, +enum + { +#include "format.def" + FMT_NUMBER_OF_FORMATS + }; +#undef DEFFMT + +/* Describes one of the display formats above. */ +struct fmt_desc + { + char name[9]; /* `DATETIME' is the longest name. */ + int n_args; /* 1=width; 2=width.decimals. */ + int Imin_w, Imax_w; /* Bounds on input width. */ + int Omin_w, Omax_w; /* Bounds on output width. */ + int cat; /* Categories. */ + int output; /* Output format. */ + int spss; /* Equivalent SPSS output format. */ + }; + +/* Display format categories. */ +enum + { + FCAT_BLANKS_SYSMIS = 001, /* 1=All-whitespace means SYSMIS. */ + FCAT_EVEN_WIDTH = 002, /* 1=Width must be even. */ + FCAT_STRING = 004, /* 1=String input/output format. */ + FCAT_SHIFT_DECIMAL = 010, /* 1=Automatically shift decimal point + on output--used for fixed-point + formats. */ + FCAT_OUTPUT_ONLY = 020 /* 1=This is not an input format. */ + }; + +/* Display format. */ +struct fmt_spec + { + int type; /* One of the above constants. */ + int w; /* Width. */ + int d; /* Number of implied decimal places. */ + }; + +/* Descriptions of all the display formats above. */ +extern struct fmt_desc formats[]; + +/* Translates SPSS formats to PSPP formats. */ +extern const int translate_fmt[40]; + +union value; + +int parse_format_specifier (struct fmt_spec *input, int allow_xt); +int parse_format_specifier_name (const char **cp, int allow_xt); +int check_input_specifier (const struct fmt_spec *spec); +int check_output_specifier (const struct fmt_spec *spec); +int check_string_specifier (const struct fmt_spec *spec, int min_len); +void convert_fmt_ItoO (const struct fmt_spec *input, struct fmt_spec *output); +int parse_string_as_format (const char *s, int len, const struct fmt_spec *fp, + int fc, union value *v); +int data_out (char *s, const struct fmt_spec *fp, const union value *v); +char *fmt_to_string (const struct fmt_spec *); +void num_to_string (double v, char *s, int w, int d); + +#endif /* !format_h */ diff --git a/src/formats.c b/src/formats.c new file mode 100644 index 00000000..8d2918a7 --- /dev/null +++ b/src/formats.c @@ -0,0 +1,165 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +static void debug_print (void); +#endif + +enum + { + FORMATS_PRINT = 001, + FORMATS_WRITE = 002 + }; + +static int internal_cmd_formats (int); + +int +cmd_print_formats (void) +{ + lex_match_id ("FORMATS"); + return internal_cmd_formats (FORMATS_PRINT); +} + +int +cmd_write_formats (void) +{ + lex_match_id ("FORMATS"); + return internal_cmd_formats (FORMATS_WRITE); +} + +int +cmd_formats (void) +{ + lex_match_id ("FORMATS"); + return internal_cmd_formats (FORMATS_PRINT | FORMATS_WRITE); +} + +int +internal_cmd_formats (int which) +{ + /* Variables. */ + struct variable **v; + int cv; + + /* Format to set the variables to. */ + struct fmt_spec f; + + /* Numeric or string. */ + int type; + + /* Counter. */ + int i; + + for (;;) + { + if (token == '.') + break; + + if (!parse_variables (NULL, &v, &cv, PV_SAME_TYPE)) + return CMD_PART_SUCCESS_MAYBE; + type = v[0]->type; + + if (!lex_match ('(')) + { + msg (SE, _("`(' expected after variable list")); + goto fail; + } + if (!parse_format_specifier (&f, 0) || !check_output_specifier (&f)) + goto fail; + + /* Catch type mismatch errors. */ + if ((type == ALPHA) ^ (0 != (formats[f.type].cat & FCAT_STRING))) + { + msg (SE, _("Format %s may not be assigned to a %s variable."), + fmt_to_string (&f), type == NUMERIC ? _("numeric") : _("string")); + goto fail; + } + + /* This is an additional check for string variables. We can't + let the user specify an A8 format for a string variable with + width 4. */ + if (type == ALPHA) + { + /* Shortest string so far. */ + int min_len = INT_MAX; + + for (i = 0; i < cv; i++) + min_len = min (min_len, v[i]->width); + if (!check_string_specifier (&f, min_len)) + goto fail; + } + + if (!lex_match (')')) + { + msg (SE, _("`)' expected after output format.")); + goto fail; + } + + for (i = 0; i < cv; i++) + { + if (which & FORMATS_PRINT) + v[i]->print = f; + if (which & FORMATS_WRITE) + v[i]->write = f; + } + free (v); + v = NULL; + } +#if DEBUGGING + debug_print (); +#endif + return CMD_SUCCESS; + +fail: + free (v); + return CMD_PART_SUCCESS_MAYBE; +} + +#if DEBUGGING +static void +debug_print (void) +{ + int i; + + printf (_("Formats:\n")); + printf (_(" Name Print Write\n")); + printf (" -------- ------------ ------------\n"); + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + printf (" %-8s %-12s", v->name, fmt_to_string (&v->print)); + printf (" %-12s\n", fmt_to_string (&v->write)); + } +} +#endif /* DEBUGGING */ diff --git a/src/frequencies.g b/src/frequencies.g new file mode 100644 index 00000000..eebb20c2 --- /dev/null +++ b/src/frequencies.g @@ -0,0 +1,89 @@ +/* PSPP - computes sample statistics. -*- C -*- + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* Included by frequencies.q. */ + +#if WEIGHTING + #define WEIGHT w + #define FUNCNAME calc_weighting +#else /* !WEIGHTING */ + #define WEIGHT 1.0 + #define FUNCNAME calc_no_weight +#endif /* !WEIGHTING */ + +static int +FUNCNAME (struct ccase *c) +{ + int i; +#if WEIGHTING + double w; + + w = c->data[default_dict.var[default_dict.weight_index]->fv].f; +#endif + + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + union value *val = &c->data[v->fv]; + struct freq_tab *ft = &v->p.frq.tab; + + switch (v->p.frq.tab.mode) + { + case FRQM_GENERAL: + { + /* General mode. This declaration and initialization are + strictly conforming: see C89 section 6.5.2.1. */ + struct freq *fp = avl_find (ft->tree, (struct freq *) val); + + if (fp) + fp->c += WEIGHT; + else + { + fp = pool_alloc (gen_pool, sizeof *fp); + fp->v = *val; + fp->c = WEIGHT; + avl_insert (ft->tree, fp); + if (is_missing (val, v)) + v->p.frq.tab.n_missing++; + } + } + break; + case FRQM_INTEGER: + /* Integer mode. */ + if (val->f == SYSMIS) + v->p.frq.tab.sysmis += WEIGHT; + else if (val->f > INT_MIN+1 && val->f < INT_MAX-1) + { + int i = val->f; + if (i >= v->p.frq.tab.min && i <= v->p.frq.tab.max) + v->p.frq.tab.vector[i - v->p.frq.tab.min] += WEIGHT; + } + else + v->p.frq.tab.out_of_range += WEIGHT; + break; + default: + assert (0); + } + } + return 1; +} + +#undef WEIGHT +#undef WEIGHTING +#undef FUNCNAME diff --git a/src/frequencies.q b/src/frequencies.q new file mode 100644 index 00000000..d40267e2 --- /dev/null +++ b/src/frequencies.q @@ -0,0 +1,1818 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* + TODO: + + * Remember that histograms, bar charts need mean, stddev. +*/ + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "bitvector.h" +#include "hash.h" +#include "pool.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "approx.h" +#include "magic.h" +#include "misc.h" +#include "stats.h" +#include "output.h" +#include "som.h" +#include "tab.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* (specification) + FREQUENCIES (frq_): + *variables=custom; + format=cond:condense/onepage(*n:onepage_limit,"%s>=0")/!standard, + table:limit(n:limit,"%s>0")/notable/!table, + labels:!labels/nolabels, + sort:!avalue/dvalue/afreq/dfreq, + spaces:!single/double, + paging:newpage/!oldpage; + missing=miss:include/!exclude; + barchart(ba_)=:minimum(d:min), + :maximum(d:max), + scale:freq(*n:freq,"%s>0")/percent(*n:pcnt,"%s>0"); + histogram(hi_)=:minimum(d:min), + :maximum(d:max), + scale:freq(*n:freq,"%s>0")/percent(*n:pcnt,"%s>0"), + norm:!nonormal/normal, + incr:increment(d:inc,"%s>0"); + hbar(hb_)=:minimum(d:min), + :maximum(d:max), + scale:freq(*n:freq,"%s>0")/percent(*n:pcnt,"%s>0"), + norm:!nonormal/normal, + incr:increment(d:inc,"%s>0"); + grouped=custom; + ntiles=custom; + percentiles=custom; + statistics[st_]=1|mean,2|semean,3|median,4|mode,5|stddev,6|variance, + 7|kurtosis,8|skewness,9|range,10|minimum,11|maximum,12|sum, + 13|default,14|seskewness,15|sekurtosis,all,none. +*/ +/* (declarations) */ +/* (functions) */ + +/* Description of a statistic. */ +struct frq_info + { + int st_indx; /* Index into a_statistics[]. */ + const char *s10; /* Identifying string. */ + }; + +/* Table of statistics, indexed by dsc_*. */ +static struct frq_info st_name[frq_n_stats + 1] = +{ + {FRQ_ST_MEAN, N_("Mean")}, + {FRQ_ST_SEMEAN, N_("S.E. Mean")}, + {FRQ_ST_MEDIAN, N_("Median")}, + {FRQ_ST_MODE, N_("Mode")}, + {FRQ_ST_STDDEV, N_("Std Dev")}, + {FRQ_ST_VARIANCE, N_("Variance")}, + {FRQ_ST_KURTOSIS, N_("Kurtosis")}, + {FRQ_ST_SEKURTOSIS, N_("S.E. Kurt")}, + {FRQ_ST_SKEWNESS, N_("Skewness")}, + {FRQ_ST_SESKEWNESS, N_("S.E. Skew")}, + {FRQ_ST_RANGE, N_("Range")}, + {FRQ_ST_MINIMUM, N_("Minimum")}, + {FRQ_ST_MAXIMUM, N_("Maximum")}, + {FRQ_ST_SUM, N_("Sum")}, + {-1, 0}, +}; + +/* Percentiles to calculate. */ +static double *percentiles; +static int n_percentiles; + +/* Groups of statistics. */ +#define BI BIT_INDEX +#define frq_default \ + (BI (frq_mean) | BI (frq_stddev) | BI (frq_min) | BI (frq_max)) +#define frq_all \ + (BI (frq_sum) | BI(frq_min) | BI(frq_max) \ + | BI(frq_mean) | BI(frq_semean) | BI(frq_stddev) \ + | BI(frq_variance) | BI(frq_kurt) | BI(frq_sekurt) \ + | BI(frq_skew) | BI(frq_seskew) | BI(frq_range) \ + | BI(frq_range) | BI(frq_mode) | BI(frq_median)) + +/* Statistics; number of statistics. */ +static unsigned long stats; +static int n_stats; + +/* Types of graphs. */ +enum + { + GFT_NONE, /* Don't draw graphs. */ + GFT_BAR, /* Draw bar charts. */ + GFT_HIST, /* Draw histograms. */ + GFT_HBAR /* Draw bar charts or histograms at our discretion. */ + }; + +/* Parsed command. */ +static struct cmd_frequencies cmd; + +/* Summary of the barchart, histogram, and hbar subcommands. */ +static int chart; /* NONE/BAR/HIST/HBAR. */ +static double min, max; /* Minimum, maximum on y axis. */ +static int format; /* FREQ/PERCENT: Scaling of y axis. */ +static double scale, incr; /* FIXME */ +static int normal; /* FIXME */ + +/* Variables for which to calculate statistics. */ +static int n_variables; +static struct variable **v_variables; + +/* Arenas used to store semi-permanent storage. */ +static struct pool *int_pool; /* Integer mode. */ +static struct pool *gen_pool; /* General mode. */ + +/* Easier access to a_statistics. */ +#define stat cmd.a_statistics + +static void determine_charts (void); + +static void precalc (void); +static int calc_weighting (struct ccase *); +static int calc_no_weight (struct ccase *); +static void postcalc (void); + +static void postprocess_freq_tab (struct variable *); +static void dump_full (struct variable *); +static void dump_condensed (struct variable *); +static void dump_statistics (struct variable *, int show_varname); +static void cleanup_freq_tab (struct variable *); + +static int compare_value_numeric_a (const void *, const void *, void *); +static int compare_value_alpha_a (const void *, const void *, void *); +static int compare_value_numeric_d (const void *, const void *, void *); +static int compare_value_alpha_d (const void *, const void *, void *); +static int compare_freq_numeric_a (const void *, const void *, void *); +static int compare_freq_alpha_a (const void *, const void *, void *); +static int compare_freq_numeric_d (const void *, const void *, void *); +static int compare_freq_alpha_d (const void *, const void *, void *); + +/* Parser and outline. */ + +static int internal_cmd_frequencies (void); + +int +cmd_frequencies (void) +{ + int result; + + int_pool = pool_create (); + result = internal_cmd_frequencies (); + pool_destroy (int_pool); + pool_destroy (gen_pool); + free (v_variables); + return result; +} + +static int +internal_cmd_frequencies (void) +{ + int (*calc) (struct ccase *); + int i; + + n_percentiles = 0; + percentiles = NULL; + + n_variables = 0; + v_variables = NULL; + + for (i = 0; i < default_dict.nvar; i++) + default_dict.var[i]->foo = 0; + + lex_match_id ("FREQUENCIES"); + if (!parse_frequencies (&cmd)) + return CMD_FAILURE; + + if (cmd.onepage_limit == NOT_LONG) + cmd.onepage_limit = 50; + + /* Figure out statistics to calculate. */ + stats = 0; + if (stat[FRQ_ST_DEFAULT] || !cmd.sbc_statistics) + stats |= frq_default; + if (stat[FRQ_ST_ALL]) + stats |= frq_all; + if (cmd.sort != FRQ_AVALUE && cmd.sort != FRQ_DVALUE) + stats &= ~frq_median; + for (i = 0; i < frq_n_stats; i++) + if (stat[st_name[i].st_indx]) + stats |= BIT_INDEX (i); + if (stats & frq_kurt) + stats |= frq_sekurt; + if (stats & frq_skew) + stats |= frq_seskew; + + /* Calculate n_stats. */ + n_stats = 0; + for (i = 0; i < frq_n_stats; i++) + if ((stats & BIT_INDEX (i))) + n_stats++; + + /* Charting. */ + determine_charts (); + if (chart != GFT_NONE || cmd.sbc_ntiles) + cmd.sort = FRQ_AVALUE; + + /* Do it! */ + update_weighting (&default_dict); + calc = default_dict.weight_index == -1 ? calc_no_weight : calc_weighting; + procedure (precalc, calc, postcalc); + + return CMD_SUCCESS; +} + +/* Figure out which charts the user requested. */ +static void +determine_charts (void) +{ + int count = (!!cmd.sbc_histogram) + (!!cmd.sbc_barchart) + (!!cmd.sbc_hbar); + + if (!count) + { + chart = GFT_NONE; + return; + } + else if (count > 1) + { + chart = GFT_HBAR; + msg (SW, _("At most one of BARCHART, HISTOGRAM, or HBAR should be " + "given. HBAR will be assumed. Argument values will be " + "given precedence increasing along the order given.")); + } + else if (cmd.sbc_histogram) + chart = GFT_HIST; + else if (cmd.sbc_barchart) + chart = GFT_BAR; + else + chart = GFT_HBAR; + + min = max = SYSMIS; + format = FRQ_FREQ; + scale = SYSMIS; + incr = SYSMIS; + normal = 0; + + if (cmd.sbc_barchart) + { + if (cmd.ba_min != SYSMIS) + min = cmd.ba_min; + if (cmd.ba_max != SYSMIS) + max = cmd.ba_max; + if (cmd.ba_scale == FRQ_FREQ) + { + format = FRQ_FREQ; + scale = cmd.ba_freq; + } + else if (cmd.ba_scale == FRQ_PERCENT) + { + format = FRQ_PERCENT; + scale = cmd.ba_pcnt; + } + } + + if (cmd.sbc_histogram) + { + if (cmd.hi_min != SYSMIS) + min = cmd.hi_min; + if (cmd.hi_max != SYSMIS) + max = cmd.hi_max; + if (cmd.hi_scale == FRQ_FREQ) + { + format = FRQ_FREQ; + scale = cmd.hi_freq; + } + else if (cmd.hi_scale == FRQ_PERCENT) + { + format = FRQ_PERCENT; + scale = cmd.ba_pcnt; + } + if (cmd.hi_norm) + normal = 1; + if (cmd.hi_incr == FRQ_INCREMENT) + incr = cmd.hi_inc; + } + + if (cmd.sbc_hbar) + { + if (cmd.hb_min != SYSMIS) + min = cmd.hb_min; + if (cmd.hb_max != SYSMIS) + max = cmd.hb_max; + if (cmd.hb_scale == FRQ_FREQ) + { + format = FRQ_FREQ; + scale = cmd.hb_freq; + } + else if (cmd.hb_scale == FRQ_PERCENT) + { + format = FRQ_PERCENT; + scale = cmd.ba_pcnt; + } + if (cmd.hb_norm) + normal = 1; + if (cmd.hb_incr == FRQ_INCREMENT) + incr = cmd.hb_inc; + } + + if (min != SYSMIS && max != SYSMIS && min >= max) + { + msg (SE, _("MAX must be greater than or equal to MIN, if both are " + "specified. However, MIN was specified as %g and MAX as %g. " + "MIN and MAX will be ignored."), min, max); + min = max = SYSMIS; + } +} + +/* Generate each calc_*(). */ +#define WEIGHTING 0 +#include "frequencies.g" + +#define WEIGHTING 1 +#include "frequencies.g" + +/* Prepares each variable that is the target of FREQUENCIES by setting + up its hash table. */ +static void +precalc (void) +{ + int i; + + pool_destroy (gen_pool); + gen_pool = pool_create (); + + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + + if (v->p.frq.tab.mode == FRQM_GENERAL) + { + avl_comparison_func compare; + if (v->type == NUMERIC) + compare = compare_value_numeric_a; + else + compare = compare_value_alpha_a; + v->p.frq.tab.tree = avl_create (gen_pool, compare, + (void *) v->width); + v->p.frq.tab.n_missing = 0; + } + else + { + int j; + + for (j = (v->p.frq.tab.max - v->p.frq.tab.min); j >= 0; j--) + v->p.frq.tab.vector[j] = 0.0; + v->p.frq.tab.out_of_range = 0.0; + v->p.frq.tab.sysmis = 0.0; + } + } +} + +/* Finishes up with the variables after frequencies have been + calculated. Displays statistics, percentiles, ... */ +static void +postcalc (void) +{ + int i; + + for (i = 0; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + int n_categories; + int dumped_freq_tab = 1; + + postprocess_freq_tab (v); + + /* Frequencies tables. */ + n_categories = v->p.frq.tab.n_valid + v->p.frq.tab.n_missing; + if (cmd.table == FRQ_TABLE + || (cmd.table == FRQ_LIMIT && n_categories <= cmd.limit)) + switch (cmd.cond) + { + case FRQ_CONDENSE: + dump_condensed (v); + break; + case FRQ_STANDARD: + dump_full (v); + break; + case FRQ_ONEPAGE: + if (n_categories > cmd.onepage_limit) + dump_condensed (v); + else + dump_full (v); + break; + default: + assert (0); + } + else + dumped_freq_tab = 0; + + /* Statistics. */ + if (n_stats) + dump_statistics (v, !dumped_freq_tab); + + cleanup_freq_tab (v); + } +} + +/* Comparison function called by comparison_helper(). */ +static avl_comparison_func comparison_func; + +/* Passed to comparison function by comparison_helper(). */ +static void *comparison_param; + +/* Used by postprocess_freq_tab to re-sort frequency tables. */ +static int +comparison_helper (const void *a, const void *b) +{ + return comparison_func (&((struct freq *) a)->v, + &((struct freq *) b)->v, comparison_param); +} + +/* Used by postprocess_freq_tab to construct the array members valid, + missing of freq_tab. */ +static void +add_freq (void *data, void *param) +{ + struct freq *f = data; + struct variable *v = param; + + v->p.frq.tab.total_cases += f->c; + + if ((v->type == NUMERIC && f->v.f == SYSMIS) + || (cmd.miss == FRQ_EXCLUDE && is_user_missing (&f->v, v))) + { + *v->p.frq.tab.missing++ = *f; + v->p.frq.tab.valid_cases -= f->c; + } + else + *v->p.frq.tab.valid++ = *f; +} + +static void +postprocess_freq_tab (struct variable * v) +{ + avl_comparison_func compare; + + switch (cmd.sort | (v->type << 16)) + { + /* Note that q2c generates tags beginning with 1000. */ + case FRQ_AVALUE | (NUMERIC << 16): + compare = NULL; + break; + case FRQ_AVALUE | (ALPHA << 16): + compare = NULL; + break; + case FRQ_DVALUE | (NUMERIC << 16): + comparison_func = compare_value_numeric_d; + break; + case FRQ_DVALUE | (ALPHA << 16): + compare = compare_value_alpha_d; + break; + case FRQ_AFREQ | (NUMERIC << 16): + compare = compare_freq_numeric_a; + break; + case FRQ_AFREQ | (ALPHA << 16): + compare = compare_freq_alpha_a; + break; + case FRQ_DFREQ | (NUMERIC << 16): + compare = compare_freq_numeric_d; + break; + case FRQ_DFREQ | (ALPHA << 16): + compare = compare_freq_alpha_d; + break; + default: + assert (0); + } + comparison_func = compare; + + if (v->p.frq.tab.mode == FRQM_GENERAL) + { + int total; + struct freq_tab *ft = &v->p.frq.tab; + + total = avl_count (ft->tree); + ft->n_valid = total - ft->n_missing; + ft->valid = xmalloc (sizeof (struct freq) * total); + ft->missing = &ft->valid[ft->n_valid]; + ft->valid_cases = ft->total_cases = 0.0; + + avl_walk (ft->tree, add_freq, (void *) v); + + ft->valid -= ft->n_valid; + ft->missing -= ft->n_missing; + ft->valid_cases += ft->total_cases; + + if (compare) + { + qsort (ft->valid, ft->n_valid, sizeof (struct freq), comparison_helper); + qsort (ft->missing, ft->n_missing, sizeof (struct freq), comparison_helper); + } + } + else + assert (0); +} + +static void +cleanup_freq_tab (struct variable * v) +{ + if (v->p.frq.tab.mode == FRQM_GENERAL) + { + struct freq_tab *ft = &v->p.frq.tab; + + free (ft->valid); + } + else + assert (0); +} + +/* Parses the VARIABLES subcommand, adding to + {n_variables,v_variables}. */ +static int +frq_custom_variables (struct cmd_frequencies *cmd unused) +{ + int mode; + int min, max; + + int old_n_variables = n_variables; + int i; + + lex_match ('='); + if (token != T_ALL && (token != T_ID || !is_varname (tokid))) + return 2; + + if (!parse_variables (NULL, &v_variables, &n_variables, + PV_APPEND | PV_NO_SCRATCH)) + return 0; + + for (i = old_n_variables; i < n_variables; i++) + v_variables[i]->p.frq.tab.mode = FRQM_GENERAL; + + if (!lex_match ('(')) + mode = FRQM_GENERAL; + else + { + mode = FRQM_INTEGER; + if (!lex_force_int ()) + return 0; + min = lex_integer (); + lex_get (); + if (!lex_force_match (',')) + return 0; + if (!lex_force_int ()) + return 0; + max = lex_integer (); + lex_get (); + if (!lex_force_match (')')) + return 0; + if (max < min) + { + msg (SE, _("Upper limit of integer mode value range must be " + "greater than lower limit.")); + return 0; + } + } + + for (i = old_n_variables; i < n_variables; i++) + { + struct variable *v = v_variables[i]; + + if (v->foo != 0) + { + msg (SE, _("Variable %s specified multiple times on VARIABLES " + "subcommand."), v->name); + return 0; + } + + v->foo = 1; /* Used simply as a marker. */ + + v->p.frq.tab.valid = v->p.frq.tab.missing = NULL; + + if (mode == FRQM_INTEGER) + { + if (v->type != NUMERIC) + { + msg (SE, _("Integer mode specified, but %s is not a numeric " + "variable."), v->name); + return 0; + } + + v->p.frq.tab.min = min; + v->p.frq.tab.max = max; + v->p.frq.tab.vector = pool_alloc (int_pool, + sizeof (struct freq) * (max - min + 1)); + } + else + v->p.frq.tab.vector = NULL; + + v->p.frq.n_groups = 0; + v->p.frq.groups = NULL; + } + return 1; +} + +/* Parses the GROUPED subcommand, setting the frq.{n_grouped,grouped} + fields of specified variables. */ +static int +frq_custom_grouped (struct cmd_frequencies *cmd unused) +{ + lex_match ('='); + if ((token == T_ID && is_varname (tokid)) || token == T_ID) + for (;;) + { + int i; + + /* Max, current size of list; list itself. */ + int nl, ml; + double *dl; + + /* Variable list. */ + int n; + struct variable **v; + + if (!parse_variables (NULL, &v, &n, PV_NO_DUPLICATE | PV_NUMERIC)) + return 0; + if (lex_match ('(')) + { + nl = ml = 0; + dl = NULL; + while (token == T_NUM) + { + if (nl >= ml) + { + ml += 16; + dl = pool_realloc (int_pool, dl, ml * sizeof (double)); + } + dl[nl++] = tokval; + lex_get (); + lex_match (','); + } + /* Note that nl might still be 0 and dl might still be + NULL. That's okay. */ + if (!lex_match (')')) + { + free (v); + msg (SE, _("`)' expected after GROUPED interval list.")); + return 0; + } + } + else + nl = 0; + + for (i = 0; i < n; i++) + { + if (v[i]->foo == 0) + msg (SE, _("Variables %s specified on GROUPED but not on " + "VARIABLES."), v[i]->name); + if (v[i]->p.frq.groups != NULL) + msg (SE, _("Variables %s specified multiple times on GROUPED " + "subcommand."), v[i]->name); + else + { + v[i]->p.frq.n_groups = nl; + v[i]->p.frq.groups = dl; + } + } + free (v); + if (!lex_match ('/')) + break; + if ((token != T_ID || !is_varname (tokid)) && token != T_ALL) + { + lex_put_back ('/'); + break; + } + } + + return 1; +} + +/* Adds X to the list of percentiles, keeping the list in proper + order. */ +static void +add_percentile (double x) +{ + int i; + + for (i = 0; i < n_percentiles; i++) + if (x <= percentiles[i]) + break; + if (i >= n_percentiles || tokval != percentiles[i]) + { + percentiles = pool_realloc (int_pool, percentiles, + (n_percentiles + 1) * sizeof (double)); + if (i < n_percentiles) + memmove (&percentiles[i + 1], &percentiles[i], + (n_percentiles - i) * sizeof (double)); + percentiles[i] = x; + n_percentiles++; + } +} + +/* Parses the PERCENTILES subcommand, adding user-specified + percentiles to the list. */ +static int +frq_custom_percentiles (struct cmd_frequencies *cmd unused) +{ + lex_match ('='); + if (token != T_NUM) + { + msg (SE, _("Percentile list expected after PERCENTILES.")); + return 0; + } + + do + { + if (tokval <= 0 || tokval >= 100) + { + msg (SE, _("Percentiles must be greater than " + "0 and less than 100.")); + return 0; + } + + add_percentile (tokval / 100.0); + lex_get (); + lex_match (','); + } + while (token == T_NUM); + return 1; +} + +/* Parses the NTILES subcommand, adding the percentiles that + correspond to the specified evenly-distributed ntiles. */ +static int +frq_custom_ntiles (struct cmd_frequencies *cmd unused) +{ + int i; + + lex_match ('='); + if (!lex_force_int ()) + return 0; + for (i = 1; i < lex_integer (); i++) + add_percentile (1.0 / lex_integer () * i); + lex_get (); + return 1; +} + +/* Comparison functions. */ + +/* Ascending numeric compare of values. */ +static int +compare_value_numeric_a (const void *a, const void *b, void *foo unused) +{ + return approx_compare (((struct freq *) a)->v.f, ((struct freq *) b)->v.f); +} + +/* Ascending string compare of values. */ +static int +compare_value_alpha_a (const void *a, const void *b, void *len) +{ + return memcmp (((struct freq *) a)->v.s, ((struct freq *) b)->v.s, (int) len); +} + +/* Descending numeric compare of values. */ +static int +compare_value_numeric_d (const void *a, const void *b, void *foo unused) +{ + return approx_compare (((struct freq *) b)->v.f, ((struct freq *) a)->v.f); +} + +/* Descending string compare of values. */ +static int +compare_value_alpha_d (const void *a, const void *b, void *len) +{ + return memcmp (((struct freq *) b)->v.s, ((struct freq *) a)->v.s, (int) len); +} + +/* Ascending numeric compare of frequency; + secondary key on ascending numeric value. */ +static int +compare_freq_numeric_a (const void *a, const void *b, void *foo unused) +{ + int x = approx_compare (((struct freq *) a)->c, ((struct freq *) b)->c); + return x ? x : approx_compare (((struct freq *) a)->v.f, ((struct freq *) b)->v.f); +} + +/* Ascending numeric compare of frequency; + secondary key on ascending string value. */ +static int +compare_freq_alpha_a (const void *a, const void *b, void *len) +{ + int x = approx_compare (((struct freq *) a)->c, ((struct freq *) b)->c); + return x ? x : memcmp (((struct freq *) a)->v.s, ((struct freq *) b)->v.s, (int) len); +} + +/* Descending numeric compare of frequency; + secondary key on ascending numeric value. */ +static int +compare_freq_numeric_d (const void *a, const void *b, void *foo unused) +{ + int x = approx_compare (((struct freq *) b)->c, ((struct freq *) a)->c); + return x ? x : approx_compare (((struct freq *) a)->v.f, ((struct freq *) b)->v.f); +} + +/* Descending numeric compare of frequency; + secondary key on ascending string value. */ +static int +compare_freq_alpha_d (const void *a, const void *b, void *len) +{ + int x = approx_compare (((struct freq *) b)->c, ((struct freq *) a)->c); + return x ? x : memcmp (((struct freq *) a)->v.s, ((struct freq *) b)->v.s, (int) len); +} + +/* Frequency table display. */ + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +full_dim (struct tab_table *t, struct outp_driver *d) +{ + int lab = cmd.labels == FRQ_LABELS; + int i; + + if (lab) + t->w[0] = min (tab_natural_width (t, d, 0), d->prop_em_width * 15); + for (i = lab; i < lab + 5; i++) + t->w[i] = max (tab_natural_width (t, d, i), d->prop_em_width * 8); + for (i = 0; i < t->nr; i++) + t->h[i] = d->font_height; +} + +/* Displays a full frequency table for variable V. */ +static void +dump_full (struct variable * v) +{ + int n_categories; + struct freq *f; + struct tab_table *t; + int r; + double cum_percent = 0.0; + double cum_freq = 0.0; + + struct init + { + int c, r; + const char *s; + }; + + struct init *p; + + static struct init vec[] = + { + {4, 0, N_("Valid")}, + {5, 0, N_("Cum")}, + {1, 1, N_("Value")}, + {2, 1, N_("Frequency")}, + {3, 1, N_("Percent")}, + {4, 1, N_("Percent")}, + {5, 1, N_("Percent")}, + {0, 0, NULL}, + {1, 0, NULL}, + {2, 0, NULL}, + {3, 0, NULL}, + {-1, -1, NULL}, + }; + + int lab = cmd.labels == FRQ_LABELS; + + n_categories = v->p.frq.tab.n_valid + v->p.frq.tab.n_missing; + t = tab_create (5 + lab, n_categories + 3, 0); + tab_headers (t, 0, 0, 2, 0); + tab_dim (t, full_dim); + + if (lab) + tab_text (t, 0, 1, TAB_CENTER | TAT_TITLE, _("Value Label")); + for (p = vec; p->s; p++) + tab_text (t, p->c - (p->r ? !lab : 0), p->r, + TAB_CENTER | TAT_TITLE, gettext (p->s)); + + r = 2; + for (f = v->p.frq.tab.valid; f < v->p.frq.tab.missing; f++) + { + double percent, valid_percent; + + cum_freq += f->c; + + percent = f->c / v->p.frq.tab.total_cases * 100.0; + valid_percent = f->c / v->p.frq.tab.valid_cases * 100.0; + cum_percent += valid_percent; + + if (lab) + { + char *label = get_val_lab (v, f->v, 0); + if (label != NULL) + tab_text (t, 0, r, TAB_LEFT, label); + } + + tab_value (t, 0 + lab, r, TAB_NONE, &f->v, &v->print); + tab_float (t, 1 + lab, r, TAB_NONE, f->c, 8, 0); + tab_float (t, 2 + lab, r, TAB_NONE, percent, 5, 1); + tab_float (t, 3 + lab, r, TAB_NONE, valid_percent, 5, 1); + tab_float (t, 4 + lab, r, TAB_NONE, cum_percent, 5, 1); + r++; + } + for (; f < &v->p.frq.tab.valid[n_categories]; f++) + { + cum_freq += f->c; + + if (lab) + { + char *label = get_val_lab (v, f->v, 0); + if (label != NULL) + tab_text (t, 0, r, TAB_LEFT, label); + } + + tab_value (t, 0 + lab, r, TAB_NONE, &f->v, &v->print); + tab_float (t, 1 + lab, r, TAB_NONE, f->c, 8, 0); + tab_float (t, 2 + lab, r, TAB_NONE, + f->c / v->p.frq.tab.total_cases * 100.0, 5, 1); + tab_text (t, 3 + lab, r, TAB_NONE, _("Missing")); + r++; + } + + tab_box (t, TAL_1, TAL_1, + cmd.spaces == FRQ_SINGLE ? -1 : (TAL_1 | TAL_SPACING), TAL_1, + 0, 0, 4 + lab, r); + tab_hline (t, TAL_2, 0, 4 + lab, 2); + tab_hline (t, TAL_2, 0, 4 + lab, r); + tab_joint_text (t, 0, r, 0 + lab, r, TAB_RIGHT | TAT_TITLE, _("Total")); + tab_vline (t, TAL_0, 1, r, r); + tab_float (t, 1 + lab, r, TAB_NONE, cum_freq, 8, 0); + tab_float (t, 2 + lab, r, TAB_NONE, 100.0, 5, 1); + tab_float (t, 3 + lab, r, TAB_NONE, 100.0, 5, 1); + + tab_title (t, 1, "%s: %s", v->name, v->label ? v->label : ""); + tab_submit (t); +} + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +condensed_dim (struct tab_table *t, struct outp_driver *d) +{ + int cum_w = max (outp_string_width (d, _("Cum")), + max (outp_string_width (d, _("Cum")), + outp_string_width (d, "000"))); + + int i; + + for (i = 0; i < 2; i++) + t->w[i] = max (tab_natural_width (t, d, i), d->prop_em_width * 8); + for (i = 2; i < 4; i++) + t->w[i] = cum_w; + for (i = 0; i < t->nr; i++) + t->h[i] = d->font_height; +} + +/* Display condensed frequency table for variable V. */ +static void +dump_condensed (struct variable * v) +{ + int n_categories; + struct freq *f; + struct tab_table *t; + int r; + double cum_percent = 0.0; + + n_categories = v->p.frq.tab.n_valid + v->p.frq.tab.n_missing; + t = tab_create (4, n_categories + 2, 0); + + tab_headers (t, 0, 0, 2, 0); + tab_text (t, 0, 1, TAB_CENTER | TAT_TITLE, _("Value")); + tab_text (t, 1, 1, TAB_CENTER | TAT_TITLE, _("Freq")); + tab_text (t, 2, 1, TAB_CENTER | TAT_TITLE, _("Pct")); + tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Cum")); + tab_text (t, 3, 1, TAB_CENTER | TAT_TITLE, _("Pct")); + tab_dim (t, condensed_dim); + + r = 2; + for (f = v->p.frq.tab.valid; f < v->p.frq.tab.missing; f++) + { + double percent; + + percent = f->c / v->p.frq.tab.total_cases * 100.0; + cum_percent += f->c / v->p.frq.tab.valid_cases * 100.0; + + tab_value (t, 0, r, TAB_NONE, &f->v, &v->print); + tab_float (t, 1, r, TAB_NONE, f->c, 8, 0); + tab_float (t, 2, r, TAB_NONE, percent, 3, 0); + tab_float (t, 3, r, TAB_NONE, cum_percent, 3, 0); + r++; + } + for (; f < &v->p.frq.tab.valid[n_categories]; f++) + { + tab_value (t, 0, r, TAB_NONE, &f->v, &v->print); + tab_float (t, 1, r, TAB_NONE, f->c, 8, 0); + tab_float (t, 2, r, TAB_NONE, + f->c / v->p.frq.tab.total_cases * 100.0, 3, 0); + r++; + } + + tab_box (t, TAL_1, TAL_1, + cmd.spaces == FRQ_SINGLE ? -1 : (TAL_1 | TAL_SPACING), TAL_1, + 0, 0, 3, r - 1); + tab_hline (t, TAL_2, 0, 3, 2); + tab_title (t, 1, "%s: %s", v->name, v->label ? v->label : ""); + tab_columns (t, SOM_COL_DOWN, 1); + tab_submit (t); +} + +/* Statistical display. */ + +/* Calculates all the pertinent statistics for variable V, putting + them in array D[]. FIXME: This could be made much more optimal. */ +static void +calc_stats (struct variable * v, double d[frq_n_stats]) +{ + double W = v->p.frq.tab.valid_cases; + double X_bar, M2, M3, M4; + struct freq *f; + + /* Calculate the mean. */ + X_bar = 0.0; + for (f = v->p.frq.tab.valid; f < v->p.frq.tab.missing; f++) + X_bar += f->v.f * f->c; + X_bar /= W; + + /* Calculate moments about the mean. */ + M2 = M3 = M4 = 0.0; + for (f = v->p.frq.tab.valid; f < v->p.frq.tab.missing; f++) + { + double dev = f->v.f - X_bar; + double tmp; + tmp = dev * dev; + M2 += f->c * tmp; + tmp *= dev; + M3 += f->c * tmp; + tmp *= dev; + M4 += f->c * tmp; + } + + /* Formulas below are taken from _SPSS Statistical Algorithms_. */ + d[frq_min] = v->p.frq.tab.valid[0].v.f; + d[frq_max] = v->p.frq.tab.missing[-1].v.f; + d[frq_mode] = 0.0; + d[frq_range] = d[frq_max] - d[frq_min]; + d[frq_median] = 0.0; + d[frq_mean] = X_bar; + d[frq_sum] = X_bar * W; + d[frq_variance] = M2 / (W - 1); + d[frq_stddev] = sqrt (d[frq_variance]); + d[frq_semean] = d[frq_stddev] / sqrt (W); + if (W >= 3.0 && d[frq_variance] > 0) + { + double S = d[frq_stddev]; + d[frq_skew] = (W * M3 / ((W - 1.0) * (W - 2.0) * S * S * S)); + d[frq_seskew] = sqrt (6.0 * W * (W - 1.0) + / ((W - 2.0) * (W + 1.0) * (W + 3.0))); + } + else + { + d[frq_skew] = d[frq_seskew] = SYSMIS; + } + if (W >= 4.0 && d[frq_variance] > 0) + { + double S2 = d[frq_variance]; + double SE_g1 = d[frq_seskew]; + + d[frq_kurt] = ((W * (W + 1.0) * M4 - 3.0 * M2 * M2 * (W - 1.0)) + / ((W - 1.0) * (W - 2.0) * (W - 3.0) * S2 * S2)); + d[frq_sekurt] = sqrt ((4.0 * (W * W - 1.0) * SE_g1 * SE_g1) + / ((W - 3.0) * (W + 5.0))); + } + else + { + d[frq_kurt] = d[frq_sekurt] = SYSMIS; + } +} + +/* Displays a table of all the statistics requested for variable V. */ +static void +dump_statistics (struct variable * v, int show_varname) +{ + double stat_value[frq_n_stats]; + struct tab_table *t; + int i, r; + + if (v->type == ALPHA) + return; + if (v->p.frq.tab.n_valid == 0) + { + msg (SW, _("No valid data for variable %s; statistics not displayed."), + v->name); + return; + } + calc_stats (v, stat_value); + + t = tab_create (2, n_stats, 0); + tab_dim (t, tab_natural_dimensions); + tab_vline (t, TAL_1 | TAL_SPACING, 1, 0, n_stats - 1); + for (i = r = 0; i < frq_n_stats; i++) + if (stats & BIT_INDEX (i)) + { + tab_text (t, 0, r, TAB_LEFT | TAT_TITLE, + gettext (st_name[i].s10)); + tab_float (t, 1, r, TAB_NONE, stat_value[i], 11, 3); + r++; + } + + tab_columns (t, SOM_COL_DOWN, 1); + if (show_varname) + { + if (v->label) + tab_title (t, 1, "%s: %s", v->name, v->label); + else + tab_title (t, 0, v->name); + } + else + tab_flags (t, SOMF_NO_TITLE); + + tab_submit (t); +} + +#if 0 +/* Statistical calculation. */ + +static int degree[6]; +static int maxdegree, minmax; + +static void stat_func (struct freq *, VISIT, int); +static void calc_stats (int); +static void display_stats (int); + +/* mapping of data[]: + * 0=>8 + * 1=>9 + * 2=>10 + * index 3: number of modes found (detects multiple modes) + * index 4: number of nodes processed, for calculation of median + * 5=>11 + * + * mapping of dbl[]: + * index 0-3: sum of X**i + * index 4: minimum + * index 5: maximum + * index 6: mode + * index 7: median + * index 8: number of cases, valid and missing + * index 9: number of valid cases + * index 10: maximum frequency found, for calculation of mode + * index 11: maximum frequency + */ +static void +out_stats (int i) +{ + int j; + + if (cur_var->type == ALPHA) + return; + for (j = 0; j < 8; j++) + cur_var->dbl[j] = 0.; + cur_var->dbl[10] = 0; + cur_var->dbl[4] = DBL_MAX; + cur_var->dbl[5] = -DBL_MAX; + for (j = 2; j < 5; j++) + cur_var->data[j] = 0; + cur_var->p.frq.median_ncases = cur_var->p.frq.t.valid_cases / 2; + avlwalk (cur_var->p.frq.t.f, stat_func, LEFT_TO_RIGHT); + calc_stats (i); + display_stats (i); +} + +static void +calc_stats (int i) +{ + struct variable *v; + double n; + double *d; + + v = v_variables[i]; + n = v->p.frq.t.valid_cases; + d = v->dbl; + + if (n < 2 || (n < 3 && stat[FRQ_ST_7])) + { + warn (_("only %g case%s for variable %s, statistics not " + "computed"), n, n == 1 ? "" : "s", v->name); + return; + } + if (stat[FRQ_ST_9]) + v->res[FRQ_ST_9] = d[5] - d[4]; + if (stat[FRQ_ST_10]) + v->res[FRQ_ST_10] = d[4]; + if (stat[FRQ_ST_11]) + v->res[FRQ_ST_11] = d[5]; + if (stat[FRQ_ST_12]) + v->res[FRQ_ST_12] = d[0]; + if (stat[FRQ_ST_1] || stat[FRQ_ST_2] || stat[FRQ_ST_5] || stat[FRQ_ST_6] || stat[FRQ_ST_7]) + { + v->res[FRQ_ST_1] = calc_mean (d, n); + v->res[FRQ_ST_6] = calc_variance (d, n); + } + if (stat[FRQ_ST_2] || stat[FRQ_ST_5] || stat[FRQ_ST_7]) + v->res[FRQ_ST_5] = calc_stddev (v->res[FRQ_ST_6]); + if (stat[FRQ_ST_2]) + v->res[FRQ_ST_2] = calc_semean (v->res[FRQ_ST_5], n); + if (stat[FRQ_ST_7]) + { + v->res[FRQ_ST_7] = calc_kurt (d, n, v->res[FRQ_ST_6]); + v->res[FRQ_ST_14] = calc_sekurt (n); + } + if (stat[FRQ_ST_8]) + { + v->res[FRQ_ST_8] = calc_skew (d, n, v->res[FRQ_ST_5]); + v->res[FRQ_ST_15] = calc_seskew (n); + } + if (stat[FRQ_ST_MODE]) + { + v->res[FRQ_ST_MODE] = v->dbl[6]; + if (v->data[3] > 1) + warn (_("The variable %s has %d modes. The lowest of these " + "is the one given in the table."), v->name, v->data[3]); + } + if (stat[FRQ_ST_MEDIAN]) + v->res[FRQ_ST_MEDIAN] = v->dbl[7]; +} + +static void +stat_func (struct freq * x, VISIT order, int param) +{ + double d, f; + + if (order != INORDER) + return; + f = d = x->v.f; + cur_var->dbl[0] += (d * x->c); + switch (maxdegree) + { + case 1: + f *= d; + cur_var->dbl[1] += (f * x->c); + break; + case 2: + f *= d; + cur_var->dbl[1] += (f * x->c); + f *= d; + cur_var->dbl[2] += (f * x->c); + break; + case 3: + f *= d; + cur_var->dbl[1] += (f * x->c); + f *= d; + cur_var->dbl[2] += (f * x->c); + f *= d; + cur_var->dbl[3] += (f * x->c); + break; + } + if (minmax) + { + if (d < cur_var->dbl[4]) + cur_var->dbl[4] = d; + if (d > cur_var->dbl[5]) + cur_var->dbl[5] = d; + } + if (x->c > cur_var->dbl[10]) + { + cur_var->data[3] = 1; + cur_var->dbl[10] = x->c; + cur_var->dbl[6] = x->v.f; + } + else if (x->c == cur_var->dbl[10]) + cur_var->data[3]++; + if (cur_var->data[4] < cur_var->p.frq.median_ncases + && cur_var->data[4] + x->c >= cur_var->p.frq.median_ncases) + cur_var->dbl[7] = x->v.f; + cur_var->data[4] += x->c; +} + +/* Statistical display. */ +static int column, ncolumns; + +static void outstat (char *, double); + +static void +display_stats (int i) +{ + statname *sp; + struct variable *v; + int nlines; + + v = v_variables[i]; + ncolumns = (margin_width + 3) / 26; + if (ncolumns < 1) + ncolumns = 1; + nlines = sc / ncolumns + (sc % ncolumns > 0); + if (nlines == 2 && sc == 4) + ncolumns = 2; + if (nlines == 3 && sc == 9) + ncolumns = 3; + if (nlines == 4 && sc == 12) + ncolumns = 3; + column = 0; + for (sp = st_name; sp->s != -1; sp++) + if (stat[sp->s] == 1) + outstat (gettext (sp->s10), v->res[sp->s]); + if (column) + out_eol (); + blank_line (); +} + +static void +outstat (char *label, double value) +{ + char buf[128], *cp; + int dw, n; + + cp = &buf[0]; + if (!column) + out_header (); + else + { + memset (buf, ' ', 3); + cp = &buf[3]; + } + dw = 4; + n = nsprintf (cp, "%-10s %12.4f", label, value); + while (n > 23 && dw > 0) + n = nsprintf (cp, "%-10s %12.*f", label, --dw, value); + outs (buf); + column++; + if (column == ncolumns) + { + column = 0; + out_eol (); + } +} + +/* Graphs. */ + +static rect pb, gb; /* Page border, graph border. */ +static int px, py; /* Page width, height. */ +static int ix, iy; /* Inch width, height. */ + +static void draw_bar_chart (int); +static void draw_histogram (int); +static int scale_dep_axis (int); + +static void +out_graphs (int i) +{ + struct variable *v; + + v = v_variables[i]; + if (avlcount (cur_var->p.frq.t.f) < 2 + || (chart == HIST && v_variables[i]->type == ALPHA)) + return; + if (driver_id && set_highres == 1) + { + char *text; + + graf_page_size (&px, &py, &ix, &iy); + graf_feed_page (); + + /* Calculate borders. */ + pb.x1 = ix; + pb.y1 = iy; + pb.x2 = px - ix; + pb.y2 = py - iy; + gb.x1 = pb.x1 + ix; + gb.y1 = pb.y1 + iy; + gb.x2 = pb.x2 - ix / 2; + gb.y2 = pb.y2 - iy; + + /* Draw borders. */ + graf_frame_rect (COMPONENTS (pb)); + graf_frame_rect (COMPONENTS (gb)); + + /* Draw axis labels. */ + graf_font_size (iy / 4); /* 18-point text */ + text = format == PERCENT ? _("Percentage") : _("Frequency"); + graf_text (pb.x1 + max (ix, iy) / 4 + max (ix, iy) / 16, gb.y2, text, + SIDEWAYS); + text = v->label ? v->label : v->name; + graf_text (gb.x1, pb.y2 - iy / 4, text, UPRIGHT); + + /* Draw axes, chart proper. */ + if (chart == BAR || + (chart == HBAR + && (avlcount (cur_var->p.frq.t.f) || v_variables[i]->type == ALPHA))) + draw_bar_chart (i); + else + draw_histogram (i); + + graf_eject_page (); + } + if (set_lowres == 1 || (set_lowres == 2 && (!driver_id || !set_highres))) + { + static warned; + + /* Do character-based graphs. */ + if (!warned) + { + warn (_("low-res graphs not implemented")); + warned = 1; + } + } +} + +#if __GNUC__ && !__CHECKER__ +#define BIG_TYPE long long +#else /* !__GNUC__ */ +#define BIG_TYPE double +#endif /* !__GNUC__ */ + +static void +draw_bar_chart (int i) +{ + int bar_width, bar_spacing; + int w, max, row; + double val; + struct freq *f; + rect r; + AVLtraverser *t = NULL; + + w = (px - ix * 7 / 2) / avlcount (cur_var->p.frq.t.f); + bar_width = w * 2 / 3; + bar_spacing = w - bar_width; + +#if !ALLOW_HUGE_BARS + if (bar_width > ix / 2) + bar_width = ix / 2; +#endif /* !ALLOW_HUGE_BARS */ + + max = scale_dep_axis (cur_var->p.frq.t.max_freq); + + row = 0; + r.x1 = gb.x1 + bar_spacing / 2; + r.x2 = r.x1 + bar_width; + r.y2 = gb.y2; + graf_fill_color (255, 0, 0); + for (f = avltrav (cur_var->p.frq.t.f, &t); f; + f = avltrav (cur_var->p.frq.t.f, &t)) + { + char buf2[64]; + char *buf; + + val = f->c; + if (format == PERCENT) + val = val * 100 / cur_var->p.frq.t.valid_cases; + r.y1 = r.y2 - val * (height (gb) - 1) / max; + graf_fill_rect (COMPONENTS (r)); + graf_frame_rect (COMPONENTS (r)); + buf = get_val_lab (cur_var, f->v, 0); + if (!buf) + if (cur_var->type == ALPHA) + buf = f->v.s; + else + { + sprintf (buf2, "%g", f->v.f); + buf = buf2; + } + graf_text (r.x1 + bar_width / 2, + gb.y2 + iy / 32 + row * iy / 9, buf, TCJUST); + row ^= 1; + r.x1 += bar_width + bar_spacing; + r.x2 += bar_width + bar_spacing; + } + graf_fill_color (0, 0, 0); +} + +#define round_down(X, V) \ + (floor ((X) / (V)) * (V)) +#define round_up(X, V) \ + (ceil ((X) / (V)) * (V)) + +static void +draw_histogram (int i) +{ + double lower, upper, interval; + int bars[MAX_HIST_BARS + 1], top, j; + int err, addend, rem, nbars, row, max_freq; + char buf[25]; + rect r; + struct freq *f; + AVLtraverser *t = NULL; + + lower = min == SYSMIS ? cur_var->dbl[4] : min; + upper = max == SYSMIS ? cur_var->dbl[5] : max; + if (upper - lower >= 10) + { + double l, u; + + u = round_up (upper, 5); + l = round_down (lower, 5); + nbars = (u - l) / 5; + if (nbars * 2 + 1 <= MAX_HIST_BARS) + { + nbars *= 2; + u = round_up (upper, 2.5); + l = round_down (lower, 2.5); + if (l + 1.25 <= lower && u - 1.25 >= upper) + nbars--, lower = l + 1.25, upper = u - 1.25; + else if (l + 1.25 <= lower) + lower = l + 1.25, upper = u + 1.25; + else if (u - 1.25 >= upper) + lower = l - 1.25, upper = u - 1.25; + else + nbars++, lower = l - 1.25, upper = u + 1.25; + } + else if (nbars < MAX_HIST_BARS) + { + if (l + 2.5 <= lower && u - 2.5 >= upper) + nbars--, lower = l + 2.5, upper = u - 2.5; + else if (l + 2.5 <= lower) + lower = l + 2.5, upper = u + 2.5; + else if (u - 2.5 >= upper) + lower = l - 2.5, upper = u - 2.5; + else + nbars++, lower = l - 2.5, upper = u + 2.5; + } + else + nbars = MAX_HIST_BARS; + } + else + { + nbars = avlcount (cur_var->p.frq.t.f); + if (nbars > MAX_HIST_BARS) + nbars = MAX_HIST_BARS; + } + if (nbars < MIN_HIST_BARS) + nbars = MIN_HIST_BARS; + interval = (upper - lower) / nbars; + + memset (bars, 0, sizeof (int[nbars + 1])); + if (lower >= upper) + { + msg (SE, _("Could not make histogram for %s for specified " + "minimum %g and maximum %g; please discard graph."), cur_var->name, + lower, upper); + return; + } + for (f = avltrav (cur_var->p.frq.t.f, &t); f; + f = avltrav (cur_var->p.frq.t.f, &t)) + if (f->v.f == upper) + bars[nbars - 1] += f->c; + else if (f->v.f >= lower && f->v.f < upper) + bars[(int) ((f->v.f - lower) / interval)] += f->c; + bars[nbars - 1] += bars[nbars]; + for (j = top = 0; j < nbars; j++) + if (bars[j] > top) + top = bars[j]; + max_freq = top; + top = scale_dep_axis (top); + + err = row = 0; + addend = width (gb) / nbars; + rem = width (gb) % nbars; + r.x1 = gb.x1; + r.x2 = r.x1 + addend; + r.y2 = gb.y2; + err += rem; + graf_fill_color (255, 0, 0); + for (j = 0; j < nbars; j++) + { + int w; + + r.y1 = r.y2 - (BIG_TYPE) bars[j] * (height (gb) - 1) / top; + graf_fill_rect (COMPONENTS (r)); + graf_frame_rect (COMPONENTS (r)); + sprintf (buf, "%g", lower + interval / 2 + interval * j); + graf_text (r.x1 + addend / 2, + gb.y2 + iy / 32 + row * iy / 9, buf, TCJUST); + row ^= 1; + w = addend; + err += rem; + while (err >= addend) + { + w++; + err -= addend; + } + r.x1 = r.x2; + r.x2 = r.x1 + w; + } + if (normal) + { + double x, y, variance, mean, step, factor; + + variance = cur_var->res[FRQ_ST_VARIANCE]; + mean = cur_var->res[FRQ_ST_MEAN]; + factor = (1. / (sqrt (2. * PI * variance)) + * cur_var->p.frq.t.valid_cases * interval); + graf_polyline_begin (); + for (x = lower, step = (upper - lower) / (POLYLINE_DENSITY); + x <= upper; x += step) + { + y = factor * exp (-square (x - mean) / (2. * variance)); + debug_printf (("(%20.10f, %20.10f)\n", x, y)); + graf_polyline_point (gb.x1 + (x - lower) / (upper - lower) * width (gb), + gb.y2 - y * (height (gb) - 1) / top); + } + graf_polyline_end (); + } + graf_fill_color (0, 0, 0); +} + +static int +scale_dep_axis (int max) +{ + int j, s, x, y, ty, by; + char buf[10]; + + x = 10, s = 2; + if (scale != SYSMIS && max < scale) + x = scale, s = scale / 5; + else if (format == PERCENT) + { + max = ((BIG_TYPE) 100 * cur_var->p.frq.t.max_freq + / cur_var->p.frq.t.valid_cases + 1); + if (max < 5) + x = 5, s = 1; + else if (max < 10) + x = 10, s = 2; + else if (max < 25) + x = 25, s = 5; + else if (max < 50) + x = 50, s = 10; + else + max = 100, s = 20; + } + else /* format==FREQ */ + /* Uses a progression of 10, 20, 50, 100, 200, 500, ... */ + for (;;) + { + if (x > max) + break; + x *= 2; + s *= 2; + if (x > max) + break; + x = x / 2 * 5; + s = s / 2 * 5; + if (x > max) + break; + x *= 2; + s *= 2; + } + graf_font_size (iy / 9); /* 8-pt text */ + for (j = 0; j <= x; j += s) + { + y = gb.y2 - (BIG_TYPE) j *(height (gb) - 1) / x; + ty = y - iy / 64; + by = y + iy / 64; + if (ty < gb.y1) + ty += iy / 64, by += iy / 64; + else if (by > gb.y2) + ty -= iy / 64, by -= iy / 64; + graf_fill_rect (gb.x1 - ix / 16, ty, gb.x1, by); + sprintf (buf, "%d", j); + graf_text (gb.x1 - ix / 8, (ty + by) / 2, buf, CRJUST); + } + return x; +} + +/* Percentiles. */ + +static void ungrouped_pcnt (int i); +static int grouped_interval_pcnt (int i); +static void out_pcnt (double, double); + +static void +out_percentiles (int i) +{ + if (cur_var->type == ALPHA || !n_percentiles) + return; + + outs_line (_("Percentile Value " + "Percentile Value " + "Percentile Value")); + blank_line (); + + column = 0; + if (!g_var[i]) + ungrouped_pcnt (i); + else if (g_var[i] == 1) + grouped_interval_pcnt (i); +#if 0 + else if (g_var[i] == -1) + grouped_pcnt (i); + else + grouped_boundaries_pcnt (i); +#else /* !0 */ + else + warn (_("this form of percentiles not supported")); +#endif + if (column) + out_eol (); +} + +static void +out_pcnt (double pcnt, double value) +{ + if (!column) + out_header (); + else + outs (" "); + out ("%7.2f%13.3f", pcnt * 100., value); + column++; + if (column == 3) + { + out_eol (); + column = 0; + } +} + +static void +ungrouped_pcnt (int i) +{ + AVLtraverser *t = NULL; + struct freq *f; + double *p, *e; + int sum; + + p = percentiles; + e = &percentiles[n_percentiles]; + sum = 0; + for (f = avltrav (cur_var->p.frq.t.f, &t); + f && p < e; f = avltrav (cur_var->p.frq.t.f, &t)) + { + sum += f->c; + while (sum >= p[0] * cur_var->p.frq.t.valid_cases && p < e) + out_pcnt (*p++, f->v.f); + } +} + + +static int +grouped_interval_pcnt (int i) +{ + AVLtraverser * t = NULL; + struct freq * f, *fp; + double *p, *e, w; + int sum, psum; + + p = percentiles; + e = &percentiles[n_percentiles]; + w = gl_var[i][0]; + sum = psum = 0; + for (fp = 0, f = avltrav (cur_var->p.frq.t.f, &t); + f && p < e; + fp = f, f = avltrav (cur_var->p.frq.t.f, &t)) + { + if (fp) + if (fabs (f->v.f - fp->v.f) < w) + { + out_eol (); + column = 0; + return msg (SE, _("Difference between %g and %g is " + "too small for grouping interval %g."), f->v.f, + fp->v.f, w); + } + psum = sum; + sum += f->c; + while (sum >= p[0] * cur_var->p.frq.t.valid_cases && p < e) + { + out_pcnt (p[0], (((p[0] * cur_var->p.frq.t.valid_cases) - psum) * w / f->c + + (f->v.f - w / 2))); + p++; + } + } + return 1; +} +#endif + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/get.c b/src/get.c new file mode 100644 index 00000000..8f4a05f3 --- /dev/null +++ b/src/get.c @@ -0,0 +1,1610 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "error.h" +#include "file-handle.h" +#include "lexer.h" +#include "misc.h" +#include "pfm.h" +#include "settings.h" +#include "sfm.h" +#include "str.h" +#include "var.h" +#include "vfm.h" +#include "vfmP.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* XSAVE transformation (and related SAVE, EXPORT procedures). */ +struct save_trns + { + struct trns_header h; + struct file_handle *f; /* Associated system file. */ + int nvar; /* Number of variables. */ + int *var; /* Indices of variables. */ + flt64 *case_buf; /* Case transfer buffer. */ + }; + +/* Options bits set by trim_dictionary(). */ +#define GTSV_OPT_COMPRESSED 001 /* Compression; (X)SAVE only. */ +#define GTSV_OPT_SAVE 002 /* The SAVE/XSAVE/EXPORT procedures. */ +#define GTSV_OPT_MATCH_FILES 004 /* The MATCH FILES procedure. */ +#define GTSV_OPT_NONE 0 + +/* The file being read by the input program. */ +static struct file_handle *get_file; + +/* The transformation being used by the SAVE procedure. */ +static struct save_trns *trns; + +static int trim_dictionary (struct dictionary * dict, int *options); +static int save_write_case_func (struct ccase *); +static int save_trns_proc (struct trns_header *, struct ccase *); +static void save_trns_free (struct trns_header *); + +#if DEBUGGING +void dump_dict_variables (struct dictionary *); +#endif + +/* Parses the GET command. */ +int +cmd_get (void) +{ + struct file_handle *handle; + struct dictionary *dict; + int options = GTSV_OPT_NONE; + + int i; + int nval; + + lex_match_id ("GET"); + discard_variables (); + + lex_match ('/'); + if (lex_match_id ("FILE")) + lex_match ('='); + + handle = fh_parse_file_handle (); + if (handle == NULL) + return CMD_FAILURE; + + dict = sfm_read_dictionary (handle, NULL); + if (dict == NULL) + return CMD_FAILURE; + +#if DEBUGGING + dump_dict_variables (dict); +#endif + if (0 == trim_dictionary (dict, &options)) + { + fh_close_handle (handle); + return CMD_FAILURE; + } +#if DEBUGGING + dump_dict_variables (dict); +#endif + + /* Set the fv and lv elements of all variables remaining in the + dictionary. */ + nval = 0; + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + v->fv = nval; + nval += v->nv; + } + dict->nval = nval; + assert (nval); + +#if DEBUGGING + printf (_("GET translation table from file to memory:\n")); + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + printf (_(" %8s from %3d,%3d to %3d,%3d\n"), v->name, + v->get.fv, v->get.nv, v->fv, v->nv); + } +#endif + + restore_dictionary (dict); + + vfm_source = &get_source; + get_file = handle; + + return CMD_SUCCESS; +} + +/* Parses the SAVE (for X==0) and XSAVE (for X==1) commands. */ +/* FIXME: save_dictionary() is too expensive. It would make more + sense to copy just the first few fields of each variables (up to + `foo'): that's a SMOP. */ +int +cmd_save_internal (int x) +{ + struct file_handle *handle; + struct dictionary *dict; + int options = GTSV_OPT_SAVE; + + struct save_trns *t; + struct sfm_write_info inf; + + int i; + + lex_match_id ("SAVE"); + + lex_match ('/'); + if (lex_match_id ("OUTFILE")) + lex_match ('='); + + handle = fh_parse_file_handle (); + if (handle == NULL) + return CMD_FAILURE; + + dict = save_dictionary (); +#if DEBUGGING + dump_dict_variables (dict); +#endif + for (i = 0; i < dict->nvar; i++) + dict->var[i]->foo = i; + if (0 == trim_dictionary (dict, &options)) + { + fh_close_handle (handle); + return CMD_FAILURE; + } + +#if DEBUGGING + dump_dict_variables (dict); +#endif + + /* Write dictionary. */ + inf.h = handle; + inf.dict = dict; + inf.compress = !!(options & GTSV_OPT_COMPRESSED); + if (!sfm_write_dictionary (&inf)) + { + free_dictionary (dict); + fh_close_handle (handle); + return CMD_FAILURE; + } + + /* Fill in transformation structure. */ + t = trns = xmalloc (sizeof *t); + t->h.proc = save_trns_proc; + t->h.free = save_trns_free; + t->f = handle; + t->nvar = dict->nvar; + t->var = xmalloc (sizeof *t->var * dict->nvar); + for (i = 0; i < dict->nvar; i++) + t->var[i] = dict->var[i]->foo; + t->case_buf = xmalloc (sizeof *t->case_buf * inf.case_size); + free_dictionary (dict); + + if (x == 0) + /* SAVE. */ + { + procedure (NULL, save_write_case_func, NULL); + save_trns_free ((struct trns_header *) t); + } + else + /* XSAVE. */ + add_transformation ((struct trns_header *) t); + + return CMD_SUCCESS; +} + +/* Parses and performs the SAVE procedure. */ +int +cmd_save (void) +{ + return cmd_save_internal (0); +} + +/* Parses the XSAVE transformation command. */ +int +cmd_xsave (void) +{ + return cmd_save_internal (1); +} + +static int +save_write_case_func (struct ccase * c) +{ + save_trns_proc ((struct trns_header *) trns, c); + return 1; +} + +static int +save_trns_proc (struct trns_header * t unused, struct ccase * c) +{ + flt64 *p = trns->case_buf; + int i; + + for (i = 0; i < trns->nvar; i++) + { + struct variable *v = default_dict.var[trns->var[i]]; + if (v->type == NUMERIC) + { + double src = c->data[v->fv].f; + if (src == SYSMIS) + *p++ = -FLT64_MAX; + else + *p++ = src; + } + else + { + memcpy (p, c->data[v->fv].s, v->width); + memset (&((char *) p)[v->width], ' ', + REM_RND_UP (v->width, sizeof *p)); + p += DIV_RND_UP (v->width, sizeof *p); + } + } + + sfm_write_case (trns->f, trns->case_buf, p - trns->case_buf); + return -1; +} + +static void +save_trns_free (struct trns_header *pt) +{ + struct save_trns *t = (struct save_trns *) pt; + + fh_close_handle (t->f); + free (t->var); + free (t->case_buf); + free (t); +} + +/* Deletes NV variables from DICT, starting at index FIRST. The + variables must have consecutive indices. The variables are cleared + and freed. */ +static void +dict_delete_run (struct dictionary *dict, int first, int nv) +{ + int i; + + for (i = first; i < first + nv; i++) + { + clear_variable (dict, dict->var[i]); + free (dict->var[i]); + } + for (i = first; i < dict->nvar - nv; i++) + { + dict->var[i] = dict->var[i + nv]; + dict->var[i]->index -= nv; + } + dict->nvar -= nv; +} + +static int rename_variables (struct dictionary * dict); + +/* The GET and SAVE commands have a common structure after the + FILE/OUTFILE subcommand. This function parses this structure and + returns nonzero on success, zero on failure. It both reads + *OPTIONS, for the GTSV_OPT_SAVE bit, and writes it, for the + GTSV_OPT_COMPRESSED bit. */ +/* FIXME: IN, FIRST, LAST, MAP. */ +static int +trim_dictionary (struct dictionary *dict, int *options) +{ + if (set_scompression) + *options |= GTSV_OPT_COMPRESSED; + + if (*options & GTSV_OPT_SAVE) + { + int i; + + /* Delete all the scratch variables. */ + for (i = 0; i < dict->nvar; i++) + { + int j; + + if (dict->var[i]->name[0] != '#') + continue; + + /* Find a run of variables to be deleted. */ + for (j = i + 1; j < dict->nvar; j++) + if (dict->var[j]->name[0] != '#') + break; + + /* Actually delete 'em. */ + dict_delete_run (dict, i, j - i); + } + } + + while ((*options & GTSV_OPT_MATCH_FILES) || lex_match ('/')) + { + if (!(*options & GTSV_OPT_MATCH_FILES) && lex_match_id ("COMPRESSED")) + *options |= GTSV_OPT_COMPRESSED; + else if (!(*options & GTSV_OPT_MATCH_FILES) && lex_match_id ("UNCOMPRESSED")) + *options &= ~GTSV_OPT_COMPRESSED; + else if (lex_match_id ("DROP")) + { + struct variable **v; + int nv; + int i; + + lex_match ('='); + if (!parse_variables (dict, &v, &nv, PV_NONE)) + return 0; + + /* Loop through the variables to delete. */ + for (i = 0; i < nv;) + { + int j; + + /* Find a run of variables to be deleted. */ + for (j = i + 1; j < nv; j++) + if (v[j]->index != v[j - 1]->index + 1) + break; + + /* Actually delete 'em. */ + dict_delete_run (dict, v[i]->index, j - i); + i = j; + } + } + else if (lex_match_id ("KEEP")) + { + struct variable **v; + int nv; + + lex_match ('='); + if (!parse_variables (dict, &v, &nv, PV_NONE)) + return 0; + + /* Reorder the dictionary so that the kept variables are at + the beginning. */ + { + int i1; + + for (i1 = 0; i1 < nv; i1++) + { + int i2 = v[i1]->index; + + /* Swap variables with indices i1 and i2. */ + struct variable *t = dict->var[i1]; + dict->var[i1] = dict->var[i2]; + dict->var[i2] = t; + dict->var[i1]->index = i1; + dict->var[i2]->index = i2; + } + + free (v); + } + + /* Delete all but the first NV variables from the + dictionary. */ + { + int i; + for (i = nv; i < dict->nvar; i++) + { + clear_variable (dict, dict->var[i]); + free (dict->var[i]); + } + } + dict->var = xrealloc (dict->var, sizeof *dict->var * nv); + dict->nvar = nv; + } + else if (lex_match_id ("RENAME")) + { + if (!rename_variables (dict)) + return 0; + } + else + { + lex_error (_("while expecting a valid subcommand")); + return 0; + } + + if (dict->nvar == 0) + { + msg (SE, _("All variables deleted from system file dictionary.")); + return 0; + } + + if (*options & GTSV_OPT_MATCH_FILES) + return 1; + } + + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + + return 1; +} + +/* Parses and performs the RENAME subcommand of GET and SAVE. */ +static int +rename_variables (struct dictionary * dict) +{ + int i; + + int success = 0; + + struct variable **v; + char **new_names; + int nv, nn; + + int group; + + lex_match ('='); + if (token != '(') + { + struct variable *v; + + v = parse_dict_variable (dict); + if (v == NULL) + return 0; + if (!lex_force_match ('=') + || !lex_force_id ()) + return 0; + if (!strncmp (tokid, v->name, 8)) + return 1; + if (is_dict_varname (dict, tokid)) + { + msg (SE, _("Cannot rename %s as %s because there already exists " + "a variable named %s. To rename variables with " + "overlapping names, use a single RENAME subcommand " + "such as \"/RENAME (A=B)(B=C)(C=A)\", or equivalently, " + "\"/RENAME (A B C=B C A)\"."), v->name, tokid, tokid); + return 0; + } + + rename_variable (dict, v, tokid); + lex_get (); + return 1; + } + + nv = nn = 0; + v = NULL; + new_names = 0; + group = 1; + while (lex_match ('(')) + { + int old_nv = nv; + + if (!parse_variables (dict, &v, &nv, PV_NO_DUPLICATE | PV_APPEND)) + goto lossage; + if (!lex_match ('=')) + { + msg (SE, _("`=' expected after variable list.")); + goto lossage; + } + if (!parse_DATA_LIST_vars (&new_names, &nn, PV_APPEND | PV_NO_SCRATCH)) + goto lossage; + if (nn != nv) + { + msg (SE, _("Number of variables on left side of `=' (%d) do not " + "match number of variables on right side (%d), in " + "parenthesized group %d of RENAME subcommand."), + nv - old_nv, nn - old_nv, group); + goto lossage; + } + if (!lex_force_match (')')) + goto lossage; + group++; + } + + for (i = 0; i < nv; i++) + avl_force_delete (dict->var_by_name, v[i]); + for (i = 0; i < nv; i++) + { + strcpy (v[i]->name, new_names[i]); + if (NULL != avl_insert (dict->var_by_name, v[i])) + { + msg (SE, _("Duplicate variables name %s."), v[i]->name); + goto lossage; + } + } + success = 1; + +lossage: + /* The label is a bit of a misnomer, we actually come here on any + sort of return. */ + for (i = 0; i < nn; i++) + free (new_names[i]); + free (new_names); + free (v); + + return success; +} + +#if DEBUGGING +void +dump_dict_variables (struct dictionary * dict) +{ + int i; + + printf (_("\nVariables in dictionary:\n")); + for (i = 0; i < dict->nvar; i++) + printf ("%s, ", dict->var[i]->name); + printf ("\n"); +} +#endif + +/* Clears internal state related to GET input procedure. */ +static void +get_source_destroy_source (void) +{ + /* It is not necessary to destroy the dictionary because if we get + to this point then the dictionary is default_dict. */ + fh_close_handle (get_file); +} + +/* Reads all the cases from the data file and passes them to + write_case(). */ +static void +get_source_read (void) +{ + while (sfm_read_case (get_file, temp_case->data, &default_dict) + && write_case ()) + ; + get_source_destroy_source (); +} + +struct case_stream get_source = + { + NULL, + get_source_read, + NULL, + NULL, + get_source_destroy_source, + NULL, + "GET", + }; + + +/* MATCH FILES. */ + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* File types. */ +enum + { + MTF_FILE, /* Specified on FILE= subcommand. */ + MTF_TABLE /* Specified on TABLE= subcommand. */ + }; + +/* One of the files on MATCH FILES. */ +struct mtf_file + { + struct mtf_file *next, *prev; + /* Next, previous in the list of files. */ + struct mtf_file *next_min; /* Next in the chain of minimums. */ + + int type; /* One of MTF_*. */ + struct variable **by; /* List of BY variables for this file. */ + struct file_handle *handle; /* File handle for the file. */ + struct dictionary *dict; /* Dictionary from system file. */ + char in[9]; /* Name of the variable from IN=. */ + char first[9], last[9]; /* Name of the variables from FIRST=, LAST=. */ + union value *input; /* Input record. */ + }; + +/* All the files mentioned on FILE= or TABLE=. */ +static struct mtf_file *mtf_head, *mtf_tail; + +/* Variables on the BY subcommand. */ +static struct variable **mtf_by; +static int mtf_n_by; + +/* Master dictionary. */ +static struct dictionary *mtf_master; + +static void mtf_free (void); +static void mtf_free_file (struct mtf_file *file); +static int mtf_merge_dictionary (struct mtf_file *f); +static void mtf_delete_file_in_place (struct mtf_file **file); + +static void mtf_read_nonactive_records (void); +static void mtf_processing_finish (void); +static int mtf_processing (struct ccase *); + +static char *var_type_description (struct variable *); + +/* Parse and execute the MATCH FILES command. */ +int +cmd_match_files (void) +{ + struct mtf_file *first_table = NULL; + + int seen = 0; + + lex_match_id ("MATCH"); + lex_match_id ("FILES"); + + mtf_head = mtf_tail = NULL; + mtf_by = NULL; + mtf_n_by = 0; + mtf_master = new_dictionary (0); + mtf_master->N = default_dict.N; + + do + { + lex_match ('/'); + + if (lex_match (T_BY)) + { + if (seen & 1) + { + msg (SE, _("The BY subcommand may be given once at most.")); + goto lossage; + } + seen |= 1; + + lex_match ('='); + if (!parse_variables (mtf_master, &mtf_by, &mtf_n_by, + PV_NO_DUPLICATE | PV_NO_SCRATCH)) + goto lossage; + } + else if (token != T_ID) + { + lex_error (NULL); + goto lossage; + } + else if (lex_id_match ("FILE", tokid) || lex_id_match ("TABLE", tokid)) + { + struct mtf_file *file = xmalloc (sizeof *file); + + file->in[0] = file->first[0] = file->last[0] = '\0'; + file->dict = NULL; + file->by = NULL; + file->input = NULL; + + if (lex_match_id ("FILE")) + file->type = MTF_FILE; + else if (lex_match_id ("TABLE")) + { + file->type = MTF_TABLE; + seen |= 4; + } + else + assert (0); + + /* FILEs go first, then TABLEs. */ + if (file->type == MTF_TABLE || first_table == NULL) + { + file->next = NULL; + file->prev = mtf_tail; + if (mtf_tail) + mtf_tail->next = file; + mtf_tail = file; + if (mtf_head == NULL) + mtf_head = file; + if (file->type == MTF_TABLE && first_table == NULL) + first_table = file; + } + else + { + assert (file->type == MTF_FILE); + file->next = first_table; + file->prev = first_table->prev; + if (first_table->prev) + first_table->prev->next = file; + else + mtf_head = file; + first_table->prev = file; + } + + lex_match ('='); + + if (lex_match ('*')) + { + file->handle = NULL; + + if (seen & 2) + { + msg (SE, _("The active file may not be specified more " + "than once.")); + goto lossage; + } + seen |= 2; + + assert (pgm_state != STATE_INPUT); + if (pgm_state == STATE_INIT) + { + msg (SE, _("Cannot specify the active file since no active " + "file has been defined.")); + goto lossage; + } + } + else + { + file->handle = fh_parse_file_handle (); + if (!file->handle) + goto lossage; + } + + if (file->handle) + { + file->dict = sfm_read_dictionary (file->handle, NULL); + if (!file->dict) + goto lossage; + } + else + file->dict = &default_dict; + if (!mtf_merge_dictionary (file)) + goto lossage; + } + else if (lex_id_match ("IN", tokid) + || lex_id_match ("FIRST", tokid) + || lex_id_match ("LAST", tokid)) + { + const char *sbc; + char *name; + + if (mtf_tail == NULL) + { + msg (SE, _("IN, FIRST, and LAST subcommands may not occur " + "before the first FILE or TABLE.")); + goto lossage; + } + + if (lex_match_id ("IN")) + { + name = mtf_tail->in; + sbc = "IN"; + } + else if (lex_match_id ("FIRST")) + { + name = mtf_tail->first; + sbc = "FIRST"; + } + else if (lex_match_id ("LAST")) + { + name = mtf_tail->last; + sbc = "LAST"; + } + else + assert (0); + + lex_match ('='); + if (token != T_ID) + { + lex_error (NULL); + goto lossage; + } + + if (*name) + { + msg (SE, _("Multiple %s subcommands for a single FILE or " + "TABLE."), + sbc); + goto lossage; + } + strcpy (name, tokid); + lex_get (); + + if (!create_variable (mtf_master, name, NUMERIC, 0)) + { + msg (SE, _("Duplicate variable name %s while creating %s " + "variable."), + name, sbc); + goto lossage; + } + } + else if (lex_id_match ("RENAME", tokid) + || lex_id_match ("KEEP", tokid) + || lex_id_match ("DROP", tokid)) + { + int options = GTSV_OPT_MATCH_FILES; + + if (mtf_tail == NULL) + { + msg (SE, _("RENAME, KEEP, and DROP subcommands may not occur " + "before the first FILE or TABLE.")); + goto lossage; + } + + if (!trim_dictionary (mtf_tail->dict, &options)) + goto lossage; + } + else if (lex_match_id ("MAP")) + { + /* FIXME. */ + } + else + { + lex_error (NULL); + goto lossage; + } + } + while (token != '.'); + + if (seen & 4) + { + if (!(seen & 1)) + { + msg (SE, _("The BY subcommand is required when a TABLE subcommand " + "is given.")); + goto lossage; + } + } + + if (seen & 1) + { + struct mtf_file *iter; + + for (iter = mtf_head; iter; iter = iter->next) + { + int i; + + iter->by = xmalloc (sizeof *iter->by * mtf_n_by); + + for (i = 0; i < mtf_n_by; i++) + { + iter->by[i] = find_dict_variable (iter->dict, mtf_by[i]->name); + if (iter->by[i] == NULL) + { + msg (SE, _("File %s lacks BY variable %s."), + iter->handle ? fh_handle_name (iter->handle) : "*", + mtf_by[i]->name); + goto lossage; + } + } + } + } + +#if DEBUGGING + { + /* From sfm-read.c. */ + extern void dump_dictionary (struct dictionary *); + + dump_dictionary (mtf_master); + } +#endif + + /* MATCH FILES performs an n-way merge on all its input files. + Abstract algorithm: + + 1. Read one input record from every input FILE. + + 2. If no FILEs are left, stop. Otherwise, proceed to step 3. + + 3. Find the FILE input record with minimum BY values. Store all + the values from this input record into the output record. + + 4. Find all the FILE input records with BY values identical to + the minimums. Store all the values from these input records into + the output record. + + 5. For every TABLE, read another record as long as the BY values + on the TABLE's input record are less than the FILEs' BY values. + If an exact match is found, store all the values from the TABLE + input record into the output record. + + 6. Write the output record. + + 7. Read another record from each input file FILE and TABLE that + we stored values from above. If we come to the end of one of the + input files, remove it from the list of input files. + + 8. Repeat from step 2. + + Unfortunately, this algorithm can't be directly implemented + because there's no function to read a record from the active + file; instead, it has to be done using callbacks. + + FIXME: A better algorithm would use a heap for finding minimum + values, or replacement selection, as described by Knuth in _Art + of Computer Programming, Vol. 3_. The SORT CASES procedure does + this, and perhaps some of its code could be adapted. */ + + if (!(seen & 2)) + discard_variables (); + + temporary = 2; + temp_dict = mtf_master; + temp_trns = n_trns; + + process_active_file (mtf_read_nonactive_records, mtf_processing, + mtf_processing_finish); + mtf_master = NULL; + + mtf_free (); + return CMD_SUCCESS; + +lossage: + mtf_free (); + return CMD_FAILURE; +} + +/* Repeats 2...8 an arbitrary number of times. */ +static void +mtf_processing_finish (void) +{ + /* Find the active file and delete it. */ + { + struct mtf_file *iter; + + for (iter = mtf_head; iter; iter = iter->next) + if (iter->handle == NULL) + { + mtf_delete_file_in_place (&iter); + break; + } + } + + while (mtf_head && mtf_head->type == MTF_FILE) + if (!mtf_processing (temp_case)) + break; +} + +/* Return a string in a static buffer describing V's variable type and + width. */ +static char * +var_type_description (struct variable *v) +{ + static char buf[2][32]; + static int x = 0; + char *s; + + x ^= 1; + s = buf[x]; + + if (v->type == NUMERIC) + strcpy (s, "numeric"); + else + { + assert (v->type == ALPHA); + sprintf (s, "string with width %d", v->width); + } + return s; +} + +/* Free FILE and associated data. */ +static void +mtf_free_file (struct mtf_file *file) +{ + fh_close_handle (file->handle); + if (file->dict && file->dict != &default_dict) + free_dictionary (file->dict); + free (file->by); + if (file->handle) + free (file->input); + free (file); +} + +/* Free all the data for the MATCH FILES procedure. */ +static void +mtf_free (void) +{ + struct mtf_file *iter, *next; + + for (iter = mtf_head; iter; iter = next) + { + next = iter->next; + + mtf_free_file (iter); + } + + free (mtf_by); + if (mtf_master) + free_dictionary (mtf_master); +} + +/* Remove *FILE from the mtf_file chain. Make *FILE point to the next + file in the chain, or to NULL if was the last in the chain. */ +static void +mtf_delete_file_in_place (struct mtf_file **file) +{ + struct mtf_file *f = *file; + + if (f->prev) + f->prev->next = f->next; + if (f->next) + f->next->prev = f->prev; + if (f == mtf_head) + mtf_head = f->next; + if (f == mtf_tail) + mtf_tail = f->prev; + *file = f->next; + + { + int i; + + for (i = 0; i < f->dict->nvar; i++) + { + struct variable *v = f->dict->var[i]; + + if (v->type == NUMERIC) + compaction_case->data[v->p.mtf.master->fv].f = SYSMIS; + else + memset (compaction_case->data[v->p.mtf.master->fv].s, ' ', + v->width); + } + } + + mtf_free_file (f); +} + +/* Read a record from every input file except the active file. */ +static void +mtf_read_nonactive_records (void) +{ + struct mtf_file *iter; + + for (iter = mtf_head; iter; ) + { + if (iter->handle) + { + assert (iter->input == NULL); + iter->input = xmalloc (sizeof *iter->input * iter->dict->nval); + + if (!sfm_read_case (iter->handle, iter->input, iter->dict)) + mtf_delete_file_in_place (&iter); + else + iter = iter->next; + } + else + { + iter->input = temp_case->data; + iter = iter->next; + } + } +} + +/* Compare the BY variables for files A and B; return -1 if A < B, 0 + if A == B, 1 if A > B. */ +static inline int +mtf_compare_BY_values (struct mtf_file *a, struct mtf_file *b) +{ + int i; + + for (i = 0; i < mtf_n_by; i++) + { + assert (a->by[i]->type == b->by[i]->type); + assert (a->by[i]->width == b->by[i]->width); + + if (a->by[i]->type == NUMERIC) + { + double af = a->input[a->by[i]->fv].f; + double bf = b->input[b->by[i]->fv].f; + + if (af < bf) + return -1; + else if (af > bf) + return 1; + } + else + { + int result; + + assert (a->by[i]->type == ALPHA); + result = memcmp (a->input[a->by[i]->fv].s, + b->input[b->by[i]->fv].s, + a->by[i]->width); + if (result < 0) + return -1; + else if (result > 0) + return 1; + } + } + return 0; +} + +/* Used to determine whether we've already initialized this + variable. */ +static int mtf_seq_no = 0; + +/* Perform one iteration of steps 3...7 above. */ +static int +mtf_processing (struct ccase *c unused) +{ + /* List of files with minimum BY values. */ + struct mtf_file *min_head, *min_tail; + + /* List of files with non-minimum BY values. */ + struct mtf_file *max_head, *max_tail; + + /* Iterator. */ + struct mtf_file *iter; + + for (;;) + { + /* If the active file doesn't have the minimum BY values, don't + return because that would cause a record to be skipped. */ + int advance = 1; + + if (mtf_head->type == MTF_TABLE) + return 0; + + /* 3. Find the FILE input record with minimum BY values. Store + all the values from this input record into the output record. + + 4. Find all the FILE input records with BY values identical + to the minimums. Store all the values from these input + records into the output record. */ + min_head = min_tail = mtf_head; + max_head = max_tail = NULL; + for (iter = mtf_head->next; iter && iter->type == MTF_FILE; + iter = iter->next) + switch (mtf_compare_BY_values (min_head, iter)) + { + case -1: + if (max_head) + max_tail = max_tail->next_min = iter; + else + max_head = max_tail = iter; + break; + + case 0: + min_tail = min_tail->next_min = iter; + break; + + case 1: + if (max_head) + { + max_tail->next_min = min_head; + max_tail = min_tail; + } + else + { + max_head = min_head; + max_tail = min_tail; + } + min_head = min_tail = iter; + break; + + default: + assert (0); + } + + /* 5. For every TABLE, read another record as long as the BY + values on the TABLE's input record are less than the FILEs' + BY values. If an exact match is found, store all the values + from the TABLE input record into the output record. */ + while (iter) + { + struct mtf_file *next = iter->next; + + assert (iter->type == MTF_TABLE); + + if (iter->handle == NULL) + advance = 0; + + again: + switch (mtf_compare_BY_values (min_head, iter)) + { + case -1: + if (max_head) + max_tail = max_tail->next_min = iter; + else + max_head = max_tail = iter; + break; + + case 0: + min_tail = min_tail->next_min = iter; + break; + + case 1: + if (iter->handle == NULL) + return 1; + if (sfm_read_case (iter->handle, iter->input, iter->dict)) + goto again; + mtf_delete_file_in_place (&iter); + break; + + default: + assert (0); + } + + iter = next; + } + + /* Next sequence number. */ + mtf_seq_no++; + + /* Store data to all the records we are using. */ + if (min_tail) + min_tail->next_min = NULL; + for (iter = min_head; iter; iter = iter->next_min) + { + int i; + + for (i = 0; i < iter->dict->nvar; i++) + { + struct variable *v = iter->dict->var[i]; + + if (v->p.mtf.master->foo == mtf_seq_no) + continue; + v->p.mtf.master->foo = mtf_seq_no; + +#if 0 + printf ("%s/%s: dest-fv=%d, src-fv=%d\n", + fh_handle_name (iter->handle), + v->name, + v->p.mtf.master->fv, v->fv); +#endif + if (v->type == NUMERIC) + compaction_case->data[v->p.mtf.master->fv].f + = iter->input[v->fv].f; + else + { + assert (v->type == ALPHA); + memcpy (compaction_case->data[v->p.mtf.master->fv].s, + iter->input[v->fv].s, v->width); +#if __CHECKER__ + memset (&compaction_case + ->data[v->p.mtf.master->fv].s[v->width], + 0, REM_RND_UP (v->width, MAX_SHORT_STRING)); +#endif + } + } + } + + /* Store missing values to all the records we're not using. */ + if (max_tail) + max_tail->next_min = NULL; + for (iter = max_head; iter; iter = iter->next_min) + { + int i; + + for (i = 0; i < iter->dict->nvar; i++) + { + struct variable *v = iter->dict->var[i]; + + if (v->p.mtf.master->foo == mtf_seq_no) + continue; + v->p.mtf.master->foo = mtf_seq_no; + +#if 0 + printf ("%s/%s: dest-fv=%d\n", + fh_handle_name (iter->handle), + v->name, + v->p.mtf.master->fv); +#endif + if (v->type == NUMERIC) + compaction_case->data[v->p.mtf.master->fv].f = SYSMIS; + else + { + memset (compaction_case->data[v->p.mtf.master->fv].s, ' ', + v->width); +#if __CHECKER__ + memset (&compaction_case + ->data[v->p.mtf.master->fv].s[v->width], + 0, REM_RND_UP (v->width, MAX_SHORT_STRING)); +#endif + } + } + + if (iter->handle == NULL) + advance = 0; + } + + /* 6. Write the output record. */ + process_active_file_output_case (); + + /* 7. Read another record from each input file FILE and TABLE + that we stored values from above. If we come to the end of + one of the input files, remove it from the list of input + files. */ + for (iter = min_head; iter && iter->type == MTF_FILE; ) + { + struct mtf_file *next = iter->next_min; + + if (iter->handle) + { + assert (iter->input != NULL); + + if (!sfm_read_case (iter->handle, iter->input, iter->dict)) + mtf_delete_file_in_place (&iter); + } + + iter = next; + } + + if (advance) + break; + } + + return (mtf_head && mtf_head->type != MTF_TABLE); +} + +/* Merge the dictionary for file F into the master dictionary + mtf_master. */ +static int +mtf_merge_dictionary (struct mtf_file *f) +{ + struct dictionary *const m = mtf_master; + struct dictionary *d = f->dict; + + if (d->label && m->label == NULL) + m->label = xstrdup (d->label); + + if (d->documents) + { + m->documents = xrealloc (m->documents, + 80 * (m->n_documents + d->n_documents)); + memcpy (&m->documents[80 * m->n_documents], + d->documents, 80 * d->n_documents); + m->n_documents += d->n_documents; + } + + { + int i; + + d->nval = 0; + for (i = 0; i < d->nvar; i++) + { + struct variable *dv = d->var[i]; + struct variable *mv = find_dict_variable (m, dv->name); + + dv->fv = d->nval; + d->nval += dv->nv; + + assert (dv->type == ALPHA || dv->width == 0); + assert (!mv || mv->type == ALPHA || mv->width == 0); + if (mv && dv->width == mv->width) + { + if (dv->val_lab && !mv->val_lab) + mv->val_lab = copy_value_labels (dv->val_lab); + if (dv->miss_type != MISSING_NONE && mv->miss_type == MISSING_NONE) + copy_missing_values (mv, dv); + } + if (mv && dv->label && !mv->label) + mv->label = xstrdup (dv->label); + if (!mv) + { + mv = force_dup_variable (m, dv, dv->name); + + /* Used to make sure we initialize each variable in the + master dictionary exactly once per case. */ + mv->foo = mtf_seq_no; + } + else if (mv->width != dv->width) + { + msg (SE, _("Variable %s in file %s (%s) has different " + "type or width from the same variable in " + "earlier file (%s)."), + dv->name, fh_handle_name (f->handle), + var_type_description (dv), var_type_description (mv)); + return 0; + } + dv->p.mtf.master = mv; + } + } + + return 1; +} + +/* IMPORT command. */ + +/* Parses the IMPORT command. */ +int +cmd_import (void) +{ + struct file_handle *handle = NULL; + struct dictionary *dict; + int options = GTSV_OPT_NONE; + int type; + + int i; + int nval; + + lex_match_id ("IMPORT"); + + for (;;) + { + lex_match ('/'); + + if (lex_match_id ("FILE") || token == T_STRING) + { + lex_match ('='); + + handle = fh_parse_file_handle (); + if (handle == NULL) + return CMD_FAILURE; + } + else if (lex_match_id ("TYPE")) + { + lex_match ('='); + + if (lex_match_id ("COMM")) + type = PFM_COMM; + else if (lex_match_id ("TAPE")) + type = PFM_TAPE; + else + { + lex_error (_("expecting COMM or TAPE")); + return CMD_FAILURE; + } + } + else break; + } + if (!lex_match ('/') && token != '.') + { + lex_error (NULL); + return CMD_FAILURE; + } + + discard_variables (); + + dict = pfm_read_dictionary (handle, NULL); + if (dict == NULL) + return CMD_FAILURE; + +#if DEBUGGING + dump_dict_variables (dict); +#endif + if (0 == trim_dictionary (dict, &options)) + { + fh_close_handle (handle); + return CMD_FAILURE; + } +#if DEBUGGING + dump_dict_variables (dict); +#endif + + /* Set the fv and lv elements of all variables remaining in the + dictionary. */ + nval = 0; + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + v->fv = nval; + nval += v->nv; + } + dict->nval = nval; + assert (nval); + +#if DEBUGGING + printf (_("IMPORT translation table from file to memory:\n")); + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + printf (_(" %8s from %3d,%3d to %3d,%3d\n"), v->name, + v->get.fv, v->get.nv, v->fv, v->nv); + } +#endif + + restore_dictionary (dict); + + vfm_source = &import_source; + get_file = handle; + + return CMD_SUCCESS; +} + +/* Reads all the cases from the data file and passes them to + write_case(). */ +static void +import_source_read (void) +{ + while (pfm_read_case (get_file, temp_case->data, &default_dict) + && write_case ()) + ; + get_source_destroy_source (); +} + +struct case_stream import_source = + { + NULL, + import_source_read, + NULL, + NULL, + get_source_destroy_source, + NULL, + "IMPORT", + }; + +static int export_write_case_func (struct ccase *c); + +/* Parses the EXPORT command. */ +/* FIXME: same as cmd_save_internal(). */ +int +cmd_export (void) +{ + struct file_handle *handle; + struct dictionary *dict; + int options = GTSV_OPT_SAVE; + + struct save_trns *t; + + int i; + + lex_match_id ("EXPORT"); + + lex_match ('/'); + if (lex_match_id ("OUTFILE")) + lex_match ('='); + + handle = fh_parse_file_handle (); + if (handle == NULL) + return CMD_FAILURE; + + dict = save_dictionary (); +#if DEBUGGING + dump_dict_variables (dict); +#endif + for (i = 0; i < dict->nvar; i++) + dict->var[i]->foo = i; + if (0 == trim_dictionary (dict, &options)) + { + fh_close_handle (handle); + return CMD_FAILURE; + } + +#if DEBUGGING + dump_dict_variables (dict); +#endif + + /* Write dictionary. */ + if (!pfm_write_dictionary (handle, dict)) + { + free_dictionary (dict); + fh_close_handle (handle); + return CMD_FAILURE; + } + + /* Fill in transformation structure. */ + t = trns = xmalloc (sizeof *t); + t->h.proc = save_trns_proc; + t->h.free = save_trns_free; + t->f = handle; + t->nvar = dict->nvar; + t->var = xmalloc (sizeof *t->var * dict->nvar); + for (i = 0; i < dict->nvar; i++) + t->var[i] = dict->var[i]->foo; + t->case_buf = xmalloc (sizeof *t->case_buf * dict->nvar); + free_dictionary (dict); + + procedure (NULL, export_write_case_func, NULL); + save_trns_free ((struct trns_header *) t); + + return CMD_SUCCESS; +} + +static int +export_write_case_func (struct ccase *c) +{ + union value *p = (union value *) trns->case_buf; + int i; + + for (i = 0; i < trns->nvar; i++) + { + struct variable *v = default_dict.var[trns->var[i]]; + + if (v->type == NUMERIC) + *p++ = c->data[v->fv]; + else + (*p++).c = c->data[v->fv].s; + } + + printf ("."); + fflush (stdout); + + pfm_write_case (trns->f, (union value *) trns->case_buf); + return 1; +} diff --git a/src/getline.c b/src/getline.c new file mode 100644 index 00000000..5b8588c8 --- /dev/null +++ b/src/getline.c @@ -0,0 +1,519 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "getline.h" +#include "lexer.h" +#include "settings.h" +#include "str.h" +#include "tab.h" +#include "var.h" +#include "version.h" + +/* Global variables. */ +struct string getl_buf; +struct getl_script *getl_head; +struct getl_script *getl_tail; +int getl_interactive; +int getl_welcomed; +int getl_mode; +int getl_prompt; + +#if HAVE_LIBHISTORY +static char *history_file; + +#if HAVE_READLINE_HISTORY_H +#include +#else /* no readline/history.h */ +extern void add_history (char *); +extern void using_history (void); +extern int read_history (char *); +extern void stifle_history (int); +extern int write_history (char *); +#endif /* no readline/history.h */ +#endif /* -lhistory */ + +static struct string getl_include_path; + +/* Number of levels of DO REPEAT structures we're nested inside. If + this is greater than zero then DO REPEAT macro substitutions are + performed. */ +static int DO_REPEAT_level; + +static int read_console (void); + +/* Initialize getline. */ +void +getl_initialize (void) +{ + ds_create (NULL, &getl_include_path, + fn_getenv_default ("STAT_INCLUDE_PATH", include_path)); + ds_init (NULL, &getl_buf, 256); +} + +/* Close getline. */ +void +getl_uninitialize (void) +{ +#if HAVE_LIBHISTORY && unix + if (history_file) + write_history (history_file); +#endif +} + +/* Returns a string that represents the directory that the syntax file + currently being read resides in. If there is no syntax file then + returns the OS current working directory. Return value must be + free()'d. */ +char * +getl_get_current_directory (void) +{ + return getl_head ? fn_dirname (getl_head->fn) : fn_get_cwd (); +} + +/* Delete everything from the include path. */ +void +getl_clear_include_path (void) +{ + ds_clear (&getl_include_path); +} + +/* Add to the include path. */ +void +getl_add_include_dir (const char *path) +{ + if (ds_length (&getl_include_path)) + ds_putchar (&getl_include_path, PATH_DELIMITER); + + ds_concat (&getl_include_path, path); +} + +/* Adds FN to the tail end of the list of script files to execute. + OPTIONS is the value to stick in the options field of the + getl_script struct. If WHERE is zero then the file is added after + all other files; otherwise it is added before all other files (this + can be done only if parsing has not yet begun). */ +void +getl_add_file (const char *fn, int separate, int where) +{ + struct getl_script *n = xmalloc (sizeof *n); + + assert (fn != NULL); + n->next = NULL; + if (getl_tail == NULL) + getl_head = getl_tail = n; + else if (!where) + getl_tail = getl_tail->next = n; + else + { + assert (getl_head->f == NULL); + n->next = getl_head; + getl_head = n; + } + n->included_from = n->includes = NULL; + n->fn = xstrdup (fn); + n->ln = 0; + n->f = NULL; + n->separate = separate; + n->first_line = NULL; +} + +/* Inserts the given file with filename FN into the current file after + the current line. */ +void +getl_include (const char *fn) +{ + struct getl_script *n; + char *real_fn; + + { + char *cur_dir = getl_get_current_directory (); + real_fn = fn_search_path (fn, ds_value (&getl_include_path), cur_dir); + free (cur_dir); + } + + if (!real_fn) + { + msg (SE, _("Can't find `%s' in include file search path."), fn); + return; + } + + if (!getl_head) + { + getl_add_file (real_fn, 0, 0); + free (real_fn); + } + else + { + n = xmalloc (sizeof *n); + n->included_from = getl_head; + getl_head = getl_head->includes = n; + n->includes = NULL; + n->next = NULL; + n->fn = real_fn; + n->ln = 0; + n->f = NULL; + n->separate = 0; + n->first_line = NULL; + } +} + +/* Add the virtual file FILE to the list of files to be processed. + The first_line field in FILE must already have been initialized. */ +void +getl_add_virtual_file (struct getl_script *file) +{ + if (getl_tail == NULL) + getl_head = getl_tail = file; + else + getl_tail = getl_tail->next = file; + file->included_from = file->includes = NULL; + file->next = NULL; + file->fn = file->first_line->line; + file->ln = -file->first_line->len - 1; + file->separate = 0; + file->f = NULL; + file->cur_line = NULL; + file->remaining_loops = 1; + file->loop_index = -1; + file->macros = NULL; +} + +/* Causes the DO REPEAT virtual file passed in FILE to be included in + the current file. The first_line, cur_line, remaining_loops, + loop_index, and macros fields in FILE must already have been + initialized. */ +void +getl_add_DO_REPEAT_file (struct getl_script *file) +{ + /* getl_head == NULL can't happen. */ + assert (getl_head); + + DO_REPEAT_level++; + file->included_from = getl_head; + getl_head = getl_head->includes = file; + file->includes = NULL; + file->next = NULL; + assert (file->first_line->len < 0); + file->fn = file->first_line->line; + file->ln = -file->first_line->len - 1; + file->separate = 0; + file->f = NULL; +} + +/* Display a welcoming message. */ +void +welcome (void) +{ + getl_welcomed = 1; + fputs ("PSPP is free software and you are welcome to distribute copies of" + "it\nunder certain conditions; type \"show copying.\" to see the " + "conditions.\nThere is ABSOLUTELY NO WARRANTY for PSPP; type \"show " + "warranty.\" for details.\n", stdout); + puts (stat_version); +} + +/* Reads a single line from the user's terminal. */ + +/* From repeat.c. */ +extern void perform_DO_REPEAT_substitutions (void); + +/* Reads a single line from the line buffer associated with getl_head. + Returns 1 if a line was successfully read or 0 if no more lines are + available. */ +static int +handle_line_buffer (void) +{ + struct getl_script *s = getl_head; + + /* Check that we're not all done. */ + do + { + if (s->cur_line == NULL) + { + s->loop_index++; + if (s->remaining_loops-- == 0) + return 0; + s->cur_line = s->first_line; + } + + if (s->cur_line->len < 0) + { + s->ln = -s->cur_line->len - 1; + s->fn = s->cur_line->line; + s->cur_line = s->cur_line->next; + continue; + } + } + while (s->cur_line == NULL); + + ds_concat_buffer (&getl_buf, s->cur_line->line, s->cur_line->len); + + /* Advance pointers. */ + s->cur_line = s->cur_line->next; + s->ln++; + + return 1; +} + +/* Reads a single line into getl_buf from the list of files. Will not + read from the eof of one file to the beginning of another unless + the options field on the new file's getl_script is nonzero. Return + zero on eof. */ +int +getl_read_line (void) +{ + getl_mode = GETL_MODE_BATCH; + + while (getl_head) + { + struct getl_script *s = getl_head; + + ds_clear (&getl_buf); + if (s->separate) + return 0; + + if (s->first_line) + { + if (!handle_line_buffer ()) + { + getl_close_file (); + continue; + } + perform_DO_REPEAT_substitutions (); + if (getl_head->print) + tab_output_text (TAB_LEFT | TAT_FIX | TAT_PRINTF, "+%s", + ds_value (&getl_buf)); + return 1; + } + + if (s->f == NULL) + { + msg (VM (1), _("%s: Opening as syntax file."), s->fn); + s->f = fn_open (s->fn, "r"); + + if (s->f == NULL) + { + msg (ME, _("Opening `%s': %s."), s->fn, strerror (errno)); + getl_close_file (); + continue; + } + } + + if (!ds_getline (&getl_buf, s->f)) + { + if (ferror (s->f)) + msg (ME, _("Reading `%s': %s."), s->fn, strerror (errno)); + getl_close_file (); + continue; + } + if (ds_length (&getl_buf) > 0 && ds_end (&getl_buf)[-1] == '\n') + ds_truncate (&getl_buf, ds_length (&getl_buf) - 1); + + if (set_echo) + tab_output_text (TAB_LEFT | TAT_FIX, ds_value (&getl_buf)); + + getl_head->ln++; + + /* Allows shebang invocation: `#! /usr/local/bin/pspp'. */ + if (ds_value (&getl_buf)[0] == '#' + && ds_value (&getl_buf)[1] == '!') + continue; + + return 1; + } + + if (getl_interactive == 0) + return 0; + + getl_mode = GETL_MODE_INTERACTIVE; + + if (getl_welcomed == 0) + welcome (); + + return read_console (); +} + +/* Closes the current file, whether it be a main file or included + file, then moves getl_head to the next file in the chain. */ +void +getl_close_file (void) +{ + struct getl_script *s = getl_head; + + if (!s) + return; + assert (getl_tail != NULL); + + if (s->first_line) + { + struct getl_line_list *cur, *next; + + s->fn = NULL; /* It will be freed below. */ + for (cur = s->first_line; cur; cur = next) + { + next = cur->next; + free (cur->line); + free (cur); + } + + DO_REPEAT_level--; + } + + if (s->f && EOF == fn_close (s->fn, s->f)) + msg (MW, _("Closing `%s': %s."), s->fn, strerror (errno)); + free (s->fn); + + if (s->included_from) + { + getl_head = s->included_from; + getl_head->includes = NULL; + } + else + { + getl_head = s->next; + if (NULL == getl_head) + getl_tail = NULL; + } + + free (s); +} + +/* PORTME: Adapt to your local system's idea of the terminal. */ +#if HAVE_LIBREADLINE + +#if HAVE_READLINE_READLINE_H +#include +#else /* no readline/readline.h */ +extern char *readline (char *); +#endif /* no readline/readline.h */ + +static int +read_console (void) +{ + char *line; + char *prompt; + + err_error_count = err_warning_count = 0; + err_already_flagged = 0; + +#if HAVE_LIBHISTORY + if (!history_file) + { +#if unix + history_file = tilde_expand (HISTORY_FILE); +#endif + using_history (); + read_history (history_file); + stifle_history (MAX_HISTORY); + } +#endif /* -lhistory */ + + switch (getl_prompt) + { + case GETL_PRPT_STANDARD: + prompt = set_prompt; + break; + + case GETL_PRPT_CONTINUATION: + prompt = set_cprompt; + break; + + case GETL_PRPT_DATA: + prompt = set_dprompt; + break; + + default: + assert (0); + } + + line = readline (prompt); + if (!line) + return 0; + +#if HAVE_LIBHISTORY + if (*line) + add_history (line); +#endif + + ds_clear (&getl_buf); + ds_concat (&getl_buf, line); + + return 1; +} +#else /* no -lreadline */ +static int +read_console (void) +{ + err_error_count = err_warning_count = 0; + err_already_flagged = 0; + + fputs (getl_prompt ? set_cprompt : set_prompt, stdout); + ds_clear (&getl_buf); + if (ds_getline (&getl_buf, stdin)) + return 1; + + if (ferror (stdin)) + msg (FE, "stdin: fgets(): %s.", strerror (errno)); + + return 0; +} +#endif /* no -lreadline */ + +/* Closes all files. */ +void +getl_close_all (void) +{ + while (getl_head) + getl_close_file (); +} + +/* Sets the options flag of the current script to 0, thus allowing it + to be read in. Returns nonzero if this action was taken, zero + otherwise. */ +int +getl_perform_delayed_reset (void) +{ + if (getl_head && getl_head->separate) + { + getl_head->separate = 0; + discard_variables (); + lex_reset_eof (); + return 1; + } + return 0; +} + +/* Puts the current file and line number in *FN and *LN, respectively, + or NULL and -1 if none. */ +void +getl_location (const char **fn, int *ln) +{ + if (fn != NULL) + *fn = getl_head ? getl_head->fn : NULL; + if (ln != NULL) + *ln = getl_head ? getl_head->ln : -1; +} diff --git a/src/getline.h b/src/getline.h new file mode 100644 index 00000000..f04bacdc --- /dev/null +++ b/src/getline.h @@ -0,0 +1,117 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !getline_h +#define getline_h 1 + +#include + +/* Defines a list of lines used by DO REPEAT. */ +/* Special case: if LEN is negative then it is a line number; in this + case LINE is a file name. This is used to allow errors to be + reported for the correct file and line number when DO REPEAT spans + files. */ +struct getl_line_list + { + char *line; /* Line contents. */ + int len; /* Line length. */ + struct getl_line_list *next; /* Next line. */ + }; + +/* Source file. */ +struct getl_script + { + struct getl_script *included_from; /* File that this is nested inside. */ + struct getl_script *includes; /* File nested inside this file. */ + struct getl_script *next; /* Next file in list. */ + char *fn; /* Filename. */ + int ln; /* Line number. */ + int separate; /* !=0 means this is a separate job. */ + FILE *f; /* File handle. */ + + /* Used only if F is NULL. Used for DO REPEAT. */ + struct getl_line_list *first_line; /* First line in line buffer. */ + struct getl_line_list *cur_line; /* Current line in line buffer. */ + int remaining_loops; /* Number of remaining loops through LINES. */ + int loop_index; /* Number of loops through LINES so far. */ + void *macros; /* Pointer to macro table. */ + int print; /* 1=Print lines as executed. */ + }; + +/* List of script files. */ +extern struct getl_script *getl_head; /* Current file. */ +extern struct getl_script *getl_tail; /* End of list. */ + +/* If getl_head==0 and getl_interactive!=0, lines will be read from + the console rather than terminating. */ +extern int getl_interactive; + +/* 1=the welcome message has been printed. */ +extern int getl_welcomed; + +/* Prompt styles. */ +enum + { + GETL_PRPT_STANDARD, /* Just asks for a command. */ + GETL_PRPT_CONTINUATION, /* Continuation lines for a single command. */ + GETL_PRPT_DATA /* Between BEGIN DATA and END DATA. */ + }; + +/* Current mode. */ +enum + { + GETL_MODE_BATCH, /* Batch mode. */ + GETL_MODE_INTERACTIVE /* Interactive mode. */ + }; + +/* One of GETL_MODE_*, representing the current mode. */ +extern int getl_mode; + +/* Current prompting style: one of GETL_PRPT_*. */ +extern int getl_prompt; + +/* Are we reading a script? Are we interactive? */ +#define getl_am_interactive (getl_head == NULL) +#define getl_reading_script (getl_head != NULL) + +/* Current line. This line may be modified by modules other than + getline.c, and by lexer.c in particular. */ +extern struct string getl_buf; + +/* Name of the command history file. */ +#if HAVE_LIBREADLINE && HAVE_LIBHISTORY +extern char *getl_history; +#endif + +void getl_initialize (void); +void getl_uninitialize (void); +void getl_clear_include_path (void); +char *getl_get_current_directory (void); +void getl_add_include_dir (const char *); +void getl_add_file (const char *fn, int separate, int where); +void getl_include (const char *fn); +int getl_read_line (void); +void getl_close_file (void); +void getl_close_all (void); +int getl_perform_delayed_reset (void); +void getl_add_DO_REPEAT_file (struct getl_script *); +void getl_add_virtual_file (struct getl_script *); +void getl_location (const char **, int *); + +#endif /* getline_h */ diff --git a/src/glob.c b/src/glob.c new file mode 100644 index 00000000..f9d443b5 --- /dev/null +++ b/src/glob.c @@ -0,0 +1,431 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +#include +#include + +#if TIME_WITH_SYS_TIME +#include +#include +#else +#if HAVE_SYS_TIME_H +#include +#else +#include +#endif +#endif + +#if HAVE_LIBTERMCAP +#if HAVE_TERMCAP_H +#include +#else /* !HAVE_TERMCAP_H */ +int tgetent (char *, char *); +int tgetnum (char *); +#endif /* !HAVE_TERMCAP_H */ +#endif /* !HAVE_LIBTERMCAP */ + +#if HAVE_LIBHISTORY +#if HAVE_READLINE_HISTORY_H +#include +#else /* no readline/history.h */ +extern void using_history (); +extern int read_history (); +extern void stifle_history (); +#endif /* no readline/history.h */ +#endif /* -lhistory */ + +#if HAVE_FPU_CONTROL_H +#include +#elif __BORLANDC__ +#include +#include +#endif + +#if __DJGPP__ +#include +#elif __WIN32__ && __BORLANDC__ +#undef gettext +#include +#define gettext(STRING) \ + STRING +#endif + +#if HAVE_LOCALE_H +#include +#endif + +#if HAVE_FENV_H +#include +#endif + +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "do-ifP.h" +#include "error.h" +#include "expr.h" +#include "filename.h" +#include "getline.h" +#include "julcal/julcal.h" +#include "lexer.h" +#include "main.h" +#include "settings.h" +#include "str.h" +#include "var.h" +#include "version.h" +#include "vfm.h" + +/* var.h */ +struct dictionary default_dict; +struct expression *process_if_expr; + +struct ccase *temp_case; + +struct trns_header **t_trns; +int n_trns; +int m_trns; +int f_trns; + +int FILTER_before_TEMPORARY; + +struct file_handle *default_handle; + +void (*read_active_file) (void); +void (*cancel_input_pgm) (void); + +struct ctl_stmt *ctl_stack; + +/* log.h */ +char *logfn; +FILE *logfile; +int logging; + +/* Functions. */ + +static void get_date (void); + +#if HAVE_LIBTERMCAP && !__CHECKER__ +static char *term_buffer; +#endif + +void +init_glob (int argc unused, char **argv) +{ + /* FIXME: Allow i18n of other locale items (besides LC_MESSAGES). */ +#if ENABLE_NLS +#if LC_MESSAGE + setlocale (LC_MESSAGES, ""); +#endif + setlocale (LC_MONETARY, ""); + bindtextdomain (PACKAGE, locale_dir); + textdomain (PACKAGE); +#endif /* ENABLE_NLS */ + + /* Workable defaults before we determine the real terminal size. */ + set_viewwidth = 79; + set_viewlength = 24; + + fn_init (); + getl_initialize (); + + /* PORTME: If your system/OS has the nasty tendency to halt with a + SIGFPE whenever there's a floating-point overflow (or other + exception), be sure to mask off those bits in the FPU here. + PSPP wants a guarantee that, no matter what boneheaded + floating-point operation it performs, the process will not halt. */ +#if HAVE_FEHOLDEXCEPT + { + fenv_t foo; + + feholdexcept (&foo); + } +#elif HAVE___SETFPUCW && defined(_FPU_IEEE) + __setfpucw (_FPU_IEEE); +#elif __BORLANDC__ + _control87 (0xffff, 0x137f); +#endif + +#if ENDIAN==UNKNOWN + { + /* Test for endianness borrowed from acspecific.m4, which was in + turn borrowed from Harbison&Steele. */ + union + { + long l; + char c[sizeof (long)]; + } + u; + + u.l = 1; + if (u.c[sizeof u.l - 1] == 1) + endian = BIG; + else if (u.c[0] == 1) + endian = LITTLE; + else + msg (FE, _("Your machine does not appear to be either big- or little-" + "endian. At the moment, PSPP only supports machines of " + "these standard endiannesses. If you want to hack in " + "others, contact the author.")); + } +#endif + + /* PORTME: Set the value for second_lowest_value, which is the + "second lowest" possible value for a double. This is the value + for LOWEST on MISSING VALUES, etc. */ +#ifndef SECOND_LOWEST_VALUE +#if FPREP == FPREP_IEEE754 + { + union + { + unsigned char c[8]; + double d; + } + second_lowest_little = {{0xfe, 0xff, 0xff, 0xff, 0xff, 0xff, 0xef, 0xff}}, + second_lowest_big = {{0xff, 0xef, 0xff, 0xff, 0xff, 0xff, 0xff, 0xfe}}; + + if (endian == LITTLE) + second_lowest_value = second_lowest_little.d; + else if (endian == BIG) + second_lowest_value = second_lowest_big.d; + } +#else /* FPREP != FPREP_IEEE754 */ +#error Unknown floating-point representation. +#endif /* FPREP != FPREP_IEEE754 */ +#endif /* !SECOND_LOWEST_VALUE */ + + /* var.h */ + default_dict.var_by_name = avl_create (NULL, cmp_variable, NULL); + + vec_init (&reinit_sysmis); + vec_init (&reinit_blanks); + vec_init (&init_zero); + vec_init (&init_blanks); + + last_vfm_invocation = time (NULL); + + /* lexer.h */ + ds_init (NULL, &tokstr, 64); + + /* common.h */ + { + char *cp; + + pgmname = argv[0]; + for (;;) + { + cp = strchr (pgmname, DIR_SEPARATOR); + if (!cp) + break; + pgmname = &cp[1]; + } + cur_proc = NULL; + } + + /* settings.h */ +#if !USE_INTERNAL_PAGER + { + char *pager; + + pager = getenv ("STAT_PAGER"); + if (!pager) + pager = getenv ("PAGER"); + if (pager) + set_pager = xstrdup (pager); +#if DEFAULT_PAGER + else + set_pager = xstrdup (DEFAULT_PAGER); +#endif /* DEFAULT_PAGER */ + } +#endif /* !USE_INTERNAL_PAGER */ + + set_blanks = SYSMIS; + set_scompression = 1; + set_format.type = FMT_F; + set_format.w = 8; + set_format.d = 2; + set_cpi = 6; + set_lpi = 10; + set_results_file = xstrdup ("pspp.prc"); + set_dprompt = xstrdup (_("data> ")); + + { + int i; + + for (i = 0; i < 5; i++) + { + struct set_cust_currency *cc = &set_cc[i]; + strcpy (cc->buf, "-"); + cc->neg_prefix = cc->buf; + cc->prefix = &cc->buf[1]; + cc->suffix = &cc->buf[1]; + cc->neg_suffix = &cc->buf[1]; + cc->decimal = '.'; + cc->grouping = ','; + } + } + + set_decimal = '.'; + set_grouping = ','; + set_headers = 1; + set_journaling = 1; + set_journal = xstrdup ("pspp.jnl"); + set_messages = 1; + set_mexpand = 1; + set_mprint = 1; + set_mxerrs = 50; + set_mxwarns = 100; + set_printback = 1; + set_undefined = 1; + + set_cprompt = xstrdup (" > "); + set_echo = 0; + set_endcmd = '.'; + set_errorbreak = 0; + set_include = 1; + set_nullline = 1; + set_more = 1; + set_prompt = xstrdup ("PSPP> "); + set_seed = 2000000; + +#if __DJGPP__ || __BORLANDC__ + { + struct text_info ti; + + gettextinfo (&ti); + set_viewlength = max (ti.screenheight, 25); + set_viewwidth = max (ti.screenwidth, 79); + } +#elif HAVE_LIBTERMCAP + { + char *termtype; + int success; + + /* This code stolen from termcap.info, though modified. */ +#if !__CHECKER__ + term_buffer = xmalloc (2048); +#endif + + termtype = getenv ("TERM"); + if (!termtype) + msg (FE, _("Specify a terminal type with `setenv TERM '.")); + +#if __CHECKER__ + success = tgetent (NULL, termtype); +#else + success = tgetent (term_buffer, termtype); +#endif + + if (success <= 0) + { + if (success < 0) + msg (IE, _("Could not access the termcap data base.")); + else + msg (IE, _("Terminal type `%s' is not defined."), termtype); + msg (MM, _("Assuming screen of size 79x25.")); + set_viewlength = 25; + set_viewwidth = 79; + } + else + { + set_viewlength = tgetnum ("li"); + set_viewwidth = tgetnum ("co") - 1; + } + } +#else /* !HAVE_LIBTERMCAP */ + set_viewlength = 25; + set_viewwidth = 79; +#endif /* !HAVE_LIBTERMCAP */ + + /* log.h */ + logging = 1; + logfn = xstrdup ("pspp.log"); + logfile = NULL; + + /* file-handle.h */ + { + extern void fh_init_files (void); + + fh_init_files (); + } + + get_date (); +} + +static void +get_date () +{ + static const char *months[12] = + { + N_("Jan"), N_("Feb"), N_("Mar"), N_("Apr"), N_("May"), N_("Jun"), + N_("Jul"), N_("Aug"), N_("Sep"), N_("Oct"), N_("Nov"), N_("Dec"), + }; + + time_t t; + int mn, dy, yr; + struct tm *tmp; + + if ((time_t) -1 == time (&t)) + { + strcpy (curdate, "1 Jan 1970"); + return; + } + tmp = localtime (&t); + + mn = tmp->tm_mon; + if (mn < 0) + mn = 0; + if (mn > 11) + mn = 11; + + dy = tmp->tm_mday; + if (dy < 0) + dy = 0; + if (dy > 99) + dy = 99; + + yr = tmp->tm_year + 1900; + if (yr < 0) + yr = 0; + if (yr > 9999) + yr = 9999; + + sprintf (curdate, "%2d %s %04d", dy, gettext (months[mn]), yr); +} + +int +cmp_variable (const void *a, const void *b, void *foo unused) +{ + return strcmp (((struct variable *) a)->name, ((struct variable *) b)->name); +} + +#if __BORLANDC__ +int +_RTLENTRY _EXPFUNC _matherr (struct exception _FAR *__e) +{ + return 1; +} + +int +_RTLENTRY _EXPFUNC _matherrl (struct _exceptionl _FAR *__e) +{ + return 1; +} +#endif diff --git a/src/groff-font.c b/src/groff-font.c new file mode 100644 index 00000000..2510b894 --- /dev/null +++ b/src/groff-font.c @@ -0,0 +1,1010 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "font.h" +#include "hash.h" +#include "pool.h" +#include "str.h" +#include "version.h" + +int font_number_to_index (int); + +int space_index; + +static int font_msg (int, const char *,...) + __attribute__ ((format (printf, 2, 3))); +static void scan_badchars (char *, int); +static void dup_char_metric (struct font_desc * font, int dest, int src); +static void add_char_metric (struct font_desc * font, struct char_metrics *metrics, + int code); +static void add_kern (struct font_desc * font, int ch1, int ch2, int adjust); + +/* Typical whitespace characters for tokenizing. */ +static const char whitespace[] = " \t\n\r\v"; + +void +groff_init (void) +{ + space_index = font_char_name_to_index ("space"); +} + +/* Some notes on the groff_font(8) manpage: + + DESC file format: A typical PostScript `res' would be 72000, with + `hor' and `vert' set to 1 to indicate that all those positions are + valid. `sizescale' of 1000 would indicate that a scaled point is + 1/1000 of a point (which is 1/72000 of an inch, the same as the + number of machine units per inch indicated on `res'). `unitwidth' + of 1000 would indicate that font files are set up for fonts with + point size of 1000 scaled points, which would equal 1/72 inch or 1 + point (this would tell Groff's postprocessor that it needs to scale + the font 12 times larger to get a 12-point font). */ + +/* Reads a Groff font description file and converts it to a usable + binary format in memory. Installs the binary format in the global + font table. See groff_font(8) for a description of the font + description format supported. Returns nonzero on success. */ +struct font_desc * +groff_read_font (const char *fn) +{ + struct char_metrics *metrics; + + /* Pool created for font, font being created, font file. */ + struct pool *font_pool = NULL; + struct font_desc *font = NULL; + FILE *f = NULL; + + /* Current line, size of line buffer, length of line. */ + char *line = NULL; + size_t size; + int len; + + /* Tokenization saved pointer. */ + char *sp; + + /* First token on line. */ + char *key; + + /* 0=kernpairs section, 1=charset section. */ + int charset; + + /* Index for previous line. */ + int prev_index = -1; + + /* Current location in file, used for error reporting. */ + struct file_locator where; + +#if unix + fn = fn_tilde_expand (fn); +#endif + + msg (VM (1), _("%s: Opening Groff font file..."), fn); + + where.filename = fn; + where.line_number = 1; + err_push_file_locator (&where); + + f = fopen (fn, "r"); + if (!f) + goto file_lossage; + + font_pool = pool_create (); + font = pool_alloc (font_pool, sizeof *font); + font->owner = font_pool; + font->name = NULL; + font->internal_name = NULL; + font->encoding = NULL; + font->space_width = 0; + font->slant = 0.0; + font->ligatures = 0; + font->special = 0; + font->deref = NULL; + font->deref_size = 0; + font->metric = NULL; + font->metric_size = 0; + font->metric_used = 0; + font->kern = NULL; + font->kern_size = 0; + font->kern_size_p = hsh_next_prime (64); + font->kern_used = 0; + font->kern_max_used = 0; + + /* Parses first section of font file. */ + for (;;) + { + /* Location of '#' in line. */ + char *p; + + len = getline (&line, &size, f); + if (len == -1) + break; + + scan_badchars (line, len); + p = strchr (line, '#'); + if (p) + *p = '\0'; /* Reject comments. */ + + key = strtok_r (line, whitespace, &sp); + if (!key) + goto next_iteration; + + if (!strcmp (key, "internalname")) + { + font->internal_name = strtok_r (NULL, whitespace, &sp); + if (font->internal_name == NULL) + { + font_msg (SE, _("Missing font name.")); + goto lose; + } + font->internal_name = pool_strdup (font_pool, font->internal_name); + } + else if (!strcmp (key, "encoding")) + { + font->encoding = strtok_r (NULL, whitespace, &sp); + if (font->encoding == NULL) + { + font_msg (SE, _("Missing encoding filename.")); + goto lose; + } + font->encoding = pool_strdup (font_pool, font->encoding); + } + else if (!strcmp (key, "spacewidth")) + { + char *n = strtok_r (NULL, whitespace, &sp); + char *tail; + if (n) + font->space_width = strtol (n, &tail, 10); + if (n == NULL || tail == n) + { + font_msg (SE, _("Bad spacewidth value.")); + goto lose; + } + } + else if (!strcmp (key, "slant")) + { + char *n = strtok_r (NULL, whitespace, &sp); + char *tail; + if (n) + font->slant = strtod (n, &tail); + if (n == NULL || tail == n) + { + font_msg (SE, _("Bad slant value.")); + goto lose; + } + } + else if (!strcmp (key, "ligatures")) + { + char *lig; + + for (;;) + { + lig = strtok_r (NULL, whitespace, &sp); + if (!lig || !strcmp (lig, "0")) + break; + else if (!strcmp (lig, "ff")) + font->ligatures |= LIG_ff; + else if (!strcmp (lig, "ffi")) + font->ligatures |= LIG_ffi; + else if (!strcmp (lig, "ffl")) + font->ligatures |= LIG_ffl; + else if (!strcmp (lig, "fi")) + font->ligatures |= LIG_fi; + else if (!strcmp (lig, "fl")) + font->ligatures |= LIG_fl; + else + { + font_msg (SE, _("Unknown ligature `%s'."), lig); + goto lose; + } + } + } + else if (!strcmp (key, "special")) + font->special = 1; + else if (!strcmp (key, "charset") || !strcmp (key, "kernpairs")) + break; + + where.line_number++; + } + if (ferror (f)) + goto file_lossage; + + /* Parses second section of font file (metrics & kerning data). */ + do + { + key = strtok_r (line, whitespace, &sp); + if (!key) + goto next_iteration; + + if (!strcmp (key, "charset")) + charset = 1; + else if (!strcmp (key, "kernpairs")) + charset = 0; + else if (charset) + { + struct char_metrics *metrics = pool_alloc (font_pool, + sizeof *metrics); + char *m, *type, *code, *tail; + + m = strtok_r (NULL, whitespace, &sp); + if (!m) + { + font_msg (SE, _("Unexpected end of line reading character " + "set.")); + goto lose; + } + if (!strcmp (m, "\"")) + { + if (!prev_index) + { + font_msg (SE, _("Can't use ditto mark for first character.")); + goto lose; + } + if (!strcmp (key, "---")) + { + font_msg (SE, _("Can't ditto into an unnamed character.")); + goto lose; + } + dup_char_metric (font, font_char_name_to_index (key), prev_index); + where.line_number++; + goto next_iteration; + } + + if (m) + { + metrics->code = metrics->width + = metrics->height = metrics->depth = 0; + } + + if (m == NULL || 1 > sscanf (m, "%d,%d,%d", &metrics->width, + &metrics->height, &metrics->depth)) + { + font_msg (SE, _("Missing metrics for character `%s'."), key); + goto lose; + } + + type = strtok_r (NULL, whitespace, &sp); + if (type) + metrics->type = strtol (type, &tail, 10); + if (!type || tail == type) + { + font_msg (SE, _("Missing type for character `%s'."), key); + goto lose; + } + + code = strtok_r (NULL, whitespace, &sp); + if (code) + metrics->code = strtol (code, &tail, 0); + if (tail == code) + { + font_msg (SE, _("Missing code for character `%s'."), key); + goto lose; + } + + if (strcmp (key, "---")) + prev_index = font_char_name_to_index (key); + else + prev_index = font_number_to_index (metrics->code); + add_char_metric (font, metrics, prev_index); + } + else + { + char *c1 = key; + char *c2 = strtok_r (NULL, whitespace, &sp); + char *n, *tail; + int adjust; + + if (c2 == NULL) + { + font_msg (SE, _("Malformed kernpair.")); + goto lose; + } + + n = strtok_r (NULL, whitespace, &sp); + if (!n) + { + font_msg (SE, _("Unexpected end of line reading kernpairs.")); + goto lose; + } + adjust = strtol (n, &tail, 10); + if (tail == n || *tail) + { + font_msg (SE, _("Bad kern value.")); + goto lose; + } + add_kern (font, font_char_name_to_index (c1), + font_char_name_to_index (c2), adjust); + } + + next_iteration: + where.line_number++; + + len = getline (&line, &size, f); + } + while (len != -1); + + if (ferror (f)) + goto file_lossage; + if (fclose (f) == EOF) + { + f = NULL; + goto file_lossage; + } + free (line); +#if unix + free ((char *) fn); +#endif + + /* Get font ascent and descent. */ + metrics = font_get_char_metrics (font, font_char_name_to_index ("d")); + font->ascent = metrics ? metrics->height : 0; + metrics = font_get_char_metrics (font, font_char_name_to_index ("p")); + font->descent = metrics ? metrics->depth : 0; + + msg (VM (2), _("Font read successfully with internal name %s."), + font->internal_name == NULL ? "" : font->internal_name); + + err_pop_file_locator (&where); + + return font; + + /* Come here on a file error. */ +file_lossage: + msg (ME, "%s: %s", fn, strerror (errno)); + + /* Come here on any error. */ +lose: + fclose (f); + pool_destroy (font_pool); +#if unix + free ((char *) fn); +#endif + err_pop_file_locator (&where); + + msg (VM (1), _("Error reading font.")); + return NULL; +} + +/* Prints a font error on stderr. */ +static int +font_msg (int class, const char *format,...) +{ + va_list args; + + va_start (args, format); + tmsg (class, format, args, _("installation error: Groff font error: ")); + va_end (args); + + return 0; +} + +/* Scans string LINE of length LEN (not incl. null terminator) for bad + characters, converts to spaces; reports warnings on file FN. */ +static void +scan_badchars (char *line, int len) +{ + unsigned char *cp = line; + + /* Same bad characters as Groff. */ + static unsigned char badchars[32] = + { + 0x01, 0xe8, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0xff, 0xff, 0xff, 0xff, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + }; + + for (; len--; cp++) + if (badchars[*cp >> 3] & (1 << (*cp & 7))) + { + font_msg (SE, _("Bad character \\%3o."), *cp); + *cp = ' '; + } +} + +/* Character name hashing. */ + +/* Associates a character index with a character name. */ +struct index_hash + { + char *name; + int index; + }; + +/* Character index hash table. */ +static struct + { + int size; /* Size of table. */ + int *size_p; /* Next larger table size. */ + int used; /* Number of full entries. */ + int max_used; /* # used entries where we enlarge & rehash. */ + int next_index; /* Next index to allocate. */ + struct index_hash *tab; /* Hash table proper. */ + struct pool *ar; /* Pool for names. */ + } +hash; + +/* Searches for NAME in the global character code table, returns the + index if found; otherwise inserts NAME and returns the new + index. */ +int +font_char_name_to_index (const char *name) +{ + int i; + + if (name[0] == ' ') + return space_index; + if (name[0] == '\0' || name[1] == '\0') + return name[0]; + if (0 == strncmp (name, "char", 4)) + { + char *tail; + int x = strtol (name + 4, &tail, 10); + if (tail != name + 4 && *tail == 0 && x >= 0 && x <= 255) + return x; + } + + if (!hash.tab) + { + hash.size_p = hsh_next_prime (128); + hash.size = *hash.size_p++; + hash.used = 0; + hash.max_used = hash.size / 2; + hash.next_index = 256; + hash.tab = xmalloc (sizeof *hash.tab * hash.size); + hash.ar = pool_create (); + for (i = 0; i < hash.size; i++) + hash.tab[i].name = NULL; + } + + for (i = hashpjw (name) % hash.size; hash.tab[i].name;) + { + if (!strcmp (hash.tab[i].name, name)) + return hash.tab[i].index; + if (++i >= hash.size) + i = 0; + } + + hash.used++; + if (hash.used >= hash.max_used) + { + struct index_hash *old_tab = hash.tab; + int old_size = hash.size; + int i, j; + + hash.size = *hash.size_p++; + hash.max_used = hash.size / 2; + hash.tab = xmalloc (sizeof *hash.tab * hash.size); + for (i = 0; i < hash.size; i++) + hash.tab[i].name = NULL; + for (i = 0; i < old_size; i++) + if (old_tab[i].name) + { + for (j = hashpjw (old_tab[i].name) % hash.size; hash.tab[j].name;) + if (++j >= hash.size) + j = 0; + hash.tab[j] = old_tab[i]; + } + free (old_tab); + } + + hash.tab[i].name = pool_strdup (hash.ar, name); + hash.tab[i].index = hash.next_index; + return hash.next_index++; +} + +/* Returns an index for a character that has only a code, not a + name. */ +int +font_number_to_index (int x) +{ + char name[INT_DIGITS + 2]; + + /* Note that space is the only character that can't appear in a + character name. That makes it an excellent choice for a name + that won't conflict. */ + sprintf (name, " %d", x); + return font_char_name_to_index (name); +} + +/* Font character metric entries. */ + +/* Ensures room for at least MIN_SIZE metric indexes in deref of + FONT. */ +static void +check_deref_space (struct font_desc *font, int min_size) +{ + if (min_size >= font->deref_size) + { + int i = font->deref_size; + + font->deref_size = min_size + 16; + if (font->deref_size < 256) + font->deref_size = 256; + font->deref = pool_realloc (font->owner, font->deref, + sizeof *font->deref * font->deref_size); + for (; i < font->deref_size; i++) + font->deref[i] = -1; + } +} + +/* Inserts METRICS for character with code CODE into FONT. */ +static void +add_char_metric (struct font_desc *font, struct char_metrics *metrics, int code) +{ + check_deref_space (font, code); + if (font->metric_used >= font->metric_size) + { + font->metric_size += 64; + font->metric = pool_realloc (font->owner, font->metric, + sizeof *font->metric * font->metric_size); + } + font->metric[font->metric_used] = metrics; + font->deref[code] = font->metric_used++; +} + +/* Copies metric in FONT from character with code SRC to character + with code DEST. */ +static void +dup_char_metric (struct font_desc *font, int dest, int src) +{ + check_deref_space (font, dest); + assert (font->deref[src] != -1); + font->deref[dest] = font->deref[src]; +} + +/* Kerning. */ + +/* Returns a hash value for characters with codes CH1 and CH2. */ +#define hash_kern(CH1, CH2) \ + ((unsigned) (((CH1) << 16) ^ (CH2))) + +/* Adds an ADJUST-size kern to FONT between characters with codes CH1 + and CH2. */ +static void +add_kern (struct font_desc *font, int ch1, int ch2, int adjust) +{ + int i; + + if (font->kern_used >= font->kern_max_used) + { + struct kern_pair *old_kern = font->kern; + int old_kern_size = font->kern_size; + int j; + + font->kern_size = *font->kern_size_p++; + font->kern_max_used = font->kern_size / 2; + font->kern = pool_malloc (font->owner, + sizeof *font->kern * font->kern_size); + for (i = 0; i < font->kern_size; i++) + font->kern[i].ch1 = -1; + + for (i = 0; i < old_kern_size; i++) + { + if (old_kern[i].ch1 == -1) + continue; + + j = hash_kern (old_kern[i].ch1, old_kern[i].ch2) % font->kern_size; + while (font->kern[j].ch1 != -1) + if (0 == j--) + j = font->kern_size - 1; + font->kern[j] = old_kern[i]; + } + if (old_kern) + pool_free (font->owner, old_kern); + } + + for (i = hash_kern (ch1, ch2) % font->kern_size; font->kern[i].ch1 != -1;) + if (0 == i--) + i = font->kern_size - 1; + font->kern[i].ch1 = ch1; + font->kern[i].ch2 = ch2; + font->kern[i].adjust = adjust; + font->kern_used++; +} + +/* Finds a font file corresponding to font NAME for device DEV. */ +static char * +find_font_file (const char *dev, const char *name) +{ + char *basename = xmalloc (3 + strlen (dev) + 1 + strlen (name) + 1); + char *cp; + char *filename; + char *path; + + cp = stpcpy (basename, "dev"); + cp = stpcpy (cp, dev); + *cp++ = DIR_SEPARATOR; + strcpy (cp, name); + + /* Search order: + 1. $STAT_GROFF_FONT_PATH + 2. $GROFF_FONT_PATH + 3. GROFF_FONT_PATH from pref.h + 4. config_path + */ + if ((path = getenv ("STAT_GROFF_FONT_PATH")) != NULL + && (filename = fn_search_path (basename, path, NULL)) != NULL) + goto win; + + if ((path = getenv ("GROFF_FONT_PATH")) != NULL + && (filename = fn_search_path (basename, path, NULL)) != NULL) + goto win; + + if ((filename = fn_search_path (basename, groff_font_path, NULL)) != NULL) + goto win; + + if ((filename = fn_search_path (basename, config_path, NULL)) != NULL) + goto win; + + msg (IE, _("Groff font error: Cannot find \"%s\"."), basename); + +win: + free (basename); + return filename; +} + +/* Finds a font for device DEV with name NAME, reads it with + groff_read_font(), and returns the resultant font. */ +struct font_desc * +groff_find_font (const char *dev, const char *name) +{ + char *filename = find_font_file (dev, name); + struct font_desc *fd; + + if (!filename) + return NULL; + fd = groff_read_font (filename); + free (filename); + return fd; +} + +/* Reads a DESC file for device DEV and sets the appropriate fields in + output driver *DRIVER, which must be previously allocated. Returns + nonzero on success. */ +int +groff_read_DESC (const char *dev_name, struct groff_device_info * dev) +{ + char *filename; /* Full name of DESC file. */ + FILE *f; /* DESC file. */ + + char *line = NULL; /* Current line. */ + int line_len; /* Number of chars in current line. */ + size_t line_size = 0; /* Number of chars allocated for line. */ + + char *token; /* strtok()'d token inside line. */ + + unsigned found = 0; /* Bitmask showing what settings + have been encountered. */ + + int m_sizes = 0; /* Number of int[2] items that + can fit in driver->sizes. */ + + char *sp; /* Tokenization string pointer. */ + struct file_locator where; + + int i; + + dev->horiz = 1; + dev->vert = 1; + dev->size_scale = 1; + dev->n_sizes = 0; + dev->sizes = NULL; + dev->family = NULL; + for (i = 0; i < 4; i++) + dev->font_name[i] = NULL; + + filename = find_font_file (dev_name, "DESC"); + if (!filename) + return 0; + + where.filename = filename; + where.line_number = 0; + err_push_file_locator (&where); + + msg (VM (1), _("%s: Opening Groff description file..."), filename); + f = fopen (filename, "r"); + if (!f) + goto file_lossage; + + while ((line_len = getline (&line, &line_size, f)) != -1) + { + where.line_number++; + + token = strtok_r (line, whitespace, &sp); + if (!token) + continue; + + if (!strcmp (token, "sizes")) + { + if (found & 0x10000) + font_msg (SW, _("Multiple `sizes' declarations.")); + for (;;) + { + char *tail; + int lower, upper; + + for (;;) + { + token = strtok_r (NULL, whitespace, &sp); + if (token) + break; + + where.line_number++; + if ((line_len = getline (&line, &line_size, f)) != -1) + { + if (ferror (f)) + goto file_lossage; + font_msg (SE, _("Unexpected end of file. " + "Missing 0 terminator to `sizes' command?")); + goto lossage; + } + } + + if (!strcmp (token, "0")) + break; + + errno = 0; + if (0 == (lower = strtol (token, &tail, 0)) || errno == ERANGE) + { + font_msg (SE, _("Bad argument to `sizes'.")); + goto lossage; + } + if (*tail == '-') + { + if (0 == (upper = strtol (&tail[1], &tail, 0)) || errno == ERANGE) + { + font_msg (SE, _("Bad argument to `sizes'.")); + goto lossage; + } + if (lower < upper) + { + font_msg (SE, _("Bad range in argument to `sizes'.")); + goto lossage; + } + } + else + upper = lower; + if (*tail) + { + font_msg (SE, _("Bad argument to `sizes'.")); + goto lossage; + } + + if (dev->n_sizes + 2 >= m_sizes) + { + m_sizes += 1; + dev->sizes = xrealloc (dev->sizes, + m_sizes * sizeof *dev->sizes); + } + dev->sizes[dev->n_sizes++][0] = lower; + dev->sizes[dev->n_sizes][1] = upper; + + found |= 0x10000; + } + } + else if (!strcmp (token, "family")) + { + token = strtok_r (NULL, whitespace, &sp); + if (!token) + { + font_msg (SE, _("Family name expected.")); + goto lossage; + } + if (found & 0x20000) + { + font_msg (SE, _("This command already specified.")); + goto lossage; + } + dev->family = xstrdup (token); + } + else if (!strcmp (token, "charset")) + break; + else + { + static const char *id[] + = {"res", "hor", "vert", "sizescale", "unitwidth", NULL}; + const char **cp; + int value; + + for (cp = id; *cp; cp++) + if (!strcmp (token, *cp)) + break; + if (*cp == NULL) + continue; /* completely ignore unrecognized lines */ + if (found & (1 << (cp - id))) + font_msg (SW, _("%s: Device characteristic already defined."), *cp); + + token = strtok_r (NULL, whitespace, &sp); + errno = 0; + if (!token || (value = strtol (token, NULL, 0)) <= 0 || errno == ERANGE) + { + font_msg (SE, _("%s: Invalid numeric format."), *cp); + goto lossage; + } + found |= (1 << (cp - id)); + switch (cp - id) + { + case 0: + dev->res = value; + break; + case 1: + dev->horiz = value; + break; + case 2: + dev->vert = value; + break; + case 3: + dev->size_scale = value; + break; + case 4: + dev->unit_width = value; + break; + default: + assert (0); + } + } + } + if (ferror (f)) + goto file_lossage; + if ((found & 0x10011) != 0x10011) + { + font_msg (SE, _("Missing `res', `unitwidth', and/or `sizes' line(s).")); + goto lossage; + } + + /* Font name = family name + suffix. */ + { + static const char *suffix[4] = + {"R", "I", "B", "BI"}; /* match OUTP_F_* */ + int len; /* length of family name */ + int i; + + if (!dev->family) + dev->family = xstrdup (""); + len = strlen (dev->family); + for (i = 0; i < 4; i++) + { + char *cp; + dev->font_name[i] = xmalloc (len + strlen (suffix[i]) + 1); + cp = stpcpy (dev->font_name[i], dev->family); + strcpy (cp, suffix[i]); + } + } + + dev->sizes[dev->n_sizes][0] = 0; + dev->sizes[dev->n_sizes][1] = 0; + + msg (VM (2), _("Description file read successfully.")); + + err_pop_file_locator (&where); + free (filename); + free (line); + return 1; + + /* Come here on a file error. */ +file_lossage: + msg (ME, "%s: %s", filename, strerror (errno)); + + /* Come here on any error. */ +lossage: + fclose (f); + free (line); + free (dev->family); + dev->family = NULL; + free (filename); + free (dev->sizes); + dev->sizes = NULL; + dev->n_sizes = 0; +#if 0 /* at the moment, no errors can come here when dev->font_name[*] are + nonzero. */ + for (i = 0; i < 4; i++) + { + free (dev->font_name[i]); + dev->font_name[i] = NULL; + } +#endif + + err_pop_file_locator (&where); + + msg (VM (1), _("Error reading description file.")); + + return 0; +} + +/* Finds character with index CH (as returned by name_to_index() or + number_to_index()) in font FONT and returns the associated metrics. + Nonexistent characters have width 0. */ +struct char_metrics * +font_get_char_metrics (const struct font_desc *font, int ch) +{ + short index; + + if (ch < 0 || ch >= font->deref_size) + return 0; + + index = font->deref[ch]; + if (index == -1) + return 0; + + return font->metric[index]; +} + +/* Finds kernpair consisting of CH1 and CH2, in that order, in font + FONT and returns the associated kerning adjustment. */ +int +font_get_kern_adjust (const struct font_desc *font, int ch1, int ch2) +{ + unsigned i; + + if (!font->kern) + return 0; + for (i = hash_kern (ch1, ch2) % font->kern_size; font->kern[i].ch1 != -1;) + { + if (font->kern[i].ch1 == ch1 && font->kern[i].ch2 == ch2) + return font->kern[i].adjust; + if (0 == i--) + i = font->kern_size - 1; + } + return 0; +} + +/* Returns a twelve-point fixed-pitch font that can be used as a + last-resort fallback. */ +struct font_desc * +default_font (void) +{ + struct pool *font_pool; + static struct font_desc *font; + + if (font) + return font; + font_pool = pool_create (); + font = pool_alloc (font_pool, sizeof *font); + font->owner = font_pool; + font->name = NULL; + font->internal_name = pool_strdup (font_pool, _("<>")); + font->encoding = pool_strdup (font_pool, "text.enc"); + font->space_width = 12000; + font->slant = 0.0; + font->ligatures = 0; + font->special = 0; + font->ascent = 8000; + font->descent = 4000; + font->deref = NULL; + font->deref_size = 0; + font->metric = NULL; + font->metric_size = 0; + font->metric_used = 0; + font->kern = NULL; + font->kern_size = 0; + font->kern_size_p = hsh_next_prime (64); + font->kern_used = 0; + font->kern_max_used = 0; + return font; +} diff --git a/src/hash.c b/src/hash.c new file mode 100644 index 00000000..9ade76f6 --- /dev/null +++ b/src/hash.c @@ -0,0 +1,344 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "hash.h" + +/* Note for constructing hash functions: + + You can store the hash values in the records, then compare hash + values (in the compare function) before bothering to compare keys. + Hash values can simply be returned from the records instead of + recalculating when rehashing. */ + +/* Debugging note: + + Since hash_probe and hash_find take void * pointers, it's easy to + pass a void ** to your data by accidentally inserting an `&' + reference operator where one shouldn't go. It took me an hour to + hunt down a bug like that once. */ + +/* Prime numbers and hash functions. */ + +static int hsh_prime_tab[] = +{ + 13, 31, 47, 67, 131, 257, 521, 1031, 2053, 4099, 8209, 16411, + 32771, 65537, 131101, 262147, 524309, 1048583, 2097169, 4194319, + 8388617, 16777259, 33554467, 67108879, 134217757, 268435459, + 536870923, 1073741827, INT_MAX, +}; + +/* Returns pointer into hsh_prime_tab[], pointing to the first prime + in the table greater than X. */ +int * +hsh_next_prime (int x) +{ + int *p; + + assert (x >= 0); + + for (p = hsh_prime_tab; *p < x; p++) + ; + + assert (*p != INT_MAX); + + return p; +} + +/* P.J. Weinberger's hash function, recommended by the Red Dragon + Book. Hashes the d-string between S1 and S2. Returns unbounded + nonnegative result. */ +int +hashpjw_d (const char *s1, const char *s2) +{ + const char *p; + unsigned g, h; + + for (h = 0, p = s1; p < s2; p++) + { + h = (h << 4) + *(unsigned char *) p; + g = h & 0xf0000000; + h ^= (g >> 24) | g; + } + return abs ((int) h); +} + +/* Alternate entry point for hashpjw_d() that takes an s-string. */ +int +hashpjw (const char *s) +{ + return hashpjw_d (s, &s[strlen (s)]); +} + +/*hash tables. */ + +/* Creates a hash table with at least M entries. COMPARE is a + function that compares two entries and returns 0 if they are + identical, nonzero otherwise; HASH returns a nonnegative hash value + for an entry; FREE destroys an entry. */ +struct hsh_table * +hsh_create (int m, + int (*compare) (const void *, const void *, void *param), + unsigned (*hash) (const void *, void *param), + void (*free) (void *, void *param), + void *param) +{ + struct hsh_table *h = xmalloc (sizeof *h); + int i; + + h->n = 0; + h->mp = hsh_next_prime (m); + h->m = *h->mp++; + h->table = xmalloc (sizeof *h->table * h->m); + for (i = 0; i < h->m; i++) + h->table[i] = NULL; + h->param = param; + h->compare = compare; + h->hash = hash; + h->free = free; + return h; +} + +/* Destroys the contents of table H. */ +void +hsh_clear (struct hsh_table *h) +{ + int i; + + if (h->free) + for (i = 0; i < h->m; i++) + h->free (h->table[i], h->param); + + if (h->m >= 128) + { + free (h->table); + h->mp = hsh_next_prime (31); + h->m = *h->mp++; + h->table = xmalloc (sizeof *h->table * h->m); + } + + for (i = 0; i < h->m; i++) + h->table[i] = NULL; +} + +/* Destroys table H and all its contents. */ +void +hsh_destroy (struct hsh_table *h) +{ + int i; + + if (h == NULL) + return; + if (h->free) + for (i = 0; i < h->m; i++) + { + void *p = h->table[i]; + if (p) + h->free (p, h->param); + } + free (h->table); + free (h); +} + +/* Increases the capacity of H. */ +void +hsh_rehash (struct hsh_table *h) +{ + void **begin = h->table; + void **end = &h->table[h->m]; + void **table_p; + int i; + + h->m = *h->mp++; + h->table = xmalloc (sizeof *h->table * h->m); + for (i = 0; i < h->m; i++) + h->table[i] = NULL; + for (table_p = begin; table_p < end; table_p++) + { + void **entry; + + if (*table_p == NULL) + continue; + entry = &h->table[h->hash (*table_p, h->param) % h->m]; + while (*entry) + if (--entry < h->table) + entry = &h->table[h->m - 1]; + *entry = *table_p; + } + free (begin); +} + +/* Static variables for hsh_sort(). */ +static void *hsh_param; +static int (*hsh_compare) (const void *, const void *, void *param); + +/* hsh_sort() helper function that ensures NULLs are sorted after the + rest of the table. */ +static int +internal_comparison_fn (const void *pa, const void *pb) +{ + void *a = *(void **) pa; + void *b = *(void **) pb; + return a == NULL ? 1 : (b == NULL ? -1 : hsh_compare (a, b, hsh_param)); +} + +/* Sorts hash table H based on function COMPARE. NULLs are sent to + the end of the table. The resultant table is returned (it is + guaranteed to be NULL-terminated). H should not be used again as a + hash table until and unless hsh_clear() called. */ +void ** +hsh_sort (struct hsh_table *h, + int (*compare) (const void *, const void *, void *param)) +{ +#if GLOBAL_DEBUGGING + static int reentrant; + if (reentrant) + abort (); + reentrant++; +#endif + hsh_param = h->param; + hsh_compare = compare ? compare : h->compare; + qsort (h->table, h->m, sizeof *h->table, internal_comparison_fn); +#if GLOBAL_DEBUGGING + reentrant--; +#endif + return h->table; +} + +/* Hash entries. */ + +/* Searches hash table H for TARGET. If found, returns a pointer to a + pointer to that entry; otherwise returns a pointer to a NULL entry + which _must_ be used to insert a new entry having the same key + data. */ +inline void ** +hsh_probe (struct hsh_table *h, const void *target) +{ + void **entry; + + /* Order of these statements is important! */ + if (h->n > h->m / 2) + hsh_rehash (h); + entry = &h->table[h->hash (target, h->param) % h->m]; + + while (*entry) + { + if (!h->compare (*entry, target, h->param)) + return entry; + + if (--entry < h->table) + entry = &h->table[h->m - 1]; + } + h->n++; + return entry; +} + +/* Returns the entry in hash table H that matches TARGET, NULL if + there is none. */ +void * +hsh_find (struct hsh_table *h, const void *target) +{ + void **entry = &h->table[h->hash (target, h->param) % h->m]; + + while (*entry) + { + if (!h->compare (*entry, target, h->param)) + return *entry; + if (--entry < h->table) + entry = &h->table[h->m - 1]; + } + return NULL; +} + +/* Iterates throught hash table TABLE with iterator ITER. Returns the + next non-NULL entry in TABLE, or NULL after the last non-NULL + entry. After NULL is returned, ITER is returned to a condition in + which hsh_foreach() will return the first non-NULL entry if any on + the next call. Do not add entries to TABLE between call to + hsh_foreach() between NULL returns. + + Before calling hsh_foreach with a particular iterator for the first + time, you must initialize the iterator with a call to + hsh_iterator_init. */ +void * +hsh_foreach (struct hsh_table *table, struct hsh_iterator *iter) +{ + int i; + + if (!table) + return NULL; + if (!iter->init) + { + iter->init = 1; + iter->next = 0; + } + for (i = iter->next; i < table->m; i++) + if (table->table[i]) + { + iter->next = i + 1; + return table->table[i]; + } + iter->init = 0; + return NULL; +} + +#if GLOBAL_DEBUGGING +#include + +/* Displays contents of hash table H on stdout. */ +void +hsh_dump (struct hsh_table *h) +{ + void **entry = h->table; + int i; + + printf (_("hash table:")); + for (i = 0; i < h->m; i++) + printf (" %p", *entry++); + printf ("\n"); +} + +/* This wrapper around hsh_probe() assures that it returns a pointer + to a NULL pointer. This function is used when it is known that the + entry to be inserted does not already exist in the table. */ +void +force_hsh_insert (struct hsh_table *h, void *p) +{ + void **pp = hsh_probe (h, p); + if (*pp != NULL) + assert (0); + *pp = p; +} + +/* This wrapper around hsh_find() assures that it returns non-NULL. + This function is for use when it is known that the entry being + searched for must exist in the table. */ +void * +force_hsh_find (struct hsh_table *h, const void *p) +{ + p = hsh_find (h, p); + if (p == NULL) + assert (0); + return (void *) p; +} +#endif diff --git a/src/hash.h b/src/hash.h new file mode 100644 index 00000000..048d2f24 --- /dev/null +++ b/src/hash.h @@ -0,0 +1,95 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !hash_h +#define hash_h 1 + +/* Hash table (opaque). */ +struct hsh_table + { + int n; /* Number of filled entries. */ + int m; /* Number of entries. */ + int *mp; /* Pointer into hsh_prime_tab[]. */ + void **table; /* Hash table proper. */ + + void *param; + int (*compare) (const void *, const void *, void *param); + unsigned (*hash) (const void *, void *param); + void (*free) (void *, void *param); + }; + +/* Hash table iterator (opaque). */ +struct hsh_iterator + { + int init; /* Initialized? */ + int next; /* Index of next entry. */ + }; + +#define hsh_iterator_init(ITERATOR) (ITERATOR).init = 0 + +/* Prime numbers and hash functions. */ +int *hsh_next_prime (int) __attribute__ ((const)); +int hashpjw_d (const char *s1, const char *s2); + +#if __GNUC__>=2 && __OPTIMIZE__ +extern inline int +hashpjw (const char *s) +{ + return hashpjw_d (s, &s[strlen (s)]); +} +#else +int hashpjw (const char *s); +#endif + +/* Hash tables. */ +struct hsh_table *hsh_create (int m, + int (*compare) (const void *, const void *, + void *param), + unsigned (*hash) (const void *, void *param), + void (*free) (void *, void *param), + void *param); +void hsh_clear (struct hsh_table *); +void hsh_destroy (struct hsh_table *); +void hsh_rehash (struct hsh_table *); +void **hsh_sort (struct hsh_table *, + int (*compare) (const void *, const void *, void *param)); +#if GLOBAL_DEBUGGING +void hsh_dump (struct hsh_table *); +#endif + +/* Hash entries. */ +void **hsh_probe (struct hsh_table *, const void *); +void *hsh_find (struct hsh_table *, const void *); +void *hsh_foreach (struct hsh_table *, struct hsh_iterator *); + +#if GLOBAL_DEBUGGING +void force_hsh_insert (struct hsh_table *, void *); +void *force_hsh_find (struct hsh_table *, const void *); +#else +#define force_hsh_insert(A, B) \ + do *hsh_probe (A, B) = B; while (0) +#define force_hsh_find(A, B) \ + hsh_find (A, B) +#endif + +/* Returns number of used elements in hash table H. */ +#define hsh_count(H) \ + ((H)->n) + +#endif /* hash_h */ diff --git a/src/heap.c b/src/heap.c new file mode 100644 index 00000000..a90aefda --- /dev/null +++ b/src/heap.c @@ -0,0 +1,269 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "heap.h" + +#if STANDALONE +#define GLOBAL_DEBUGGING 1 +#define _(x) (x) +#endif + +/* Creates and returns a heap with an initial capacity of M_ELEM + elements. Returns nonzero only if successful. */ +struct heap * +heap_create (size_t m_elem) +{ + struct heap *h = malloc (sizeof *h); + if (h != NULL) + { + h->n_elem = 0; + h->m_elem = m_elem; + h->elem = malloc (h->m_elem * sizeof *h->elem); + if (h->elem == NULL) + { + free (h); + h = NULL; + } + } + return h; +} + +/* Destroys the heap at *H. */ +void +heap_destroy (struct heap *h) +{ + assert (h != NULL); + free (h->elem); + free (h); +} + +/* Inserts into heap *H an element having index INDEX and key KEY. + Returns nonzero only if successful. */ +int +heap_insert (struct heap *h, int index, int key) +{ + int i, j; + + assert (h != NULL); + if (h->n_elem >= h->m_elem) + { + h->elem = realloc (h->elem, 2 * h->m_elem * sizeof *h->elem); + if (h->elem == NULL) + return 0; + h->m_elem *= 2; + } + + /* Knuth's Algorithm 5.2.3-16. Step 1. */ + j = h->n_elem + 1; + + for (;;) + { + /* Step 2. */ + i = j / 2; + + /* Step 3. */ + if (i == 0 || h->elem[i - 1].key <= key) + { + h->elem[j - 1].index = index; + h->elem[j - 1].key = key; + h->n_elem++; + return 1; + } + + /* Step 4. */ + h->elem[j - 1] = h->elem[i - 1]; + j = i; + } +} + +/* Deletes the first element in the heap (the one with the greatest + index) and returns its index, or -1 if the heap is empty. If KEY + is non-NULL then *KEY is set to the deleted element's key, if it + returns non-NULL. */ +int +heap_delete (struct heap *h, int *key) +{ + /* Knuth's Algorithm 5.2.3H-19. */ + int first, K, R, l, r, i, j; + + if (h->n_elem == 0) + return -1; + first = h->elem[0].index; + if (key) + *key = h->elem[0].key; + K = h->elem[h->n_elem - 1].key; + R = h->elem[h->n_elem - 1].index; + l = 1; + r = h->n_elem - 1; + + /* H3. */ + j = 1; + +H4: + i = j; + j *= 2; + if (j == r) + goto H6; + else if (j > r) + goto H8; + + /* H5. */ + if (h->elem[j - 1].key > h->elem[j].key) + j++; + +H6: + if (K <= h->elem[j - 1].key) + goto H8; + + /* H7. */ + h->elem[i - 1] = h->elem[j - 1]; + goto H4; + +H8: + h->elem[i - 1].key = K; + h->elem[i - 1].index = R; + + h->n_elem--; + return first; +} + +/* Returns the number of elements in heap H. */ +int +heap_size (struct heap *h) +{ + return h->n_elem; +} + +#if GLOBAL_DEBUGGING +/* Checks that a heap is really a heap. */ +void +heap_verify (const struct heap *h) +{ + size_t j; + + for (j = 1; j <= h->n_elem; j++) + { + if (j / 2 >= 1 && h->elem[j / 2 - 1].key > h->elem[j - 1].key) + printf (_("bad ordering of keys %d and %d\n"), j / 2 - 1, j - 1); + } +} + +/* Dumps out the heap on stdout. */ +void +heap_dump (const struct heap *h) +{ + size_t j; + + printf (_("Heap contents:\n")); + for (j = 1; j <= h->n_elem; j++) + { + int partner; + if (j / 2 >= 1) + partner = h->elem[j / 2 - 1].key; + else + partner = -1; + printf ("%6d-%5d", h->elem[j - 1].key, partner); + } +} +#endif /* GLOBAL_DEBUGGING */ + +#if STANDALONE +#include + +/* To perform a fairly thorough test of the heap routines, define + STANDALONE to nonzero then compile this file by itself. */ + +/* Compares the second elements of the integer arrays at _A and _B and + returns a strcmp()-type result. */ +int +compare_int2 (const void *pa, const void *pb) +{ + int *a = (int *) pa; + int *b = (int *) pb; + + return a[1] - b[1]; +} + +#define N_ELEM 16 + +/* Arrange the N elements of ARRAY in random order. */ +void +shuffle (int (*array)[2], int n) +{ + int i; + + for (i = 0; i < n; i++) + { + int j = i + rand () % (n - i); + int t = array[j][0], s = array[j][1]; + array[j][0] = array[i][0], array[j][1] = array[i][1]; + array[i][0] = t, array[i][1] = s; + } +} + +/* Test routine. */ +int +main (void) +{ + struct heap *h; + int i; + int array[N_ELEM][2]; + + srand (time (0)); + + h = heap_create (16); + for (i = 0; i < N_ELEM; i++) + { + array[i][0] = i; + array[i][1] = N_ELEM - i - 1; + } + shuffle (array, N_ELEM); + + printf ("Insertion order:\n"); + for (i = 0; i < N_ELEM; i++) + { + printf ("(%d,%d) ", array[i][0], array[i][1]); + heap_insert (h, array[i][0], array[i][1]); + heap_verify (h); + } + putchar ('\n'); + + /*heap_dump(&h); */ + + printf ("\nDeletion order:\n"); + for (i = 0; i < N_ELEM; i++) + { + int index, key; + index = heap_delete (h, &key); + assert (index != -1); + printf ("(%d,%d) ", index, key); + fflush (stdout); + assert (index == N_ELEM - i - 1 && key == i); + heap_verify (h); + } + putchar ('\n'); + heap_destroy (h); + + return 0; +} +#endif diff --git a/src/heap.h b/src/heap.h new file mode 100644 index 00000000..7644356b --- /dev/null +++ b/src/heap.h @@ -0,0 +1,52 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !heap_h +#define heap_h 1 + +/* This module implements a priority queue as a heap as described in + Knuth 5.2.3. This is a first-in-smallest-out priority queue. */ + +/* One element of a heap. */ +struct heap_elem + { + int index; /* Data. */ + int key; /* Key value. */ + }; + +/* An entire heap. */ +struct heap + { + size_t n_elem; /* Number of elements in heap. */ + size_t m_elem; /* Number of elements allocated for heap. */ + struct heap_elem *elem; /* Heap elements. */ + }; + +struct heap *heap_create (size_t m_elem); +void heap_destroy (struct heap *); +int heap_insert (struct heap *, int index, int key); +int heap_delete (struct heap *, int *key); +int heap_size (struct heap *); + +#if GLOBAL_DEBUGGING +void heap_verify (const struct heap *); +void heap_dump (const struct heap *); +#endif + +#endif /* heap_h */ diff --git a/src/html.c b/src/html.c new file mode 100644 index 00000000..c647f34b --- /dev/null +++ b/src/html.c @@ -0,0 +1,623 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* This #if encloses the rest of the file. */ +#if !NO_HTML + +#include +#include +#include +#include +#include +#include + +#if HAVE_UNISTD_H +#include +#endif + +#include "alloc.h" +#include "error.h" +#include "filename.h" +#include "getline.h" +#include "htmlP.h" +#include "output.h" +#include "som.h" +#include "tab.h" +#include "version.h" + +/* Prototypes. */ +static int postopen (struct file_ext *); +static int preclose (struct file_ext *); + +int +html_open_global (struct outp_class *this unused) +{ + return 1; +} + +int +html_close_global (struct outp_class *this unused) +{ + return 1; +} + +int +html_preopen_driver (struct outp_driver *this) +{ + struct html_driver_ext *x; + + assert (this->driver_open == 0); + msg (VM (1), _("HTML driver initializing as `%s'..."), this->name); + + this->ext = x = xmalloc (sizeof *x); + this->res = 0; + this->horiz = this->vert = 0; + this->width = this->length = 0; + + this->cp_x = this->cp_y = 0; + + x->prologue_fn = NULL; + + x->file.filename = NULL; + x->file.mode = "w"; + x->file.file = NULL; + x->file.sequence_no = &x->sequence_no; + x->file.param = this; + x->file.postopen = postopen; + x->file.preclose = preclose; + + x->sequence_no = 0; + + return 1; +} + +int +html_postopen_driver (struct outp_driver *this) +{ + struct html_driver_ext *x = this->ext; + + assert (this->driver_open == 0); + if (NULL == x->file.filename) + x->file.filename = xstrdup ("pspp.html"); + + if (x->prologue_fn == NULL) + x->prologue_fn = xstrdup ("html-prologue"); + + msg (VM (2), _("%s: Initialization complete."), this->name); + this->driver_open = 1; + + return 1; +} + +int +html_close_driver (struct outp_driver *this) +{ + struct html_driver_ext *x = this->ext; + + assert (this->driver_open); + msg (VM (2), _("%s: Beginning closing..."), this->name); + fn_close_ext (&x->file); + free (x->prologue_fn); + free (x->file.filename); + free (x); + msg (VM (3), _("%s: Finished closing."), this->name); + this->driver_open = 0; + + return 1; +} + +/* Generic option types. */ +enum +{ + boolean_arg = -10, + string_arg, + nonneg_int_arg +}; + +/* All the options that the HTML driver supports. */ +static struct outp_option option_tab[] = +{ + /* *INDENT-OFF* */ + {"output-file", 1, 0}, + {"prologue-file", string_arg, 0}, + {"", 0, 0}, + /* *INDENT-ON* */ +}; +static struct outp_option_info option_info; + +void +html_option (struct outp_driver *this, const char *key, const struct string *val) +{ + struct html_driver_ext *x = this->ext; + int cat, subcat; + + cat = outp_match_keyword (key, option_tab, &option_info, &subcat); + switch (cat) + { + case 0: + msg (SE, _("Unknown configuration parameter `%s' for HTML device " + "driver."), key); + break; + case 1: + free (x->file.filename); + x->file.filename = xstrdup (ds_value (val)); + break; + case string_arg: + { + char **dest; + switch (subcat) + { + case 0: + dest = &x->prologue_fn; + break; + default: + assert (0); + } + if (*dest) + free (*dest); + *dest = xstrdup (ds_value (val)); + } + break; +#if __CHECKER__ + case 42000: + assert (0); +#endif + default: + assert (0); + } +} + +/* Variables for the prologue. */ +struct html_variable + { + const char *key; + const char *value; + }; + +static struct html_variable *html_var_tab; + +/* Searches html_var_tab for a html_variable with key KEY, and returns + the associated value. */ +static const char * +html_get_var (const char *key) +{ + struct html_variable *v; + + for (v = html_var_tab; v->key; v++) + if (!strcmp (key, v->key)) + return v->value; + return NULL; +} + +/* Writes the HTML prologue to file F. */ +static int +postopen (struct file_ext *f) +{ + static struct html_variable dict[] = + { + {"generator", 0}, + {"date", 0}, + {"user", 0}, + {"host", 0}, + {"title", 0}, + {"subtitle", 0}, + {"source-file", 0}, + {0, 0}, + }; +#if HAVE_UNISTD_H + char host[128]; +#endif + time_t curtime; + struct tm *loctime; + + struct outp_driver *this = f->param; + struct html_driver_ext *x = this->ext; + + char *prologue_fn = fn_search_path (x->prologue_fn, config_path, NULL); + FILE *prologue_file; + + char *buf = NULL; + int buf_size = 0; + + if (prologue_fn == NULL) + { + msg (IE, _("Cannot find HTML prologue. The use of `-vv' " + "on the command line is suggested as a debugging aid.")); + return 0; + } + + msg (VM (1), _("%s: %s: Opening HTML prologue..."), this->name, prologue_fn); + prologue_file = fopen (prologue_fn, "rb"); + if (prologue_file == NULL) + { + fclose (prologue_file); + free (prologue_fn); + msg (IE, "%s: %s", prologue_fn, strerror (errno)); + goto error; + } + + dict[0].value = version; + + curtime = time (NULL); + loctime = localtime (&curtime); + dict[1].value = asctime (loctime); + { + char *cp = strchr (dict[1].value, '\n'); + if (cp) + *cp = 0; + } + + /* PORTME: Determine username, net address. */ +#if HAVE_UNISTD_H + dict[2].value = getenv ("LOGNAME"); + if (!dict[2].value) + dict[2].value = getlogin (); + if (!dict[2].value) + dict[2].value = _("nobody"); + + if (gethostname (host, 128) == -1) + { + if (errno == ENAMETOOLONG) + host[127] = 0; + else + strcpy (host, _("nowhere")); + } + dict[3].value = host; +#else /* !HAVE_UNISTD_H */ + dict[2].value = _("nobody"); + dict[3].value = _("nowhere"); +#endif /* !HAVE_UNISTD_H */ + + dict[4].value = outp_title ? outp_title : ""; + dict[5].value = outp_subtitle ? outp_subtitle : ""; + + getl_location (&dict[6].value, NULL); + if (dict[6].value == NULL) + dict[6].value = ""; + + html_var_tab = dict; + while (-1 != getline (&buf, &buf_size, prologue_file)) + { + char *buf2; + int len; + + if (strstr (buf, "!!!")) + continue; + + { + char *cp = strstr (buf, "!title"); + if (cp) + { + if (outp_title == NULL) + continue; + else + *cp = '\0'; + } + } + + { + char *cp = strstr (buf, "!subtitle"); + if (cp) + { + if (outp_subtitle == NULL) + continue; + else + *cp = '\0'; + } + } + + /* PORTME: Line terminator. */ + buf2 = fn_interp_vars (buf, html_get_var); + len = strlen (buf2); + fwrite (buf2, len, 1, f->file); + if (buf2[len - 1] != '\n') + putc ('\n', f->file); + free (buf2); + } + if (ferror (f->file)) + msg (IE, _("Reading `%s': %s."), prologue_fn, strerror (errno)); + fclose (prologue_file); + + free (prologue_fn); + free (buf); + + if (ferror (f->file)) + goto error; + + msg (VM (2), _("%s: HTML prologue read successfully."), this->name); + return 1; + +error: + msg (VM (1), _("%s: Error reading HTML prologue."), this->name); + return 0; +} + +/* Writes the HTML epilogue to file F. */ +static int +preclose (struct file_ext *f) +{ + fprintf (f->file, + "\n" + "\n" + "\n"); + + if (ferror (f->file)) + return 0; + return 1; +} + +int +html_open_page (struct outp_driver *this) +{ + struct html_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open == 0); + x->sequence_no++; + if (!fn_open_ext (&x->file)) + { + if (errno) + msg (ME, _("HTML output driver: %s: %s"), x->file.filename, + strerror (errno)); + return 0; + } + + if (!ferror (x->file.file)) + this->page_open = 1; + return !ferror (x->file.file); +} + +int +html_close_page (struct outp_driver *this) +{ + struct html_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + this->page_open = 0; + return !ferror (x->file.file); +} + +static void output_tab_table (struct outp_driver *, struct tab_table *); + +void +html_submit (struct outp_driver *this, struct som_table *s) +{ + extern struct som_table_class tab_table_class; + struct html_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + if (x->sequence_no == 0 && !html_open_page (this)) + { + msg (ME, _("Cannot open first page on HTML device %s."), this->name); + return; + } + + if (s->class == &tab_table_class) + output_tab_table (this, (struct tab_table *) s->ext); + else + assert (0); +} + +/* Emit HTML to FILE to change from *OLD_ATTR attributes to NEW_ATTR. + Sets *OLD_ATTR to NEW_ATTR when done. */ +static void +change_attributes (FILE *f, int *old_attr, int new_attr) +{ + if (*old_attr == new_attr) + return; + + if (*old_attr & OUTP_F_B) + fputs ("", f); + if (*old_attr & OUTP_F_I) + fputs ("", f); + if (new_attr & OUTP_F_I) + fputs ("", f); + if (new_attr & OUTP_F_B) + fputs ("", f); + + *old_attr = new_attr; +} + +/* Write string S of length LEN to file F, escaping characters as + necessary for HTML. */ +static void +escape_string (FILE *f, char *s, int len) +{ + char *ep = &s[len]; + char *bp, *cp; + int attr = 0; + + for (bp = cp = s; bp < ep; bp = cp) + { + while (cp < ep && *cp != '&' && *cp != '<' && *cp != '>' && *cp) + cp++; + if (cp > bp) + fwrite (bp, 1, cp - bp, f); + if (cp < ep) + switch (*cp++) + { + case '&': + fputs ("&", f); + break; + case '<': + fputs ("<", f); + break; + case '>': + fputs (">", f); + break; + case 0: + break; + default: + assert (0); + } + } + + if (attr) + change_attributes (f, &attr, 0); +} + +/* Write table T to THIS output driver. */ +static void +output_tab_table (struct outp_driver *this, struct tab_table *t) +{ + struct html_driver_ext *x = this->ext; + + tab_hit++; + + if (t->nr == 1 && t->nc == 1) + { + fputs ("

", x->file.file); + if (!ls_empty_p (t->cc)) + escape_string (x->file.file, ls_value (t->cc), ls_length (t->cc)); + fputs ("

\n", x->file.file); + + return; + } + + fputs ("\n", x->file.file); + + if (!ls_empty_p (&t->title)) + { + fprintf (x->file.file, " \n \n \n", x->file.file); + } + + { + int r; + struct len_string *cc = t->cc; + unsigned char *ct = t->ct; + + for (r = 0; r < t->nr; r++) + { + int c; + + fputs (" \n", x->file.file); + for (c = 0; c < t->nc; c++, cc++, ct++) + { + int tag; + char header[128]; + char *cp; + + if ((*ct & TAB_JOIN) + && ((struct tab_joined_cell *) ls_value (cc))->hit == tab_hit) + continue; + + if (r < t->t || r >= t->nr - t->b + || c < t->l || c >= t->nc - t->r) + tag = 'H'; + else + tag = 'D'; + cp = stpcpy (header, " hit = tab_hit; + + if (j->x2 - j->x1 > 1) + cp = spprintf (cp, " COLSPAN=%d", j->x2 - j->x1); + if (j->y2 - j->y1 > 1) + cp = spprintf (cp, " ROWSPAN=%d", j->y2 - j->y1); + } + + strcpy (cp, ">"); + fputs (header, x->file.file); + + { + char *s = ls_value (cc); + size_t l = ls_length (cc); + + while (l && isspace ((unsigned char) *s)) + { + l--; + s++; + } + + escape_string (x->file.file, s, l); + } + + fprintf (x->file.file, "\n", tag); + } + fputs (" \n", x->file.file); + } + } + + fputs ("
", t->nc); + escape_string (x->file.file, ls_value (&t->title), + ls_length (&t->title)); + fputs ("
\n\n", x->file.file); +} + +/* HTML driver class. */ +struct outp_class html_class = +{ + "html", + 0xfaeb, + 1, + + html_open_global, + html_close_global, + NULL, + + html_preopen_driver, + html_option, + html_postopen_driver, + html_close_driver, + + html_open_page, + html_close_page, + + html_submit, + + NULL, + NULL, + NULL, + + NULL, + NULL, + NULL, + NULL, + + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, +}; + +#endif /* !NO_HTML */ + diff --git a/src/htmlP.h b/src/htmlP.h new file mode 100644 index 00000000..28416fda --- /dev/null +++ b/src/htmlP.h @@ -0,0 +1,38 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !htmlP_h +#define htmlP_h 1 + +#include "filename.h" + +/* HTML output driver extension record. */ +struct html_driver_ext + { + /* User parameters. */ + char *prologue_fn; /* Prologue's filename relative to font dir. */ + + /* Internal state. */ + struct file_ext file; /* Output file. */ + int sequence_no; /* Sequence number. */ + }; + +extern struct outp_class html_class; + +#endif /* !htmlP_h */ diff --git a/src/include.c b/src/include.c new file mode 100644 index 00000000..78557bdd --- /dev/null +++ b/src/include.c @@ -0,0 +1,76 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "getline.h" +#include "lexer.h" +#include "str.h" + +int +cmd_include_at (void) +{ + char *incfn, *s, *bp, *ep; + + s = bp = lex_entire_line (); + while (isspace ((unsigned char) *bp)) + bp++; + bp++; /* skip `@' */ + while (isspace ((unsigned char) *bp)) + bp++; + if (*bp == '\'') + bp++; + + ep = bp + strlen (bp); + while (isspace ((unsigned char) *--ep)); + if (*ep != '\'') + ep++; + + if (ep <= bp) + { + msg (SE, _("Unrecognized filename format.")); + return CMD_FAILURE; + } + + /* Now the filename is trapped between bp and ep. */ + incfn = xmalloc (ep - bp + 1); + strncpy (incfn, bp, ep - bp); + incfn[ep - bp] = 0; + getl_include (incfn); + free (incfn); + + return CMD_SUCCESS; +} + +int +cmd_include (void) +{ + lex_get (); + + if (!lex_force_string ()) + return CMD_SUCCESS; + getl_include (ds_value (&tokstr)); + + lex_get (); + return lex_end_of_command (); +} diff --git a/src/inpt-pgm.c b/src/inpt-pgm.c new file mode 100644 index 00000000..a4e9a180 --- /dev/null +++ b/src/inpt-pgm.c @@ -0,0 +1,465 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "dfm.h" +#include "error.h" +#include "expr.h" +#include "file-handle.h" +#include "inpt-pgm.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* A bit-vector of two-bit entries. The array tells INPUT PROGRAM how + to initialize each `value'. Modified by envector(), devector(), + which are called by create_variable(), also by LEAVE, COMPUTE(!). */ +unsigned char *inp_init; + +/* Number of bytes allocated for inp_init. */ +size_t inp_init_size; + +/* Number of `values' created inside INPUT PROGRAM. */ +static int inp_nval; + +static int end_case_trns_proc (struct trns_header *, struct ccase *); +static int end_file_trns_proc (struct trns_header * t, struct ccase * c); +static int reread_trns_proc (struct trns_header *, struct ccase *); +static void reread_trns_free (struct trns_header *); + +int +cmd_input_program (void) +{ + lex_match_id ("INPUT"); + lex_match_id ("PROGRAM"); + discard_variables (); + + vfm_source = &input_program_source; + + inp_init = NULL; + inp_init_size = 0; + + return lex_end_of_command (); +} + +int +cmd_end_input_program (void) +{ + lex_match_id ("END"); + lex_match_id ("INPUT"); + lex_match_id ("PROGRAM"); + + if (vfm_source != &input_program_source) + { + msg (SE, _("No matching INPUT PROGRAM command.")); + return CMD_FAILURE; + } + + if (default_dict.nval == 0) + msg (SW, _("No data-input or transformation commands specified " + "between INPUT PROGRAM and END INPUT PROGRAM.")); + + /* Mark the boundary between INPUT PROGRAM and more-mundane + transformations. */ + f_trns = n_trns; + + /* Mark the boundary between input program `values' and + later-created `values'. */ + inp_nval = default_dict.nval; + + return lex_end_of_command (); +} + +/* Initializes temp_case. Called before the first case is read. */ +static void +init_case (void) +{ + union value *val = temp_case->data; + unsigned char *cp = inp_init; + unsigned char c; + int i, j; + + /* This code is 2-3X the complexity it might be, but I felt like + it. It initializes temp_case union values to 0, or SYSMIS, or + blanks, as appropriate. */ + for (i = 0; i < inp_nval / 4; i++) + { + c = *cp++; + for (j = 0; j < 4; j++) + { + switch (c & INP_MASK) + { + case INP_NUMERIC | INP_RIGHT: + val++->f = SYSMIS; + break; + case INP_NUMERIC | INP_LEFT: + val++->f = 0.0; + break; + case INP_STRING | INP_RIGHT: + case INP_STRING | INP_LEFT: + memset (val++->s, ' ', MAX_SHORT_STRING); + break; + } + c >>= 2; + } + } + if (inp_nval % 4) + { + c = *cp; + for (j = 0; j < inp_nval % 4; j++) + { + switch (c & INP_MASK) + { + case INP_NUMERIC | INP_RIGHT: + val++->f = SYSMIS; + break; + case INP_NUMERIC | INP_LEFT: + val++->f = 0.0; + break; + case INP_STRING | INP_RIGHT: + case INP_STRING | INP_LEFT: + memset (val++->s, ' ', MAX_SHORT_STRING); + break; + } + c >>= 2; + } + } +} + +/* Clears temp_case. Called between reading successive records. */ +static void +clear_case (void) +{ + union value *val = temp_case->data; + unsigned char *cp = inp_init; + unsigned char c; + int i, j; + + /* This code is 2-3X the complexity it might be, but I felt like + it. It initializes temp_case values to SYSMIS, or + blanks, or does nothing, as appropriate. */ + for (i = 0; i < inp_nval / 4; i++) + { + c = *cp++; + for (j = 0; j < 4; j++) + { + if (!(c & INP_LEFT)) + { + if (c & INP_STRING) + memset (val->s, ' ', MAX_SHORT_STRING); + else + val->f = SYSMIS; + } + val++; + c >>= 2; + } + } + + if (inp_nval % 4) + { + c = *cp; + for (j = 0; j < inp_nval % 4; j++) + { + if (!(c & INP_LEFT)) + { + if (c & INP_STRING) + memset (val->s, ' ', MAX_SHORT_STRING); + else + val->f = SYSMIS; + } + val++; + c >>= 2; + } + } +} + +/* Executes each transformation in turn on a `blank' case. When a + transformation fails, returning -2, then that's the end of the + file. -1 means go on to the next transformation. Otherwise the + return value is the index of the transformation to go to next. */ +void +input_program_source_read (void) +{ + int i; + + /* Nonzero if there were any END CASE commands in the set of + transformations. */ + int end_case = 0; + + /* We don't automatically write out cases if the user took over + that prerogative. */ + for (i = 0; i < f_trns; i++) + if (t_trns[i]->proc == end_case_trns_proc) + end_case = 1; + + init_case (); + for (;;) + { + /* Index of current transformation. */ + int i; + + /* Return value of last-called transformation. */ + int code; + + debug_printf (("input-program: ")); + + /* Perform transformations on `blank' case. */ + for (i = 0; i < f_trns;) + { +#if DEBUGGING + printf ("/%d", i); + if (t_trns[i]->proc == end_case_trns_proc) + printf ("\n"); +#endif + code = t_trns[i]->proc (t_trns[i], temp_case); + switch (code) + { + case -1: + i++; + break; + case -2: + return; + case -3: + goto next_case; + default: + i = code; + break; + } + } + +#if DEBUGGING + if (!end_case) + printf ("\n"); +#endif + + /* Write the case if appropriate. */ + if (!end_case) + if (!write_case ()) + return; + + /* Blank out the case for the next iteration. */ + next_case: + clear_case (); + } +} + +static void +input_program_source_destroy_source (void) +{ + cancel_transformations (); + free (inp_init); + inp_init = NULL; +} + +struct case_stream input_program_source = + { + NULL, + input_program_source_read, + NULL, + NULL, + input_program_source_destroy_source, + NULL, + "INPUT PROGRAM", + }; + +int +cmd_end_case (void) +{ + struct trns_header *t; + + lex_match_id ("END"); + lex_match_id ("CASE"); + + if (vfm_source != &input_program_source) + { + msg (SE, _("This command may only be executed between INPUT PROGRAM " + "and END INPUT PROGRAM.")); + return CMD_FAILURE; + } + + t = xmalloc (sizeof *t); + t->proc = end_case_trns_proc; + t->free = NULL; + add_transformation ((struct trns_header *) t); + + return lex_end_of_command (); +} + +int +end_case_trns_proc (struct trns_header *t unused, struct ccase * c unused) +{ +#if DEBUGGING + printf ("END CASE\n"); +#endif + if (!write_case ()) + return -2; + clear_case (); + return -1; +} + +/* REREAD transformation. */ +struct reread_trns + { + struct trns_header h; + + struct file_handle *handle; /* File to move file pointer back on. */ + struct expression *column; /* Column to reset file pointer to. */ + }; + +/* Parses REREAD command. */ +int +cmd_reread (void) +{ + /* File to be re-read. */ + struct file_handle *h; + + /* Expression for column to set file pointer to. */ + struct expression *e; + + /* Created transformation. */ + struct reread_trns *t; + + lex_match_id ("REREAD"); + + h = default_handle; + e = NULL; + while (token != '.') + { + if (lex_match_id ("COLUMN")) + { + lex_match ('='); + + if (e) + { + msg (SE, _("COLUMN subcommand multiply specified.")); + expr_free (e); + return CMD_FAILURE; + } + + e = expr_parse (PXP_NUMERIC); + if (!e) + return CMD_FAILURE; + } + else if (lex_match_id ("FILE")) + { + lex_match ('='); + if (token != T_ID) + { + lex_error (_("expecting file handle name")); + expr_free (e); + return CMD_FAILURE; + } + h = fh_get_handle_by_name (tokid); + if (!h) + { + expr_free (e); + return CMD_FAILURE; + } + lex_get (); + } + else + { + lex_error (NULL); + expr_free (e); + } + } + + t = xmalloc (sizeof *t); + t->h.proc = reread_trns_proc; + t->h.free = reread_trns_free; + t->handle = h; + t->column = e; + add_transformation ((struct trns_header *) t); + + return CMD_SUCCESS; +} + +static int +reread_trns_proc (struct trns_header * pt, struct ccase * c) +{ + struct reread_trns *t = (struct reread_trns *) pt; + + if (t->column == NULL) + dfm_bkwd_record (t->handle, 1); + else + { + union value column; + + expr_evaluate (t->column, c, &column); + if (!finite (column.f) || column.f < 1) + { + msg (SE, _("REREAD: Column numbers must be positive finite " + "numbers. Column set to 1.")); + dfm_bkwd_record (t->handle, 1); + } + else + dfm_bkwd_record (t->handle, column.f); + } + return -1; +} + +static void +reread_trns_free (struct trns_header * t) +{ + expr_free (((struct reread_trns *) t)->column); +} + +/* Parses END FILE command. */ +int +cmd_end_file (void) +{ + struct trns_header *t; + + lex_match_id ("END"); + lex_match_id ("FILE"); + + if (vfm_source != &input_program_source) + { + msg (SE, _("This command may only be executed between INPUT PROGRAM " + "and END INPUT PROGRAM.")); + return CMD_FAILURE; + } + + t = xmalloc (sizeof *t); + t->proc = end_file_trns_proc; + t->free = NULL; + add_transformation ((struct trns_header *) t); + + return lex_end_of_command (); +} + +static int +end_file_trns_proc (struct trns_header * t unused, struct ccase * c unused) +{ +#if DEBUGGING + printf ("END FILE\n"); +#endif + return -2; +} diff --git a/src/inpt-pgm.h b/src/inpt-pgm.h new file mode 100644 index 00000000..c46fe7ad --- /dev/null +++ b/src/inpt-pgm.h @@ -0,0 +1,38 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !inpt_pgm_h +#define inpt_pgm_h 1 + +/* Bitmasks to indicate variable type. */ +enum + { + INP_MASK = 03, /* 2#11. */ + + INP_NUMERIC = 0, /* Numeric. */ + INP_STRING = 01, /* String. */ + + INP_RIGHT = 0, /* Ordinary. */ + INP_LEFT = 02 /* Scratch or LEAVE. */ + }; + +extern unsigned char *inp_init; +extern size_t inp_init_size; + +#endif /* !inpt_pgm_h */ diff --git a/src/lexer.c b/src/lexer.c new file mode 100644 index 00000000..6bcb46eb --- /dev/null +++ b/src/lexer.c @@ -0,0 +1,1195 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "getline.h" +#include "lexer.h" +#include "magic.h" +#include "settings.h" +#include "str.h" + +/*#define DUMP_TOKENS 1*/ + + +/* Global variables. */ + +/* Current token. */ +int token; + +/* T_NUM: the token's value. */ +double tokval; + +/* T_ID: the identifier. */ +char tokid[9]; + +/* T_ID, T_STRING: token string value. + For T_ID, this is not truncated to 8 characters as is tokid. */ +struct string tokstr; + +/* Static variables. */ + +/* Table of keywords. */ +static const char *keywords[T_N_KEYWORDS + 1] = + { + "AND", "OR", "NOT", + "EQ", "GE", "GT", "LE", "LT", "NE", + "ALL", "BY", "TO", "WITH", + NULL, + }; + +/* Pointer to next token in getl_buf. */ +static char *prog; + +/* Nonzero only if this line ends with a terminal dot. */ +static int dot; + +/* Nonzero only if the last token returned was T_EOF. */ +static int eof; + +/* If nonzero, next token returned by lex_get(). + Used only in exceptional circumstances. */ +static int put; + +static void unexpected_eof (void); +static inline int check_id (const char *id, size_t len); +static void convert_numeric_string_to_char_string (int type); +static int parse_string (int type); + +#if DUMP_TOKENS +static void dump_token (void); +#endif + +/* Initialization. */ + +/* Initializes the lexer. */ +void +lex_init (void) +{ + if (!lex_get_line ()) + unexpected_eof (); +} + +/* Common functions. */ + +/* Parses a single token, setting appropriate global variables to + indicate the token's attributes. */ +void +lex_get (void) +{ + /* If a token was pushed ahead, return it. */ + if (put) + { + token = put; + put = 0; +#if DUMP_TOKENS + dump_token (); +#endif + return; + } + + /* Find a token. */ + for (;;) + { + char *cp; + + /* Skip whitespace. */ + if (eof) + unexpected_eof (); + + for (;;) + { + while (isspace ((unsigned char) *prog)) + prog++; + if (*prog) + break; + + if (dot) + { + dot = 0; + token = '.'; +#if DUMP_TOKENS + dump_token (); +#endif + return; + } + else if (!lex_get_line ()) + { + eof = 1; + token = T_STOP; +#if DUMP_TOKENS + dump_token (); +#endif + return; + } + + if (put) + { + token = put; + put = 0; +#if DUMP_TOKENS + dump_token (); +#endif + return; + } + } + + /* Actually parse the token. */ + cp = prog; + ds_clear (&tokstr); + + switch (*prog) + { + case '-': case '.': + case '0': case '1': case '2': case '3': case '4': + case '5': case '6': case '7': case '8': case '9': + { + char *tail; + + /* `-' can introduce a negative number, or it can be a + token by itself. If it is not followed by a digit or a + decimal point, it is definitely not a number. + Otherwise, it might be either, but most of the time we + want it as a number. When the syntax calls for a `-' + token, lex_negative_to_dash() must be used to break + negative numbers into two tokens. */ + if (*cp == '-') + { + ds_putchar (&tokstr, *prog++); + while (isspace ((unsigned char) *prog)) + prog++; + + if (!isdigit ((unsigned char) *prog) && *prog != '.') + { + token = '-'; + break; + } + } + + /* Parse the number, copying it into tokstr. */ + while (isdigit ((unsigned char) *prog)) + ds_putchar (&tokstr, *prog++); + if (*prog == '.') + { + ds_putchar (&tokstr, *prog++); + while (isdigit ((unsigned char) *prog)) + ds_putchar (&tokstr, *prog++); + } + if (*prog == 'e' || *prog == 'E') + { + ds_putchar (&tokstr, *prog++); + if (*prog == '+' || *prog == '-') + ds_putchar (&tokstr, *prog++); + while (isdigit ((unsigned char) *prog)) + ds_putchar (&tokstr, *prog++); + } + + /* Parse as floating point. */ + tokval = strtod (ds_value (&tokstr), &tail); + if (*tail) + { + msg (SE, _("%s does not form a valid number."), + ds_value (&tokstr)); + tokval = 0.0; + + ds_clear (&tokstr); + ds_putchar (&tokstr, '0'); + } + + token = T_NUM; + break; + } + + case '\'': case '"': + token = parse_string (0); + break; + + case '(': case ')': case ',': case '=': case '+': case '/': + token = *prog++; + break; + + case '*': + if (*++prog == '*') + { + prog++; + token = T_EXP; + } + else + token = '*'; + break; + + case '<': + if (*++prog == '=') + { + prog++; + token = T_LE; + } + else if (*prog == '>') + { + prog++; + token = T_NE; + } + else + token = T_LT; + break; + + case '>': + if (*++prog == '=') + { + prog++; + token = T_GE; + } + else + token = T_GT; + break; + + case '~': + if (*++prog == '=') + { + prog++; + token = T_NE; + } + else + token = T_NOT; + break; + + case '&': + prog++; + token = T_AND; + break; + + case '|': + prog++; + token = T_OR; + break; + + case 'a': case 'b': case 'c': case 'd': case 'e': + case 'f': case 'g': case 'h': case 'i': case 'j': + case 'k': case 'l': case 'm': case 'n': case 'o': + case 'p': case 'q': case 'r': case 's': case 't': + case 'u': case 'v': case 'w': case 'x': case 'y': + case 'z': + case 'A': case 'B': case 'C': case 'D': case 'E': + case 'F': case 'G': case 'H': case 'I': case 'J': + case 'K': case 'L': case 'M': case 'N': case 'O': + case 'P': case 'Q': case 'R': case 'S': case 'T': + case 'U': case 'V': case 'W': case 'X': case 'Y': + case 'Z': + case '#': case '$': case '@': + /* Strings can be specified in binary, octal, or hex using + this special syntax. */ + if (prog[1] == '\'' || prog[1] == '"') + { + static const char special[3] = "box"; + const char *p; + + p = strchr (special, tolower ((unsigned char) *prog)); + if (p) + { + prog++; + token = parse_string (p - special + 1); + break; + } + } + + /* Copy id to tokstr. */ + ds_putchar (&tokstr, toupper ((unsigned char) *prog++)); + while (CHAR_IS_IDN (*prog)) + ds_putchar (&tokstr, toupper ((unsigned char) *prog++)); + + /* Copy tokstr to tokid, truncating it to 8 characters. */ + strncpy (tokid, ds_value (&tokstr), 8); + tokid[8] = 0; + + token = check_id (ds_value (&tokstr), ds_length (&tokstr)); + break; + + default: + if (isgraph ((unsigned char) *prog)) + msg (SE, _("Bad character in input: `%c'."), *prog++); + else + msg (SE, _("Bad character in input: `\\%o'."), *prog++); + continue; + } + + break; + } + +#if DUMP_TOKENS + dump_token (); +#endif +} + +/* Prints a syntax error message containing the current token and + given message MESSAGE (if non-null). */ +void +lex_error (const char *message, ...) +{ + char *token_rep; + + token_rep = lex_token_representation (); + if (token_rep[0] == 0) + msg (SE, _("Syntax error at end of file.")); + else if (message) + { + char buf[1024]; + va_list args; + + va_start (args, message); + vsnprintf (buf, 1024, message, args); + va_end (args); + + msg (SE, _("Syntax error %s at `%s'."), buf, token_rep); + } + else + msg (SE, _("Syntax error at `%s'."), token_rep); + + free (token_rep); +} + +/* Checks that we're at end of command. + If so, returns a successful command completion code. + If not, flags a syntax error and returns an error command + completion code. */ +int +lex_end_of_command (void) +{ + if (token != '.') + { + lex_error (_("expecting end of command")); + return CMD_TRAILING_GARBAGE; + } + else + return CMD_SUCCESS; +} + +/* Token testing functions. */ + +/* Returns nonzero if the current token is an integer. */ +int +lex_integer_p (void) +{ + return (token == T_NUM + && tokval != NOT_LONG + && tokval >= LONG_MIN + && tokval <= LONG_MAX + && floor (tokval) == tokval); +} + +/* Returns the value of the current token, which must be an + integer. */ +long +lex_integer (void) +{ + assert (lex_integer_p ()); + return tokval; +} + +/* Token matching functions. */ + +/* If TOK is the current token, skips it and returns nonzero. + Otherwise, returns zero. */ +int +lex_match (int t) +{ + if (token == t) + { + lex_get (); + return 1; + } + else + return 0; +} + +/* If the current token is the identifier S, skips it and returns + nonzero. + Otherwise, returns zero. */ +int +lex_match_id (const char *s) +{ + if (token == T_ID && lex_id_match (s, tokid)) + { + lex_get (); + return 1; + } + else + return 0; +} + +/* If the current token is integer N, skips it and returns nonzero. + Otherwise, returns zero. */ +int +lex_match_int (int x) +{ + if (lex_integer_p () && lex_integer () == x) + { + lex_get (); + return 1; + } + else + return 0; +} + +/* Forced matches. */ + +/* If this token is identifier S, fetches the next token and returns + nonzero. + Otherwise, reports an error and returns zero. */ +int +lex_force_match_id (const char *s) +{ + if (token == T_ID && lex_id_match (s, tokid)) + { + lex_get (); + return 1; + } + else + { + lex_error (_("expecting `%s'"), s); + return 0; + } +} + +/* If the current token is T, skips the token. Otherwise, reports an + error and returns from the current function with return value 0. */ +int +lex_force_match (int t) +{ + if (token == t) + { + lex_get (); + return 1; + } + else + { + lex_error (_("expecting %s"), lex_token_name (t)); + return 0; + } +} + +/* If this token is a string, does nothing and returns nonzero. + Otherwise, reports an error and returns zero. */ +int +lex_force_string (void) +{ + if (token == T_STRING) + return 1; + else + { + lex_error (_("expecting string")); + return 0; + } +} + +/* If this token is an integer, does nothing and returns nonzero. + Otherwise, reports an error and returns zero. */ +int +lex_force_int (void) +{ + if (lex_integer_p ()) + return 1; + else + { + lex_error (_("expecting integer")); + return 0; + } +} + +/* If this token is a number, does nothing and returns nonzero. + Otherwise, reports an error and returns zero. */ +int +lex_force_num (void) +{ + if (token == T_NUM) + return 1; + else + { + lex_error (_("expecting number")); + return 0; + } +} + +/* If this token is an identifier, does nothing and returns nonzero. + Otherwise, reports an error and returns zero. */ +int +lex_force_id (void) +{ + if (token == T_ID) + return 1; + else + { + lex_error (_("expecting identifier")); + return 0; + } +} + +/* Comparing identifiers. */ + +/* Keywords match if one of the following is true: KW and TOK are + identical (barring differences in case), or TOK is at least 3 + characters long and those characters are identical to KW. KW_LEN + is the length of KW, TOK_LEN is the length of TOK. */ +int +lex_id_match_len (const char *kw, size_t kw_len, + const char *tok, size_t tok_len) +{ + size_t i = 0; + + assert (kw && tok); + for (;;) + { + if (i == kw_len && i == tok_len) + return 1; + else if (i == tok_len) + return i >= 3; + else if (i == kw_len) + return 0; + else if (toupper ((unsigned char) kw[i]) + != toupper ((unsigned char) tok[i])) + return 0; + + i++; + } +} + +/* Same as lex_id_match_len() minus the need to pass in the lengths. */ +int +lex_id_match (const char *kw, const char *tok) +{ + return lex_id_match_len (kw, strlen (kw), tok, strlen (tok)); +} + +/* Weird token functions. */ + +/* Returns the first character of the next token, except that if the + next token is not an identifier, the character returned will not be + a character that can begin an identifier. Specifically, the + hexstring lead-in X' causes lookahead() to return '. Note that an + alphanumeric return value doesn't guarantee an ID token, it could + also be a reserved-word token. */ +int +lex_look_ahead (void) +{ + if (put) + return put; + + for (;;) + { + if (eof) + unexpected_eof (); + + for (;;) + { + while (isspace ((unsigned char) *prog)) + prog++; + if (*prog) + break; + + if (dot) + return '.'; + else if (!lex_get_line ()) + unexpected_eof (); + + if (put) + return put; + } + + if ((toupper ((unsigned char) *prog) == 'X' + || toupper ((unsigned char) *prog) == 'B') + && (prog[1] == '\'' || prog[1] == '"')) + return '\''; + + return *prog; + } +} + +/* Makes the current token become the next token to be read; the + current token is set to T. */ +void +lex_put_back (int t) +{ + put = token; + token = t; +} + +/* Makes T the next token read. */ +void +lex_put_forward (int t) +{ + put = t; +} + +/* Weird line processing functions. */ + +/* Discards the rest of the current input line for tokenization + purposes, but returns the entire contents of the line for use by + the caller. */ +char * +lex_entire_line (void) +{ + prog = ds_end (&getl_buf); + dot = 0; + return ds_value (&getl_buf); +} + +/* As lex_entire_line(), but only returns the part of the current line + that hasn't already been tokenized. + If HAD_DOT is non-null, stores nonzero into *HAD_DOT if the line + ends with a terminal dot, or zero if it doesn't. */ +char * +lex_rest_of_line (int *had_dot) +{ + char *s = prog; + prog = ds_end (&getl_buf); + + if (had_dot) + *had_dot = dot; + dot = 0; + + return s; +} + +/* Causes the rest of the current input line to be ignored for + tokenization purposes. */ +void +lex_discard_line (void) +{ + msg (SW, _("The rest of this command has been discarded.")); + + ds_clear (&getl_buf); + prog = ds_value (&getl_buf); + dot = put = 0; +} + +/* Sets the current position in the current line to P, which must be + in getl_buf. */ +void +lex_set_prog (char *p) +{ + prog = p; +} + +/* Weird line reading functions. */ + +/* Read a line for use by the tokenizer. */ +int +lex_get_line (void) +{ + if (!getl_read_line ()) + return 0; + + lex_preprocess_line (); + return 1; +} + +/* Preprocesses getl_buf by removing comments, stripping trailing + whitespace and the terminal dot, and removing leading indentors. */ +void +lex_preprocess_line (void) +{ + /* Strips comments. */ + { + /* getl_buf iterator. */ + char *cp; + + /* Nonzero inside a comment. */ + int comment; + + /* Nonzero inside a quoted string. */ + int quote; + + /* Remove C-style comments begun by slash-star and terminated by + star-slash or newline. */ + quote = comment = 0; + for (cp = ds_value (&getl_buf); *cp; ) + { + /* If we're not commented out, toggle quoting. */ + if (!comment) + { + if (*cp == quote) + quote = 0; + else if (*cp == '\'' || *cp == '"') + quote = *cp; + } + + /* If we're not quoting, toggle commenting. */ + if (!quote) + { + if (cp[0] == '/' && cp[1] == '*') + { + comment = 1; + *cp++ = ' '; + *cp++ = ' '; + continue; + } + else if (cp[0] == '*' && cp[1] == '/' && comment) + { + comment = 0; + *cp++ = ' '; + *cp++ = ' '; + continue; + } + } + + /* Check commenting. */ + if (!comment) + cp++; + else + *cp++ = ' '; + } + } + + /* Strip trailing whitespace and terminal dot. */ + { + size_t len = ds_length (&getl_buf); + char *s = ds_value (&getl_buf); + + /* Strip trailing whitespace. */ + while (len > 0 && isspace ((unsigned char) s[len - 1])) + len--; + + /* Check for and remove terminal dot. */ + if (len > 0 && s[len - 1] == set_endcmd) + { + dot = 1; + len--; + } + else if (len == 0 && set_nullline) + dot = 1; + else + dot = 0; + + /* Set length. */ + ds_truncate (&getl_buf, len); + } + + /* In batch mode, strip leading indentors and insert a terminal dot + as necessary. */ + if (getl_interactive != 2 && getl_mode == GETL_MODE_BATCH) + { + char *s = ds_value (&getl_buf); + + if (s[0] == '+' || s[0] == '-' || s[0] == '.') + s[0] = ' '; + else if (s[0] && !isspace ((unsigned char) s[0])) + lex_put_forward ('.'); + } + + prog = ds_value (&getl_buf); +} + +/* Token names. */ + +/* Returns the name of a token in a static buffer. */ +const char * +lex_token_name (int token) +{ + if (token >= T_FIRST_KEYWORD && token <= T_LAST_KEYWORD) + return keywords[token - T_FIRST_KEYWORD]; + + if (token < 256) + { + static char t[2]; + t[0] = token; + return t; + } + + return _(""); +} + +/* Returns an ASCII representation of the current token as a + malloc()'d string. */ +char * +lex_token_representation (void) +{ + char *token_rep; + + switch (token) + { + case T_ID: + case T_NUM: + return xstrdup (ds_value (&tokstr)); + break; + + case T_STRING: + { + int hexstring = 0; + char *sp, *dp; + + for (sp = ds_value (&tokstr); sp < ds_end (&tokstr); sp++) + if (!isprint ((unsigned char) *sp)) + { + hexstring = 1; + break; + } + + token_rep = xmalloc (2 + ds_length (&tokstr) * 2 + 1 + 1); + + dp = token_rep; + if (hexstring) + *dp++ = 'X'; + *dp++ = '\''; + + if (!hexstring) + for (sp = ds_value (&tokstr); *sp; ) + { + if (*sp == '\'') + *dp++ = '\''; + *dp++ = (unsigned char) *sp++; + } + else + for (sp = ds_value (&tokstr); sp < ds_end (&tokstr); sp++) + { + *dp++ = (((unsigned char) *sp) >> 4)["0123456789ABCDEF"]; + *dp++ = (((unsigned char) *sp) & 15)["0123456789ABCDEF"]; + } + *dp++ = '\''; + *dp = '\0'; + + return token_rep; + } + break; + + case T_STOP: + token_rep = xmalloc (1); + *token_rep = '\0'; + return token_rep; + + case T_EXP: + return xstrdup ("**"); + + default: + if (token >= T_FIRST_KEYWORD && token <= T_LAST_KEYWORD) + return xstrdup (keywords [token - T_FIRST_KEYWORD]); + else + { + token_rep = xmalloc (2); + token_rep[0] = token; + token_rep[1] = '\0'; + return token_rep; + } + } + + assert (0); +} + +/* Really weird functions. */ + +/* Most of the time, a `-' is a lead-in to a negative number. But + sometimes it's actually part of the syntax. If a dash can be part + of syntax then this function is called to rip it off of a + number. */ +void +lex_negative_to_dash (void) +{ + if (token == T_NUM && tokval < 0.0) + { + token = '-'; + tokval = -tokval; + ds_replace (&tokstr, ds_value (&tokstr) + 1); + lex_put_forward (T_NUM); + } +} + +/* We're not at eof any more. */ +void +lex_reset_eof (void) +{ + eof = 0; +} + +/* Skip a COMMENT command. */ +void +lex_skip_comment (void) +{ + for (;;) + { + lex_get_line (); + if (put == '.') + break; + + prog = ds_end (&getl_buf); + if (dot) + break; + } +} + +/* Private functions. */ + +/* Unexpected end of file. */ +static void +unexpected_eof (void) +{ + msg (FE, _("Unexpected end of file.")); +} + +/* Returns the proper token type, either T_ID or a reserved keyword + enum, for ID[], which must contain LEN characters. */ +static inline int +check_id (const char *id, size_t len) +{ + const char **kwp; + + if (len < 2 || len > 4) + return T_ID; + + for (kwp = keywords; *kwp; kwp++) + if (!strcmp (*kwp, id)) + return T_FIRST_KEYWORD + (kwp - keywords); + + return T_ID; +} + +/* When invoked, tokstr contains a string of binary, octal, or hex + digits, for values of TYPE of 0, 1, or 2, respectively. The string + is converted to characters having the specified values. */ +static void +convert_numeric_string_to_char_string (int type) +{ + static const char *base_names[] = {N_("binary"), N_("octal"), N_("hex")}; + static const int bases[] = {2, 8, 16}; + static const int chars_per_byte[] = {8, 3, 2}; + + const char *const base_name = base_names[type]; + const int base = bases[type]; + const int cpb = chars_per_byte[type]; + const int nb = ds_length (&tokstr) / cpb; + int i; + char *p; + + assert (type >= 0 && type <= 2); + + if (ds_length (&tokstr) % cpb) + msg (SE, _("String of %s digits has %d characters, which is not a " + "multiple of %d."), + gettext (base_name), ds_length (&tokstr), cpb); + + p = ds_value (&tokstr); + for (i = 0; i < nb; i++) + { + int value; + int j; + + value = 0; + for (j = 0; j < cpb; j++, p++) + { + int v; + + if (*p >= '0' && *p <= '9') + v = *p - '0'; + else + { + static const char alpha[] = "abcdef"; + const char *q = strchr (alpha, tolower ((unsigned char) *p)); + + if (q) + v = q - alpha + 10; + else + v = base; + } + + if (v >= base) + msg (SE, _("`%c' is not a valid %s digit."), *p, base_name); + + value = value * base + v; + } + + ds_value (&tokstr)[i] = (unsigned char) value; + } + + ds_truncate (&tokstr, nb); +} + +/* Parses a string from the input buffer into tokstr. The input + buffer pointer prog must point to the initial single or double + quote. TYPE is 0 if it is an ordinary string, or 1, 2, or 3 for a + binary, octal, or hexstring, respectively. Returns token type. */ +static int +parse_string (int type) +{ + /* Accumulate the entire string, joining sections indicated by + + signs. */ + for (;;) + { + /* Single or double quote. */ + int c = *prog++; + + /* Accumulate section. */ + for (;;) + { + /* Check end of line. */ + if (*prog == 0) + { + msg (SE, _("Unterminated string constant.")); + goto finish; + } + + /* Double quote characters to embed them in strings. */ + if (*prog == c) + { + if (prog[1] == c) + prog++; + else + break; + } + + ds_putchar (&tokstr, *prog++); + } + prog++; + + /* Skip whitespace after final quote mark. */ + if (eof) + break; + for (;;) + { + while (isspace ((unsigned char) *prog)) + prog++; + if (*prog) + break; + + if (dot) + goto finish; + + if (!lex_get_line ()) + unexpected_eof (); + } + + /* Skip plus sign. */ + if (*prog != '+') + break; + prog++; + + /* Skip whitespace after plus sign. */ + if (eof) + break; + for (;;) + { + while (isspace ((unsigned char) *prog)) + prog++; + if (*prog) + break; + + if (dot) + goto finish; + + if (!lex_get_line ()) + unexpected_eof (); + } + + /* Ensure that a valid string follows. */ + if (*prog != '\'' && *prog != '"') + { + msg (SE, "String expected following `+'."); + goto finish; + } + } + + /* We come here when we've finished concatenating all the string sections + into one large string. */ +finish: + if (type != 0) + convert_numeric_string_to_char_string (type - 1); + + if (ds_length (&tokstr) > 255) + { + msg (SE, _("String exceeds 255 characters in length (%d characters)."), + ds_length (&tokstr)); + ds_truncate (&tokstr, 255); + } + + { + /* FIXME. */ + size_t i; + int warned = 0; + + for (i = 0; i < ds_length (&tokstr); i++) + if (ds_value (&tokstr)[i] == 0) + { + if (!warned) + { + msg (SE, _("Sorry, literal strings may not contain null " + "characters. Replacing with spaces.")); + warned = 1; + } + ds_value (&tokstr)[i] = ' '; + } + } + + return T_STRING; +} + +#if DUMP_TOKENS +/* Reads one token from the lexer and writes a textual representation + on stdout for debugging purposes. */ +static void +dump_token (void) +{ + { + const char *curfn; + int curln; + + getl_location (&curfn, &curln); + if (curfn) + printf ("%s:%d\t", curfn, curln); + } + + switch (token) + { + case T_ID: + printf ("ID\t%s\n", tokid); + break; + + case T_NUM: + printf ("NUM\t%f\n", tokval); + break; + + case T_STRING: + printf ("STRING\t\"%s\"\n", ds_value (&tokstr)); + break; + + case T_STOP: + printf ("STOP\n"); + break; + + case T_EXP: + puts ("MISC\tEXP"); + break; + + case 0: + puts ("MISC\tEOF"); + break; + + default: + if (token >= T_FIRST_KEYWORD && token <= T_LAST_KEYWORD) + printf ("KEYWORD\t%s\n", lex_token_name (token)); + else + printf ("PUNCT\t%c\n", token); + break; + } +} +#endif /* DEBUGGING */ diff --git a/src/lexer.h b/src/lexer.h new file mode 100644 index 00000000..542721b9 --- /dev/null +++ b/src/lexer.h @@ -0,0 +1,133 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !lexer_h +#define lexer_h 1 + +/* Returns nonzero if character CH may be the first character in an + identifier. */ +#define CHAR_IS_ID1(CH) \ + (isalpha ((unsigned char) (CH)) \ + || (CH) == '@' \ + || (CH) == '#' \ + || (CH) == '$') + +/* Returns nonzero if character CH may be a character in an + identifier other than the first. */ +#define CHAR_IS_IDN(CH) \ + (CHAR_IS_ID1 (CH) \ + || isdigit ((unsigned char) (CH)) \ + || (CH) == '.' \ + || (CH) == '_') + +/* Token types. */ +/* The order of the enumerals below is important. Do not change it. */ +enum + { + T_ID = 256, /* Identifier. */ + T_NUM, /* Number. */ + T_STRING, /* Quoted string. */ + T_STOP, /* End of input. */ + + T_AND, /* AND */ + T_OR, /* OR */ + T_NOT, /* NOT */ + + T_EQ, /* EQ */ + T_GE, /* GE or >= */ + T_GT, /* GT or > */ + T_LE, /* LE or <= */ + T_LT, /* LT or < */ + T_NE, /* NE or ~= */ + + T_ALL, /* ALL */ + T_BY, /* BY */ + T_TO, /* TO */ + T_WITH, /* WITH */ + + T_EXP, /* ** */ + + T_FIRST_KEYWORD = T_AND, + T_LAST_KEYWORD = T_WITH, + T_N_KEYWORDS = T_LAST_KEYWORD - T_FIRST_KEYWORD + 1, + }; + + +extern int token; +extern double tokval; +extern char tokid[9]; +extern struct string tokstr; + +#include + +/* Initialization. */ +void lex_init (void); + +/* Common functions. */ +void lex_get (void); +void lex_error (const char *, ...); +int lex_end_of_command (void); + +/* Token testing functions. */ +int lex_integer_p (void); +long lex_integer (void); + +/* Token matching functions. */ +int lex_match (int); +int lex_match_id (const char *); +int lex_match_int (int); + +/* Forcible matching functions. */ +int lex_force_match (int); +int lex_force_match_id (const char *); +int lex_force_int (void); +int lex_force_num (void); +int lex_force_id (void); +int lex_force_string (void); + +/* Comparing identifiers. */ +int lex_id_match_len (const char *keyword_string, size_t keyword_len, + const char *token_string, size_t token_len); +int lex_id_match (const char *keyword_string, const char *token_string); + +/* Weird token functions. */ +int lex_look_ahead (void); +void lex_put_back (int); +void lex_put_forward (int); + +/* Weird line processing functions. */ +char *lex_entire_line (void); +char *lex_rest_of_line (int *had_dot); +void lex_discard_line (void); +void lex_set_prog (char *p); + +/* Weird line reading functions. */ +int lex_get_line (void); +void lex_preprocess_line (void); + +/* Token names. */ +const char *lex_token_name (int); +char *lex_token_representation (void); + +/* Really weird functions. */ +void lex_negative_to_dash (void); +void lex_reset_eof (void); +void lex_skip_comment (void); + +#endif /* !lexer_h */ diff --git a/src/list.q b/src/list.q new file mode 100644 index 00000000..45046a02 --- /dev/null +++ b/src/list.q @@ -0,0 +1,781 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "magic.h" +#include "misc.h" +#include "htmlP.h" +#include "output.h" +#include "som.h" +#include "var.h" +#include "vfm.h" +#include "format.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +static void debug_print (void); +#endif + +/* (specification) + list (lst_): + *variables=varlist("PV_NO_SCRATCH"); + cases=:from n:first,"%s>0"/by n:step,"%s>0"/ *to n:last,"%s>0"; + format=numbering:numbered/!unnumbered, + wrap:!wrap/single, + weight:weight/!noweight. +*/ +/* (declarations) */ +/* (functions) */ + +/* Layout for one output driver. */ +struct list_ext + { + int type; /* 0=Values and labels fit across the page. */ + int n_vertical; /* Number of labels to list vertically. */ + int header_rows; /* Number of header rows. */ + char **header; /* The header itself. */ + }; + +/* Parsed command. */ +static struct cmd_list cmd; + +/* Current case number. */ +static int case_num; + +/* Line buffer. */ +static char *line_buf; + +/* TTY-style output functions. */ +static int n_lines_remaining (struct outp_driver *d); +static int n_chars_width (struct outp_driver *d); +static void write_line (struct outp_driver *d, char *s); + +/* Other functions. */ +static int list_cases (struct ccase *); +static void determine_layout (void); +static void clean_up (void); +static void write_header (struct outp_driver *); +static void write_all_headers (void); + +/* Returns the number of text lines that can fit on the remainder of + the page. */ +static inline int +n_lines_remaining (struct outp_driver *d) +{ + int diff; + + diff = d->length - d->cp_y; + return (diff > 0) ? (diff / d->font_height) : 0; +} + +/* Returns the number of fixed-width character that can fit across the + page. */ +static inline int +n_chars_width (struct outp_driver *d) +{ + return d->width / d->fixed_width; +} + +/* Writes the line S at the current position and advances to the next + line. */ +static void +write_line (struct outp_driver *d, char *s) +{ + struct outp_text text; + + assert (d->cp_y + d->font_height <= d->length); + text.options = OUTP_T_JUST_LEFT; + ls_init (&text.s, s, strlen (s)); + text.x = d->cp_x; + text.y = d->cp_y; + d->class->text_draw (d, &text); + d->cp_x = 0; + d->cp_y += d->font_height; +} + +/* Parses and executes the LIST procedure. */ +int +cmd_list (void) +{ + struct variable casenum_var; + + lex_match_id ("LIST"); + if (!parse_list (&cmd)) + return CMD_FAILURE; + + /* Fill in defaults. */ + if (cmd.step == NOT_LONG) + cmd.step = 1; + if (cmd.first == NOT_LONG) + cmd.first = 1; + if (cmd.last == NOT_LONG) + cmd.last = LONG_MAX; + if (!cmd.sbc_variables) + fill_all_vars (&cmd.v_variables, &cmd.n_variables, + FV_NO_SYSTEM | FV_NO_SCRATCH); + if (cmd.n_variables == 0) + { + msg (SE, _("No variables specified.")); + return CMD_FAILURE; + } + + /* Verify arguments. */ + if (cmd.first > cmd.last) + { + int t; + msg (SW, _("The first case (%ld) specified precedes the last case (%ld) " + "specified. The values will be swapped."), cmd.first, cmd.last); + t = cmd.first; + cmd.first = cmd.last; + cmd.last = t; + } + if (cmd.first < 1) + { + msg (SW, _("The first case (%ld) to list is less than 1. The value is " + "being reset to 1."), cmd.first); + cmd.first = 1; + } + if (cmd.last < 1) + { + msg (SW, _("The last case (%ld) to list is less than 1. The value is " + "being reset to 1."), cmd.last); + cmd.last = 1; + } + if (cmd.step < 1) + { + msg (SW, _("The step value %ld is less than 1. The value is being " + "reset to 1."), cmd.step); + cmd.step = 1; + } + + /* Weighting variable. */ + if (cmd.weight == LST_WEIGHT) + { + update_weighting (&default_dict); + if (default_dict.weight_index != -1) + { + int i; + + for (i = 0; i < cmd.n_variables; i++) + if (cmd.v_variables[i]->index == default_dict.weight_index) + break; + if (i >= cmd.n_variables) + { + /* Add the weight variable to the end of the variable list. */ + cmd.n_variables++; + cmd.v_variables = xrealloc (cmd.v_variables, + (cmd.n_variables + * sizeof *cmd.v_variables)); + cmd.v_variables[cmd.n_variables - 1] + = default_dict.var[default_dict.weight_index]; + } + } + else + msg (SW, _("`/FORMAT WEIGHT' specified, but weighting is not on.")); + } + + /* Case number. */ + if (cmd.numbering == LST_NUMBERED) + { + /* Initialize the case-number variable. */ + strcpy (casenum_var.name, "Case#"); + casenum_var.type = NUMERIC; + casenum_var.fv = -1; + casenum_var.print.type = FMT_F; + casenum_var.print.w = (cmd.last == LONG_MAX ? 5 : intlog10 (cmd.last)); + casenum_var.print.d = 0; + + /* Add the weight variable at the beginning of the variable list. */ + cmd.n_variables++; + cmd.v_variables = xrealloc (cmd.v_variables, + cmd.n_variables * sizeof *cmd.v_variables); + memmove (&cmd.v_variables[1], &cmd.v_variables[0], + (cmd.n_variables - 1) * sizeof *cmd.v_variables); + cmd.v_variables[0] = &casenum_var; + } + +#if DEBUGGING + /* Print out command. */ + debug_print (); +#endif + + determine_layout (); + + case_num = 0; + procedure (write_all_headers, list_cases, NULL); + free (line_buf); + + clean_up (); + + return CMD_SUCCESS; +} + +/* Writes headers to all devices. This is done at the beginning of + each SPLIT FILE group. */ +static void +write_all_headers (void) +{ + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + { + if (!d->class->special) + { + d->cp_y += d->font_height; /* Blank line. */ + write_header (d); + } + else if (d->class == &html_class) + { + struct html_driver_ext *x = d->ext; + + assert (d->driver_open && d->page_open); + if (x->sequence_no == 0 && !d->class->open_page (d)) + { + msg (ME, _("Cannot open first page on HTML device %s."), + d->name); + return; + } + + fputs ("\n \n", x->file.file); + + { + int i; + + for (i = 0; i < cmd.n_variables; i++) + fprintf (x->file.file, " \n", + cmd.v_variables[i]->name); + } + + fputs (" \n", x->file.file); + } + else + assert (0); + } +} + +/* Writes the headers. Some of them might be vertical; most are + probably horizontal. */ +static void +write_header (struct outp_driver *d) +{ + struct list_ext *prc = d->prc; + + if (!prc->header_rows) + return; + + if (n_lines_remaining (d) < prc->header_rows + 1) + { + outp_eject_page (d); + assert (n_lines_remaining (d) >= prc->header_rows + 1); + } + + /* Design the header. */ + if (!prc->header) + { + int i, x; + + /* Allocate, initialize header. */ + prc->header = xmalloc (sizeof (char *) * prc->header_rows); + { + int w = n_chars_width (d); + for (i = 0; i < prc->header_rows; i++) + { + prc->header[i] = xmalloc (w + 1); + memset (prc->header[i], ' ', w); + } + } + + /* Put in vertical names. */ + for (i = x = 0; i < prc->n_vertical; i++) + { + struct variable *v = cmd.v_variables[i]; + int j; + + memset (&prc->header[prc->header_rows - 1][x], '-', v->print.w); + x += v->print.w - 1; + for (j = 0; j < (int) strlen (v->name); j++) + prc->header[strlen (v->name) - j - 1][x] = v->name[j]; + x += 2; + } + + /* Put in horizontal names. */ + for (; i < cmd.n_variables; i++) + { + struct variable *v = cmd.v_variables[i]; + + memset (&prc->header[prc->header_rows - 1][x], '-', + max (v->print.w, (int) strlen (v->name))); + if ((int) strlen (v->name) < v->print.w) + x += v->print.w - strlen (v->name); + memcpy (&prc->header[0][x], v->name, strlen (v->name)); + x += strlen (v->name) + 1; + } + + /* Add null bytes. */ + for (i = 0; i < prc->header_rows; i++) + { + for (x = n_chars_width (d); x >= 1; x--) + if (prc->header[i][x - 1] != ' ') + { + prc->header[i][x] = 0; + break; + } + assert (x); + } + } + + /* Write out the header, in back-to-front order except for the last line. */ + { + int i; + + for (i = prc->header_rows - 2; i >= 0; i--) + write_line (d, prc->header[i]); + write_line (d, prc->header[prc->header_rows - 1]); + } +} + + +/* Frees up all the memory we've allocated. */ +static void +clean_up (void) +{ + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + if (d->class->special == 0) + { + struct list_ext *prc = d->prc; + int i; + + if (prc->header) + { + for (i = 0; i < prc->header_rows; i++) + free (prc->header[i]); + free (prc->header); + } + free (prc); + + d->class->text_set_font_by_name (d, "PROP"); + } + else if (d->class == &html_class) + { + if (d->driver_open && d->page_open) + { + struct html_driver_ext *x = d->ext; + + fputs ("
%s
\n", x->file.file); + } + } + else + assert (0); + + free (cmd.v_variables); +} + +/* Writes string STRING at the current position. If the text would + fall off the side of the page, then advance to the next line, + indenting by amount INDENT. */ +static void +write_varname (struct outp_driver *d, char *string, int indent) +{ + struct outp_text text; + + text.options = OUTP_T_JUST_LEFT; + ls_init (&text.s, string, strlen (string)); + d->class->text_metrics (d, &text); + + if (d->cp_x + text.h > d->width) + { + d->cp_y += d->font_height; + if (d->cp_y + d->font_height > d->length) + outp_eject_page (d); + d->cp_x = indent; + } + + text.x = d->cp_x; + text.y = d->cp_y; + d->class->text_draw (d, &text); + d->cp_x += text.h; +} + +/* When we can't fit all the values across the page, we write out all + the variable names just once. This is where we do it. */ +static void +write_fallback_headers (struct outp_driver *d) +{ + const int max_width = n_chars_width(d) - 10; + + int index = 0; + int width = 0; + int line_number = 0; + + const char *Line = _("Line"); + char *leader = local_alloc (strlen (Line) + INT_DIGITS + 1 + 1); + + while (index < cmd.n_variables) + { + struct outp_text text; + + /* Ensure that there is enough room for a line of text. */ + if (d->cp_y + d->font_height > d->length) + outp_eject_page (d); + + /* The leader is a string like `Line 1: '. Write the leader. */ + sprintf(leader, "%s %d:", Line, ++line_number); + text.options = OUTP_T_JUST_LEFT; + ls_init (&text.s, leader, strlen (leader)); + text.x = 0; + text.y = d->cp_y; + d->class->text_draw (d, &text); + d->cp_x = text.h; + + goto entry; + do + { + width++; + + entry: + { + int var_width = cmd.v_variables[index]->print.w; + if (width + var_width > max_width && width != 0) + { + width = 0; + d->cp_x = 0; + d->cp_y += d->font_height; + break; + } + width += var_width; + } + + { + char varname[10]; + sprintf (varname, " %s", cmd.v_variables[index]->name); + write_varname (d, varname, text.h); + } + } + while (++index < cmd.n_variables); + + } + d->cp_x = 0; + d->cp_y += d->font_height; + + local_free (leader); +} + +/* There are three possible layouts for the LIST procedure: + + 1. If the values and their variables' name fit across the page, + then they are listed across the page in that way. + + 2. If the values can fit across the page, but not the variable + names, then as many variable names as necessary are printed + vertically to compensate. + + 3. If not even the values can fit across the page, the variable + names are listed just once, at the beginning, in a compact format, + and the values are listed with a variable name label at the + beginning of each line for easier reference. + + This is complicated by the fact that we have to do all this for + every output driver, not just once. */ +static void +determine_layout (void) +{ + struct outp_driver *d; + + /* This is the largest page width of any driver, so we can tell what + size buffer to allocate. */ + int largest_page_width = 0; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + { + int column; /* Current column. */ + int width; /* Accumulated width. */ + int max_width; /* Page width. */ + + struct list_ext *prc; + + if (d->class == &html_class) + continue; + + assert (d->class->special == 0); + + if (!d->page_open) + d->class->open_page (d); + + max_width = n_chars_width (d); + largest_page_width = max (largest_page_width, max_width); + + prc = d->prc = xmalloc (sizeof *prc); + prc->type = 0; + prc->n_vertical = 0; + prc->header = NULL; + + /* Try layout #1. */ + for (width = cmd.n_variables - 1, column = 0; column < cmd.n_variables; column++) + { + struct variable *v = cmd.v_variables[column]; + width += max (v->print.w, (int) strlen (v->name)); + } + if (width <= max_width) + { + prc->header_rows = 2; + d->class->text_set_font_by_name (d, "FIXED"); + continue; + } + + /* Try layout #2. */ + for (width = cmd.n_variables - 1, column = 0; + column < cmd.n_variables && width <= max_width; + column++) + width += cmd.v_variables[column]->print.w; + + /* If it fit then we need to determine how many labels can be + written horizontally. */ + if (width <= max_width) + { +#ifndef NDEBUG + prc->n_vertical = -1; +#endif + for (column = cmd.n_variables - 1; column >= 0; column--) + { + struct variable *v = cmd.v_variables[column]; + int trial_width = (width - v->print.w + + max (v->print.w, (int) strlen (v->name))); + + if (trial_width > max_width) + { + prc->n_vertical = column + 1; + break; + } + width = trial_width; + } + assert(prc->n_vertical != -1); + + prc->n_vertical = cmd.n_variables; + /* Finally determine the length of the headers. */ + for (prc->header_rows = 0, column = 0; + column < prc->n_vertical; + column++) + prc->header_rows = max (prc->header_rows, + (int) strlen (cmd.v_variables[column]->name)); + prc->header_rows++; + + d->class->text_set_font_by_name (d, "FIXED"); + continue; + } + + /* Otherwise use the ugly fallback listing format. */ + prc->type = 1; + prc->header_rows = 0; + + d->cp_y += d->font_height; + write_fallback_headers (d); + d->cp_y += d->font_height; + d->class->text_set_font_by_name (d, "FIXED"); + } + + line_buf = xmalloc (max (1022, largest_page_width) + 2); +} + +static int +list_cases (struct ccase *c) +{ + struct outp_driver *d; + + case_num++; + if (case_num < cmd.first || case_num > cmd.last + || (cmd.step != 1 && (case_num - cmd.first) % cmd.step)) + return 1; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + if (d->class->special == 0) + { + const struct list_ext *prc = d->prc; + const int max_width = n_chars_width (d); + int column; + int x = 0; + + if (!prc->header_rows) + x = nsprintf (line_buf, "%8s: ", cmd.v_variables[0]->name); + + for (column = 0; column < cmd.n_variables; column++) + { + struct variable *v = cmd.v_variables[column]; + int width; + + if (prc->type == 0 && column >= prc->n_vertical) + width = max ((int) strlen (v->name), v->print.w); + else + width = v->print.w; + + if (width + x > max_width && x != 0) + { + if (!n_lines_remaining (d)) + { + outp_eject_page (d); + write_header (d); + } + + line_buf[x] = 0; + write_line (d, line_buf); + + x = 0; + if (!prc->header_rows) + x = nsprintf (line_buf, "%8s: ", v->name); + } + + if (width > v->print.w) + { + memset(&line_buf[x], ' ', width - v->print.w); + x += width - v->print.w; + } + + { + union value value; + + if (formats[v->print.type].cat & FCAT_STRING) + value.c = c->data[v->fv].s; + else if (v->fv == -1) + value.f = case_num; + else + value.f = c->data[v->fv].f; + + data_out (&line_buf[x], &v->print, &value); + } + x += v->print.w; + + line_buf[x++] = ' '; + } + + if (!n_lines_remaining (d)) + { + outp_eject_page (d); + write_header (d); + } + + line_buf[x] = 0; + write_line (d, line_buf); + } + else if (d->class == &html_class) + { + struct html_driver_ext *x = d->ext; + int column; + + fputs (" \n", x->file.file); + + for (column = 0; column < cmd.n_variables; column++) + { + struct variable *v = cmd.v_variables[column]; + union value value; + char buf[41]; + + if (formats[v->print.type].cat & FCAT_STRING) + value.c = c->data[v->fv].s; + else if (v->fv == -1) + value.f = case_num; + else + value.f = c->data[v->fv].f; + + data_out (buf, &v->print, &value); + buf[v->print.w] = 0; + + fprintf (x->file.file, " %s\n", + &buf[strspn (buf, " ")]); + } + + fputs (" \n", x->file.file); + } + else + assert (0); + + return 1; +} + +/* Debugging output. */ + +#if DEBUGGING +/* Prints out the command as parsed by cmd_list(). */ +static void +debug_print (void) +{ + int i; + + puts ("LIST"); + printf (" VARIABLES="); + for (i = 0; i < cmd.n_variables; i++) + { + if (i) + putc (' ', stdout); + fputs (cmd.v_variables[i]->name, stdout); + } + + printf ("\n /CASES=FROM %ld TO %ld BY %ld\n", first, last, step); + + fputs (" /FORMAT=", stdout); + if (numbering == NUMBERED) + fputs ("NUMBERED", stdout); + else + fputs ("UNNUMBERED", stdout); + putc (' ', stdout); + if (wrap == WRAP) + fputs ("WRAP", stdout); + else + fputs ("SINGLE", stdout); + putc (' ', stdout); + if (weight == WEIGHT) + fputs ("WEIGHT", stdout); + else + fputs ("NOWEIGHT", stdout); + puts ("."); +} +#endif /* DEBUGGING */ + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/log.h b/src/log.h new file mode 100644 index 00000000..0598206b --- /dev/null +++ b/src/log.h @@ -0,0 +1,38 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !log_h +#define log_h 1 + +#include + +/* Whether logging is on. */ +extern int logging; + +/* The name of the log file. */ +extern char *logfn; + +/* The log file stream. */ +extern FILE *logfile; + +/* Log file management. */ +void open_logfile (void); +void close_logfile (void); + +#endif /* !log_h */ diff --git a/src/loop.c b/src/loop.c new file mode 100644 index 00000000..b7dac895 --- /dev/null +++ b/src/loop.c @@ -0,0 +1,612 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "alloc.h" +#include "approx.h" +#include "command.h" +#include "do-ifP.h" +#include "error.h" +#include "expr.h" +#include "lexer.h" +#include "settings.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* *INDENT-OFF* */ +/* LOOP strategy: + + Each loop causes 3 different transformations to be output. The + first two are output when the LOOP command is encountered; the last + is output when the END LOOP command is encountered. + + The first to be output resets the pass number in the second + transformation to -1. This ensures that the pass number is set to + -1 every time the loop is encountered, before the first iteration. + + The second transformation increments the pass number. If there is + no indexing or test clause on either LOOP or END LOOP, then the + pass number is checked against MXLOOPS and control may pass out of + the loop; otherwise the indexing or test clause(s) on LOOP are + checked, and again control may pass out of the loop. + + After the second transformation the body of the loop is executed. + + The last transformation checks the test clause if present and + either jumps back up to the second transformation or terminates the + loop. + + Flow of control: (The characters ^V<> represents arrows.) + + 1. LOOP (sets pass # to -1) + V + V + >>2. LOOP (increment pass number) + ^ (test optional indexing clause) + ^ (test optional IF clause) + ^ if we need another trip if we're done with the loop>>V + ^ V V + ^ V V + ^ *. execute loop body V + ^ . V + ^ . (any number of transformations) V + ^ . V + ^ V + ^ 3. END LOOP (test optional IF clause) V + ^<<<>V + V + V + *. transformations after loop body<<<<<<<<<<<<<<<<<<<<<<<<<<< + + */ +/* *INDENT-ON* */ + +/* Types of limits on loop execution. */ +enum + { + LPC_INDEX = 001, /* Limited by indexing clause. */ + LPC_COND = 002, /* Limited by IF clause. */ + LPC_RINDEX = 004 /* Indexing clause counts downward, at least + for this pass thru the loop. */ + }; + +/* LOOP transformation 1. */ +struct loop_1_trns + { + struct trns_header h; + + struct loop_2_trns *two; /* Allows modification of associated + second transformation. */ + + struct expression *init; /* Starting index. */ + struct expression *incr; /* Index increment. */ + struct expression *term; /* Terminal index. */ + }; + +/* LOOP transformation 2. */ +struct loop_2_trns + { + struct trns_header h; + + struct ctl_stmt ctl; /* Nesting control info. */ + + int flags; /* Types of limits on loop execution. */ + int pass; /* Number of passes thru the loop so far. */ + + struct variable *index; /* Index variable. */ + double curr; /* Current index. */ + double incr; /* Increment. */ + double term; /* Terminal index. */ + + struct expression *cond; /* Optional IF condition when non-NULL. */ + + int loop_term; /* 1+(t_trns[] index of transformation 3); + backpatched in by END LOOP. */ + }; + +/* LOOP transformation 3. (Actually output by END LOOP.) */ +struct loop_3_trns + { + struct trns_header h; + + struct expression *cond; /* Optional IF condition when non-NULL. */ + + int loop_start; /* t_trns[] index of transformation 2. */ + }; + +/* LOOP transformations being created. */ +static struct loop_1_trns *one; +static struct loop_2_trns *two; +static struct loop_3_trns *thr; + +static int internal_cmd_loop (void); +static int internal_cmd_end_loop (void); +static int break_trns_proc (struct trns_header *, struct ccase *); +static int loop_1_trns_proc (struct trns_header *, struct ccase *); +static void loop_1_trns_free (struct trns_header *); +static int loop_2_trns_proc (struct trns_header *, struct ccase *); +static void loop_2_trns_free (struct trns_header *); +static int loop_3_trns_proc (struct trns_header *, struct ccase *); +static void loop_3_trns_free (struct trns_header *); +static void pop_ctl_stack (void); + +/* LOOP. */ + +/* Parses a LOOP command. Passes the real work off to + internal_cmd_loop(). */ +int +cmd_loop (void) +{ + if (!internal_cmd_loop ()) + { + loop_1_trns_free ((struct trns_header *) one); + loop_2_trns_free ((struct trns_header *) two); + return CMD_FAILURE; + } + + return CMD_SUCCESS; +} + +/* Parses a LOOP command, returns success. */ +static int +internal_cmd_loop (void) +{ + /* Name of indexing variable if applicable. */ + char name[9]; + + lex_match_id ("LOOP"); + + /* Create and initialize transformations to facilitate + error-handling. */ + two = xmalloc (sizeof *two); + two->h.proc = loop_2_trns_proc; + two->h.free = loop_2_trns_free; + two->cond = NULL; + two->flags = 0; + + one = xmalloc (sizeof *one); + one->h.proc = loop_1_trns_proc; + one->h.free = loop_1_trns_free; + one->init = one->incr = one->term = NULL; + one->two = two; + + /* Parse indexing clause. */ + if (token == T_ID && lex_look_ahead () == '=') + { + struct variable *v = find_variable (tokid); + + two->flags |= LPC_INDEX; + + if (v && v->type == ALPHA) + { + msg (SE, _("The index variable may not be a string variable.")); + return 0; + } + strcpy (name, tokid); + + lex_get (); + assert (token == '='); + lex_get (); + + one->init = expr_parse (PXP_NUMERIC); + if (!one->init) + return 0; + + if (!lex_force_match (T_TO)) + { + expr_free (one->init); + return 0; + } + one->term = expr_parse (PXP_NUMERIC); + if (!one->term) + { + expr_free (one->init); + return 0; + } + + if (lex_match (T_BY)) + { + one->incr = expr_parse (PXP_NUMERIC); + if (!one->incr) + return 0; + } + } + else + name[0] = 0; + + /* Parse IF clause. */ + if (lex_match_id ("IF")) + { + two->flags |= LPC_COND; + + two->cond = expr_parse (PXP_BOOLEAN); + if (!two->cond) + return 0; + } + + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + + /* Find variable; create if necessary. */ + if (name[0]) + { + two->index = find_variable (name); + if (!two->index) + { + two->index = force_create_variable (&default_dict, name, NUMERIC, 0); +#if DEBUGGING + envector (two->index); +#endif + } + } + + /* Push on control stack. */ + two->ctl.down = ctl_stack; + two->ctl.type = CST_LOOP; + two->ctl.trns = (struct trns_header *) two; + two->ctl.brk = NULL; + ctl_stack = &two->ctl; + + /* Dump out the transformations. */ + add_transformation ((struct trns_header *) one); + add_transformation ((struct trns_header *) two); + +#if DEBUGGING + printf ("LOOP"); + if (two->flags & LPC_INDEX) + printf ("(INDEX)"); + if (two->flags & LPC_COND) + printf ("(IF)"); + printf ("\n"); +#endif + + return 1; +} + +/* Parses the END LOOP command by passing the buck off to + cmd_internal_end_loop(). */ +int +cmd_end_loop (void) +{ + if (!internal_cmd_end_loop ()) + { + loop_3_trns_free ((struct trns_header *) thr); + if (ctl_stack && ctl_stack->type == CST_LOOP) + pop_ctl_stack (); + return CMD_FAILURE; + } + + return CMD_SUCCESS; +} + +/* Parses the END LOOP command. */ +int +internal_cmd_end_loop (void) +{ + /* Backpatch pointer for BREAK commands. */ + struct break_trns *brk; + + /* Allocate, initialize transformation to facilitate + error-handling. */ + thr = xmalloc (sizeof *thr); + thr->h.proc = loop_3_trns_proc; + thr->h.free = loop_3_trns_free; + thr->cond = NULL; + + /* There must be a matching LOOP command. */ + if (!ctl_stack || ctl_stack->type != CST_LOOP) + { + msg (SE, _("There is no LOOP command that corresponds to this " + "END LOOP.")); + return 0; + } + thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index; + + /* Parse the expression if any. */ + if (lex_match_id ("IF")) + { + thr->cond = expr_parse (PXP_BOOLEAN); + if (!thr->cond) + return 0; + } + + add_transformation ((struct trns_header *) thr); + + /* Backpatch. */ + ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns; + for (brk = ctl_stack->brk; brk; brk = brk->next) + brk->loop_term = n_trns; + + /* Pop off the top of stack. */ + ctl_stack = ctl_stack->down; + +#if DEBUGGING + printf ("END LOOP"); + if (thr->cond) + printf ("(IF)"); + printf ("\n"); +#endif + + return 1; +} + +/* Performs transformation 1. */ +static int +loop_1_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct loop_1_trns *one = (struct loop_1_trns *) trns; + struct loop_2_trns *two = one->two; + + two->pass = -1; + if (two->flags & LPC_INDEX) + { + union value t1, t2, t3; + + expr_evaluate (one->init, c, &t1); + if (one->incr) + expr_evaluate (one->incr, c, &t2); + else + t2.f = 1.0; + expr_evaluate (one->term, c, &t3); + + /* Even if the loop is never entered, force the index variable + to assume the initial value. */ + c->data[two->index->fv].f = t1.f; + + /* Throw out various pathological cases. */ + if (!finite (t1.f) || !finite (t2.f) || !finite (t3.f) + || approx_eq (t2.f, 0.0)) + return two->loop_term; + debug_printf (("LOOP %s=%g TO %g BY %g.\n", two->index->name, + t1.f, t3.f, t2.f)); + if (t2.f > 0.0) + { + /* Loop counts upward: I=1 TO 5 BY 1. */ + two->flags &= ~LPC_RINDEX; + + /* incr>0 but init>term */ + if (approx_gt (t1.f, t3.f)) + return two->loop_term; + } + else + { + /* Loop counts downward: I=5 TO 1 BY -1. */ + two->flags |= LPC_RINDEX; + + /* incr<0 but initloop_term; + } + + two->curr = t1.f; + two->incr = t2.f; + two->term = t3.f; + } + + return -1; +} + +/* Frees transformation 1. */ +static void +loop_1_trns_free (struct trns_header * trns) +{ + struct loop_1_trns *one = (struct loop_1_trns *) trns; + + expr_free (one->init); + expr_free (one->incr); + expr_free (one->term); +} + +/* Performs transformation 2. */ +static int +loop_2_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct loop_2_trns *two = (struct loop_2_trns *) trns; + + /* MXLOOPS limiter. */ + if (two->flags == 0) + { + two->pass++; + if (two->pass > set_mxloops) + return two->loop_term; + } + + /* Indexing clause limiter: counting downward. */ + if (two->flags & LPC_RINDEX) + { + /* Test if we're at the end of the looping. */ + if (approx_lt (two->curr, two->term)) + return two->loop_term; + + /* Set the current value into the case. */ + c->data[two->index->fv].f = two->curr; + + /* Decrement the current value. */ + two->curr += two->incr; + } + /* Indexing clause limiter: counting upward. */ + else if (two->flags & LPC_INDEX) + { + /* Test if we're at the end of the looping. */ + if (approx_gt (two->curr, two->term)) + return two->loop_term; + + /* Set the current value into the case. */ + c->data[two->index->fv].f = two->curr; + + /* Increment the current value. */ + two->curr += two->incr; + } + + /* Conditional clause limiter. */ + if ((two->flags & LPC_COND) + && expr_evaluate (two->cond, c, NULL) != 1.0) + return two->loop_term; + + return -1; +} + +/* Frees transformation 2. */ +static void +loop_2_trns_free (struct trns_header * trns) +{ + struct loop_2_trns *two = (struct loop_2_trns *) trns; + + expr_free (two->cond); +} + +/* Performs transformation 3. */ +static int +loop_3_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct loop_3_trns *thr = (struct loop_3_trns *) trns; + + /* Note that it breaks out of the loop if the expression is true *or + missing*. This is conformant. */ + if (thr->cond && expr_evaluate (two->cond, c, NULL) != 0.0) + return -1; + + return thr->loop_start; +} + +/* Frees transformation 3. */ +static void +loop_3_trns_free (struct trns_header * trns) +{ + struct loop_3_trns *thr = (struct loop_3_trns *) trns; + + expr_free (thr->cond); +} + +/* BREAK. */ + +/* Parses the BREAK command. */ +int +cmd_break (void) +{ + /* Climbs down the stack to find a LOOP. */ + struct ctl_stmt *loop; + + /* New transformation. */ + struct break_trns *t; + + lex_match_id ("BREAK"); + + for (loop = ctl_stack; loop; loop = loop->down) + if (loop->type == CST_LOOP) + break; + if (!loop) + { + msg (SE, _("This command may only appear enclosed in a LOOP/" + "END LOOP control structure.")); + return CMD_FAILURE; + } + + if (ctl_stack->type != CST_DO_IF) + msg (SW, _("BREAK not enclosed in DO IF structure.")); + + t = xmalloc (sizeof *t); + t->h.proc = break_trns_proc; + t->h.free = NULL; + t->next = loop->brk; + loop->brk = t; + add_transformation ((struct trns_header *) t); + + return lex_end_of_command (); +} + +static int +break_trns_proc (struct trns_header * trns, struct ccase * c unused) +{ + return ((struct break_trns *) trns)->loop_term; +} + +/* Control stack operations. */ + +/* Pops the top of stack element off of ctl_stack. Does not + check that ctl_stack is indeed non-NULL. */ +static void +pop_ctl_stack (void) +{ + switch (ctl_stack->type) + { + case CST_LOOP: + { + /* Pointer for chasing down and backpatching BREAKs. */ + struct break_trns *brk; + + /* Terminate the loop. */ + thr = xmalloc (sizeof *thr); + thr->h.proc = loop_3_trns_proc; + thr->h.free = loop_3_trns_free; + thr->cond = NULL; + thr->loop_start = ((struct loop_2_trns *) ctl_stack->trns)->h.index; + add_transformation ((struct trns_header *) thr); + + /* Backpatch. */ + ((struct loop_2_trns *) ctl_stack->trns)->loop_term = n_trns; + for (brk = ctl_stack->brk; brk; brk = brk->next) + brk->loop_term = n_trns; + } + break; + case CST_DO_IF: + { + /* List iterator. */ + struct do_if_trns *iter; + + iter = ((struct do_if_trns *) ctl_stack->trns); + for (;;) + { + if (iter->brk) + iter->brk->dest = n_trns; + iter->missing_jump = n_trns; + if (iter->next) + iter = iter->next; + else + break; + } + iter->false_jump = n_trns; + } + break; + default: + assert (0); + } + ctl_stack = ctl_stack->down; +} + +/* Checks for unclosed LOOPs and DO IFs and closes them out. */ +void +discard_ctl_stack (void) +{ + if (!ctl_stack) + return; + msg (SE, _("%s without %s."), ctl_stack->type == CST_LOOP ? "LOOP" : "DO IF", + ctl_stack->type == CST_LOOP ? "END LOOP" : "END IF"); + while (ctl_stack) + pop_ctl_stack (); + ctl_stack = NULL; +} diff --git a/src/magic.c b/src/magic.c new file mode 100644 index 00000000..d114a912 --- /dev/null +++ b/src/magic.c @@ -0,0 +1,33 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include "magic.h" + +#if ENDIAN==UNKNOWN +/* BIG or LITTLE, depending on this machine's endianness, as detected + at program startup. */ +int endian; +#endif + +#ifndef SECOND_LOWEST_VALUE +/* "Second lowest" value for a flt64; that is, (-FLT64_MAX) + epsilon. */ +double second_lowest_value; +#endif + diff --git a/src/magic.h b/src/magic.h new file mode 100644 index 00000000..3693f23f --- /dev/null +++ b/src/magic.h @@ -0,0 +1,45 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !magic_h +#define magic_h 1 + +/* Magic numbers. */ + +#include +#include + +#if ENDIAN != UNKNOWN +#define endian ENDIAN +#else +extern int endian; +#endif + +#ifdef SECOND_LOWEST_VALUE +#define second_lowest_value SECOND_LOWEST_VALUE +#else +extern double second_lowest_value; +#endif + +/* Used when we want a "missing value". */ +#define NOT_DOUBLE (-DBL_MAX) +#define NOT_LONG LONG_MIN +#define NOT_INT INT_MIN + +#endif /* magic.h */ diff --git a/src/main.c b/src/main.c new file mode 100644 index 00000000..e2599186 --- /dev/null +++ b/src/main.c @@ -0,0 +1,154 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "command.h" +#include "error.h" +#include "getline.h" +#include "lexer.h" +#include "output.h" + +#include + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +static void parse_script (void) __attribute__ ((noreturn)); +static void handle_error (int code); +static int execute_command (void); + +/* argv[0] with stripped leading directories. */ +char *pgmname; + +/* Whether FINISH. has been executed. */ +int finished; + +/* The current date in the form DD MMM YYYY. */ +char curdate[12]; + +/* Whether we're dropping down to interactive mode immediately because + we hit end-of-file unexpectedly (or whatever). */ +int start_interactive; + +/* Program entry point. */ +int +main (int argc, char **argv) +{ + void init_glob (int, char **); /* Exported by glob.c. */ + void parse_command_line (int, char **); /* Exported by cmdline.c */ + + /* Initialization. */ + if (!outp_init ()) + err_hcf (0); + init_glob (argc, argv); + parse_command_line (argc, argv); + if (!outp_read_devices ()) + msg (FE, _("Error initializing output drivers.")); + + lex_init (); + cmd_init (); + + /* Execution. */ + parse_script (); +} + +/* Parses the entire script. */ +static void +parse_script (void) +{ + while (!finished) + { + err_check_count (); + handle_error (execute_command ()); + } + + err_hcf (1); +} + +/* Parse and execute a command, returning its return code. */ +static int +execute_command (void) +{ + /* Read the command's first token. + We may hit end of file. + If so, give the line reader a chance to proceed to the next file. + End of file is not handled transparently since the user may want + the dictionary cleared between files. */ + getl_prompt = GETL_PRPT_STANDARD; + for (;;) + { + lex_get (); + if (token != T_STOP) + break; + + if (!getl_perform_delayed_reset ()) + err_hcf (1); + } + + /* Parse the command. */ + getl_prompt = GETL_PRPT_CONTINUATION; + return cmd_parse (); +} + +/* Print an error message corresponding to the command return code + CODE. */ +static void +handle_error (int code) +{ + switch (code) + { + case CMD_SUCCESS: + return; + + case CMD_FAILURE: + msg (SW, _("This command not executed.")); + break; + + case CMD_PART_SUCCESS_MAYBE: + msg (SW, _("Skipping the rest of this command. Part of " + "this command may have been executed.")); + break; + + case CMD_PART_SUCCESS: + msg (SW, _("Skipping the rest of this command. This " + "command was fully executed up to this point.")); + break; + + case CMD_TRAILING_GARBAGE: + msg (SW, _("Trailing garbage was encountered following " + "this command. The command was fully executed " + "to this point.")); + break; + + default: + assert (0); + } + + if (getl_reading_script) + { + err_break (); + while (token != T_STOP && token != '.') + lex_get (); + } + else + lex_discard_line (); +} diff --git a/src/main.h b/src/main.h new file mode 100644 index 00000000..076882b9 --- /dev/null +++ b/src/main.h @@ -0,0 +1,28 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !main_h +#define main_h 1 + +extern char *pgmname; +extern char curdate[]; +extern int start_interactive; +extern int finished; + +#endif /* main.h */ diff --git a/src/matrix-data.c b/src/matrix-data.c new file mode 100644 index 00000000..5e4d5f5d --- /dev/null +++ b/src/matrix-data.c @@ -0,0 +1,2020 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "data-in.h" +#include "dfm.h" +#include "error.h" +#include "file-handle.h" +#include "lexer.h" +#include "misc.h" +#include "pool.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* FIXME: /N subcommand not implemented. It should be pretty simple, + too. */ + +/* Format type enums. */ +enum + { + LIST, + FREE + }; + +/* Matrix section enums. */ +enum + { + LOWER, + UPPER, + FULL + }; + +/* Diagonal inclusion enums. */ +enum + { + DIAGONAL, + NODIAGONAL + }; + +/* CONTENTS types. */ +enum + { + N_VECTOR, + N_SCALAR, + N_MATRIX, + MEAN, + STDDEV, + COUNT, + MSE, + DFE, + MAT, + COV, + CORR, + PROX, + + LPAREN, + RPAREN, + EOC + }; + +/* 0=vector, 1=matrix, 2=scalar. */ +static int content_type[PROX + 1] = + { + 0, 2, 1, 0, 0, 0, 0, 0, 1, 1, 1, 1, + }; + +/* Name of each content type. */ +static const char *content_names[PROX + 1] = + { + "N", "N", "N_MATRIX", "MEAN", "STDDEV", "COUNT", "MSE", + "DFE", "MAT", "COV", "CORR", "PROX", + }; + +/* The data file to be read. */ +static struct file_handle *data_file; + +/* Format type. */ +static int fmt; /* LIST or FREE. */ +static int section; /* LOWER or UPPER or FULL. */ +static int diag; /* DIAGONAL or NODIAGONAL. */ + +/* Arena used for all the MATRIX DATA allocations. */ +static struct pool *container; + +/* ROWTYPE_ specified explicitly in data? */ +static int explicit_rowtype; + +/* ROWTYPE_, VARNAME_ variables. */ +static struct variable *rowtype_, *varname_; + +/* Is is per-factor data? */ +int is_per_factor[PROX + 1]; + +/* Single SPLIT FILE variable. */ +static struct variable *single_split; + +/* Factor variables. */ +static int n_factors; +static struct variable **factors; + +/* Number of cells, or -1 if none. */ +static int cells; + +/* Population N specified by user. */ +static int pop_n; + +/* CONTENTS subcommand. */ +static int contents[EOC * 3 + 1]; +static int n_contents; + +/* Number of continuous variables. */ +static int n_continuous; + +/* Index into default_dict.var of first continuous variables. */ +static int first_continuous; + +static int compare_variables_by_mxd_vartype (const void *pa, + const void *pb); +static void read_matrices_without_rowtype (void); +static void read_matrices_with_rowtype (void); +static int string_to_content_type (char *, int *); + +#if DEBUGGING +static void debug_print (void); +#endif + +int +cmd_matrix_data (void) +{ + unsigned seen = 0; + + lex_match_id ("MATRIX"); + lex_match_id ("DATA"); + + container = pool_create (); + + discard_variables (); + + data_file = inline_file; + fmt = LIST; + section = LOWER; + diag = DIAGONAL; + single_split = NULL; + n_factors = 0; + factors = NULL; + cells = -1; + pop_n = -1; + n_contents = 0; + while (token != '.') + { + lex_match ('/'); + + if (lex_match_id ("VARIABLES")) + { + char **v; + int nv; + + if (seen & 1) + { + msg (SE, _("VARIABLES subcommand multiply specified.")); + goto lossage; + } + seen |= 1; + + lex_match ('='); + if (!parse_DATA_LIST_vars (&v, &nv, PV_NO_DUPLICATE)) + goto lossage; + + { + int i; + + for (i = 0; i < nv; i++) + if (!strcmp (v[i], "VARNAME_")) + { + msg (SE, _("VARNAME_ cannot be explicitly specified on " + "VARIABLES.")); + for (i = 0; i < nv; i++) + free (v[i]); + free (v); + goto lossage; + } + } + + { + int i; + + for (i = 0; i < nv; i++) + { + struct variable *new_var; + + if (strcmp (v[i], "ROWTYPE_")) + { + new_var = force_create_variable (&default_dict, v[i], + NUMERIC, 0); + new_var->p.mxd.vartype = MXD_CONTINUOUS; + new_var->p.mxd.subtype = i; + } + else + explicit_rowtype = 1; + free (v[i]); + } + free (v); + } + + { + rowtype_ = force_create_variable (&default_dict, "ROWTYPE_", + ALPHA, 8); + rowtype_->p.mxd.vartype = MXD_ROWTYPE; + rowtype_->p.mxd.subtype = 0; + } + } + else if (lex_match_id ("FILE")) + { + lex_match ('='); + data_file = fh_parse_file_handle (); + if (!data_file) + goto lossage; + } + else if (lex_match_id ("FORMAT")) + { + lex_match ('='); + + while (token == T_ID) + { + if (lex_match_id ("LIST")) + fmt = LIST; + else if (lex_match_id ("FREE")) + fmt = FREE; + else if (lex_match_id ("LOWER")) + section = LOWER; + else if (lex_match_id ("UPPER")) + section = UPPER; + else if (lex_match_id ("FULL")) + section = FULL; + else if (lex_match_id ("DIAGONAL")) + diag = DIAGONAL; + else if (lex_match_id ("NODIAGONAL")) + diag = NODIAGONAL; + else + { + lex_error (_("in FORMAT subcommand")); + goto lossage; + } + } + } + else if (lex_match_id ("SPLIT")) + { + lex_match ('='); + + if (seen & 2) + { + msg (SE, _("SPLIT subcommand multiply specified.")); + goto lossage; + } + seen |= 2; + + if (token != T_ID) + { + lex_error (_("in SPLIT subcommand")); + goto lossage; + } + + if (!is_varname (tokid) + && (lex_look_ahead () == '.' || lex_look_ahead () == '/')) + { + if (!strcmp (tokid, "ROWTYPE_") || !strcmp (tokid, "VARNAME_")) + { + msg (SE, _("Split variable may not be named ROWTYPE_ " + "or VARNAME_.")); + goto lossage; + } + + single_split = force_create_variable (&default_dict, tokid, + NUMERIC, 0); + lex_get (); + + single_split->p.mxd.vartype = MXD_CONTINUOUS; + + default_dict.n_splits = 1; + default_dict.splits = xmalloc (2 * sizeof *default_dict.splits); + default_dict.splits[0] = single_split; + default_dict.splits[1] = NULL; + } + else + { + struct variable **v; + int n; + + if (!parse_variables (NULL, &v, &n, PV_NO_DUPLICATE)) + goto lossage; + + default_dict.n_splits = n; + default_dict.splits = v = xrealloc (v, sizeof *v * (n + 1)); + v[n] = NULL; + } + + { + int i; + + for (i = 0; i < default_dict.n_splits; i++) + { + if (default_dict.splits[i]->p.mxd.vartype != MXD_CONTINUOUS) + { + msg (SE, _("Split variable %s is already another type."), + tokid); + goto lossage; + } + default_dict.splits[i]->p.mxd.vartype = MXD_SPLIT; + default_dict.splits[i]->p.mxd.subtype = i; + } + } + } + else if (lex_match_id ("FACTORS")) + { + lex_match ('='); + + if (seen & 4) + { + msg (SE, _("FACTORS subcommand multiply specified.")); + goto lossage; + } + seen |= 4; + + if (!parse_variables (NULL, &factors, &n_factors, PV_NONE)) + goto lossage; + + { + int i; + + for (i = 0; i < n_factors; i++) + { + if (factors[i]->p.mxd.vartype != MXD_CONTINUOUS) + { + msg (SE, _("Factor variable %s is already another type."), + tokid); + goto lossage; + } + factors[i]->p.mxd.vartype = MXD_FACTOR; + factors[i]->p.mxd.subtype = i; + } + } + } + else if (lex_match_id ("CELLS")) + { + lex_match ('='); + + if (cells != -1) + { + msg (SE, _("CELLS subcommand multiply specified.")); + goto lossage; + } + + if (!lex_integer_p () || lex_integer () < 1) + { + lex_error (_("expecting positive integer")); + goto lossage; + } + + cells = lex_integer (); + lex_get (); + } + else if (lex_match_id ("N")) + { + lex_match ('='); + + if (pop_n != -1) + { + msg (SE, _("N subcommand multiply specified.")); + goto lossage; + } + + if (!lex_integer_p () || lex_integer () < 1) + { + lex_error (_("expecting positive integer")); + goto lossage; + } + + pop_n = lex_integer (); + lex_get (); + } + else if (lex_match_id ("CONTENTS")) + { + int inside_parens = 0; + unsigned collide = 0; + int item; + + if (seen & 8) + { + msg (SE, _("CONTENTS subcommand multiply specified.")); + goto lossage; + } + seen |= 8; + + lex_match ('='); + + { + int i; + + for (i = 0; i <= PROX; i++) + is_per_factor[i] = 0; + } + + for (;;) + { + if (lex_match ('(')) + { + if (inside_parens) + { + msg (SE, _("Nested parentheses not allowed.")); + goto lossage; + } + inside_parens = 1; + item = LPAREN; + } + else if (lex_match (')')) + { + if (!inside_parens) + { + msg (SE, _("Mismatched right parenthesis (`(').")); + goto lossage; + } + if (contents[n_contents - 1] == LPAREN) + { + msg (SE, _("Empty parentheses not allowed.")); + goto lossage; + } + inside_parens = 0; + item = RPAREN; + } + else + { + int content_type; + int collide_index; + + if (token != T_ID) + { + lex_error (_("in CONTENTS subcommand")); + goto lossage; + } + + content_type = string_to_content_type (tokid, + &collide_index); + if (content_type == -1) + { + lex_error (_("in CONTENTS subcommand")); + goto lossage; + } + lex_get (); + + if (collide & (1 << collide_index)) + { + msg (SE, _("Content multiply specified for %s."), + content_names[content_type]); + goto lossage; + } + collide |= (1 << collide_index); + + item = content_type; + is_per_factor[item] = inside_parens; + } + contents[n_contents++] = item; + + if (token == '/' || token == '.') + break; + } + + if (inside_parens) + { + msg (SE, _("Missing right parenthesis.")); + goto lossage; + } + contents[n_contents] = EOC; + } + else + { + lex_error (NULL); + goto lossage; + } + } + + if (token != '.') + { + lex_error (_("expecting end of command")); + goto lossage; + } + + if (!(seen & 1)) + { + msg (SE, _("Missing VARIABLES subcommand.")); + goto lossage; + } + + if (!n_contents && !explicit_rowtype) + { + msg (SW, _("CONTENTS subcommand not specified: assuming file " + "contains only CORR matrix.")); + + contents[0] = CORR; + contents[1] = EOC; + n_contents = 0; + } + + if (n_factors && !explicit_rowtype && cells == -1) + { + msg (SE, _("Missing CELLS subcommand. CELLS is required " + "when ROWTYPE_ is not given in the data and " + "factors are present.")); + goto lossage; + } + + if (explicit_rowtype && single_split) + { + msg (SE, _("Split file values must be present in the data when " + "ROWTYPE_ is present.")); + goto lossage; + } + + /* Create VARNAME_. */ + { + varname_ = force_create_variable (&default_dict, "VARNAME_", + ALPHA, 8); + varname_->p.mxd.vartype = MXD_VARNAME; + varname_->p.mxd.subtype = 0; + } + + /* Sort the dictionary variables into the desired order for the + system file output. */ + { + int i; + + qsort (default_dict.var, default_dict.nvar, sizeof *default_dict.var, + compare_variables_by_mxd_vartype); + + for (i = 0; i < default_dict.nvar; i++) + default_dict.var[i]->index = i; + } + + /* Set formats. */ + { + static const struct fmt_spec fmt_tab[MXD_COUNT] = + { + {FMT_F, 4, 0}, + {FMT_A, 8, 0}, + {FMT_F, 4, 0}, + {FMT_A, 8, 0}, + {FMT_F, 10, 4}, + }; + + int i; + + first_continuous = -1; + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + int type = v->p.mxd.vartype; + + assert (type >= 0 && type < MXD_COUNT); + v->print = v->write = fmt_tab[type]; + + if (type == MXD_CONTINUOUS) + n_continuous++; + if (first_continuous == -1 && type == MXD_CONTINUOUS) + first_continuous = i; + } + } + + if (n_continuous == 0) + { + msg (SE, _("No continuous variables specified.")); + goto lossage; + } + +#if DEBUGGING + debug_print (); +#endif + + if (explicit_rowtype) + read_matrices_with_rowtype (); + else + read_matrices_without_rowtype (); + + pool_destroy (container); + + return CMD_SUCCESS; + +lossage: + discard_variables (); + free (factors); + pool_destroy (container); + return CMD_FAILURE; +} + +/* Look up string S as a content-type name and return the + corresponding enumerated value, or -1 if there is no match. If + COLLIDE is non-NULL then *COLLIDE returns a value (suitable for use + as a bit-index) which can be used for determining whether a related + statistic has already been used. */ +static int +string_to_content_type (char *s, int *collide) +{ + static const struct + { + int value; + int collide; + const char *string; + } + *tp, + tab[] = + { + {N_VECTOR, 0, "N_VECTOR"}, + {N_VECTOR, 0, "N"}, + {N_SCALAR, 0, "N_SCALAR"}, + {N_MATRIX, 1, "N_MATRIX"}, + {MEAN, 2, "MEAN"}, + {STDDEV, 3, "STDDEV"}, + {STDDEV, 3, "SD"}, + {COUNT, 4, "COUNT"}, + {MSE, 5, "MSE"}, + {DFE, 6, "DFE"}, + {MAT, 7, "MAT"}, + {COV, 8, "COV"}, + {CORR, 9, "CORR"}, + {PROX, 10, "PROX"}, + {-1, -1, NULL}, + }; + + for (tp = tab; tp->value != -1; tp++) + if (!strcmp (s, tp->string)) + { + if (collide) + *collide = tp->collide; + + return tp->value; + } + return -1; +} + +/* Compare two variables using p.mxd.vartype and p.mxd.subtype + fields. */ +static int +compare_variables_by_mxd_vartype (const void *pa, const void *pb) +{ + struct matrix_data_proc *a = &(*((struct variable **) pa))->p.mxd; + struct matrix_data_proc *b = &(*((struct variable **) pb))->p.mxd; + + return (a->vartype != b->vartype + ? a->vartype - b->vartype + : a->subtype - b->subtype); +} + +#if DEBUGGING +/* Print out the command as input. */ +static void +debug_print (void) +{ + printf ("MATRIX DATA\n\t/VARIABLES="); + + { + int i; + + for (i = 0; i < default_dict.nvar; i++) + printf ("%s ", default_dict.var[i]->name); + } + printf ("\n"); + + printf ("\t/FORMAT="); + if (fmt == LIST) + printf ("LIST"); + else if (fmt == FREE) + printf ("FREE"); + else + assert (0); + if (section == LOWER) + printf (" LOWER"); + else if (section == UPPER) + printf (" UPPER"); + else if (section == FULL) + printf (" FULL"); + else + assert (0); + if (diag == DIAGONAL) + printf (" DIAGONAL\n"); + else if (diag == NODIAGONAL) + printf (" NODIAGONAL\n"); + else + assert (0); + + if (default_dict.n_splits) + { + int i; + + printf ("\t/SPLIT="); + for (i = 0; i < default_dict.n_splits; i++) + printf ("%s ", default_dict.splits[i]->name); + if (single_split) + printf ("\t/* single split"); + printf ("\n"); + } + + if (n_factors) + { + int i; + + printf ("\t/FACTORS="); + for (i = 0; i < n_factors; i++) + printf ("%s ", factors[i]->name); + printf ("\n"); + } + + if (cells != -1) + printf ("\t/CELLS=%d\n", cells); + + if (pop_n != -1) + printf ("\t/N=%d\n", pop_n); + + if (n_contents) + { + int i; + int space = 0; + + printf ("\t/CONTENTS="); + for (i = 0; i < n_contents; i++) + { + if (contents[i] == LPAREN) + { + if (space) + printf (" "); + printf ("("); + space = 0; + } + else if (contents[i] == RPAREN) + { + printf (")"); + space = 1; + } + else + { + + assert (contents[i] >= 0 && contents[i] <= PROX); + if (space) + printf (" "); + printf ("%s", content_names[contents[i]]); + space = 1; + } + } + printf ("\n"); + } +} +#endif /* DEBUGGING */ + +/* Matrix tokenizer. */ + +/* Matrix token types. */ +enum + { + MNULL, /* No token. */ + MNUM, /* Number. */ + MSTR, /* String. */ + MSTOP /* End of file. */ + }; + +/* Current matrix token. */ +static int mtoken; + +/* Token string if applicable; not null-terminated. */ +static char *mtokstr; + +/* Length of mtokstr in characters. */ +static int mtoklen; + +/* Token value if applicable. */ +static double mtokval; + +static int mget_token (void); + +#if DEBUGGING +#define mget_token() mget_token_dump() + +static int +mget_token_dump (void) +{ + int result = (mget_token) (); + mdump_token (); + return result; +} + +static void +mdump_token (void) +{ + switch (mtoken) + { + case MNULL: + printf (" "); + break; + case MNUM: + printf (" #%g", mtokval); + break; + case MSTR: + printf (" #'%.*s'", mtoklen, mtokstr); + break; + case MSTOP: + printf (" "); + break; + default: + assert (0); + } + fflush (stdout); +} +#endif + +/* Return the current position in the data file. */ +static const char * +context (void) +{ + static char buf[32]; + int len; + char *p = dfm_get_record (data_file, &len); + + if (!p || !len) + strcpy (buf, "at end of line"); + else + { + char *cp = buf; + int n_copy = min (10, len); + cp = stpcpy (buf, "before `"); + while (n_copy && isspace ((unsigned char) *p)) + p++, n_copy++; + while (n_copy && !isspace ((unsigned char) *p)) + *cp++ = *p++, n_copy--; + *cp++ = '\''; + *cp = 0; + } + + return buf; +} + +/* Is there at least one token left in the data file? */ +static int +another_token (void) +{ + char *cp, *ep; + int len; + + if (mtoken == MSTOP) + return 0; + + for (;;) + { + cp = dfm_get_record (data_file, &len); + if (!cp) + return 0; + + ep = cp + len; + while (isspace ((unsigned char) *cp) && cp < ep) + cp++; + + if (cp < ep) + break; + + dfm_fwd_record (data_file); + } + + dfm_set_record (data_file, cp); + + return 1; +} + +/* Parse a MATRIX DATA token from data_file into mtok*. */ +static int +(mget_token) (void) +{ + char *cp, *ep; + int len; + int first_column; + + for (;;) + { + cp = dfm_get_record (data_file, &len); + if (!cp) + { + if (mtoken == MSTOP) + return 0; + mtoken = MSTOP; + return 1; + } + + ep = cp + len; + while (isspace ((unsigned char) *cp) && cp < ep) + cp++; + + if (cp < ep) + break; + + dfm_fwd_record (data_file); + } + + dfm_set_record (data_file, cp); + first_column = dfm_get_cur_col (data_file) + 1; + + /* Three types of fields: quoted with ', quoted with ", unquoted. */ + if (*cp == '\'' || *cp == '"') + { + int quote = *cp; + + mtoken = MSTR; + mtokstr = ++cp; + while (cp < ep && *cp != quote) + cp++; + mtoklen = cp - mtokstr; + if (cp < ep) + cp++; + else + msg (SW, _("Scope of string exceeds line.")); + } + else + { + int is_num = isdigit ((unsigned char) *cp) || *cp == '.'; + + mtokstr = cp++; + while (cp < ep && !isspace ((unsigned char) *cp) && *cp != ',' + && *cp != '-' && *cp != '+') + { + if (isdigit ((unsigned char) *cp)) + is_num = 1; + + if ((tolower ((unsigned char) *cp) == 'd' + || tolower ((unsigned char) *cp) == 'e') + && (cp[1] == '+' || cp[1] == '-')) + cp += 2; + else + cp++; + } + + mtoklen = cp - mtokstr; + assert (mtoklen); + + if (is_num) + { + struct data_in di; + + di.s = mtokstr; + di.e = mtokstr + mtoklen; + di.v = (union value *) &mtokval; + di.f1 = first_column; + di.format.type = FMT_F; + di.format.w = mtoklen; + di.format.d = 0; + + if (!data_in (&di)) + return 0; + } + else + mtoken = MSTR; + } + + dfm_set_record (data_file, cp); + + return 1; +} + +/* Forcibly skip the end of a line for content type CONTENT in + data_file. */ +static int +force_eol (const char *content) +{ + char *cp; + int len; + + if (fmt == FREE) + return 1; + + cp = dfm_get_record (data_file, &len); + if (!cp) + return 0; + while (len && isspace (*cp)) + cp++, len--; + + if (len) + { + msg (SE, _("End of line expected %s while reading %s."), + context (), content); + return 0; + } + + dfm_fwd_record (data_file); + + return 1; +} + +/* Back end, omitting ROWTYPE_. */ + +/* MATRIX DATA data. */ +static double ***nr_data; + +/* Factor values. */ +static double *nr_factor_values; + +/* Largest-numbered cell that we have read in thus far, plus one. */ +static int max_cell_index; + +/* SPLIT FILE variable values. */ +static double *split_values; + +static int nr_read_splits (int compare); +static int nr_read_factors (int cell); +static void nr_output_data (void); +static int matrix_data_read_without_rowtype (void); + +/* Read from the data file and write it to the active file. */ +static void +read_matrices_without_rowtype (void) +{ + if (cells == -1) + cells = 1; + + mtoken = MNULL; + split_values = xmalloc (sizeof *split_values * default_dict.n_splits); + nr_factor_values = xmalloc (sizeof *nr_factor_values * n_factors * cells); + max_cell_index = 0; + + matrix_data_source.read = (void (*)(void)) matrix_data_read_without_rowtype; + vfm_source = &matrix_data_source; + + procedure (NULL, NULL, NULL); + + free (split_values); + free (nr_factor_values); + + fh_close_handle (data_file); +} + +/* Mirror data across the diagonal of matrix CP which contains + CONTENT type data. */ +static void +fill_matrix (int content, double *cp) +{ + int type = content_type[content]; + + if (type == 1 && section != FULL) + { + if (diag == NODIAGONAL) + { + const double fill = content == CORR ? 1.0 : SYSMIS; + int i; + + for (i = 0; i < n_continuous; i++) + cp[i * (1 + n_continuous)] = fill; + } + + { + int c, r; + + if (section == LOWER) + { + int n_lines = n_continuous; + if (section != FULL && diag == NODIAGONAL) + n_lines--; + + for (r = 1; r < n_lines; r++) + for (c = 0; c < r; c++) + cp[r + c * n_continuous] = cp[c + r * n_continuous]; + } + else + { + assert (section == UPPER); + for (r = 1; r < n_continuous; r++) + for (c = 0; c < r; c++) + cp[c + r * n_continuous] = cp[r + c * n_continuous]; + } + } + } + else if (type == 2) + { + int c; + + for (c = 1; c < n_continuous; c++) + cp[c] = cp[0]; + } +} + +/* Read data lines for content type CONTENT from the data file. If + PER_FACTOR is nonzero, then factor information is read from the + data file. Data is for cell number CELL. */ +static int +nr_read_data_lines (int per_factor, int cell, int content, int compare) +{ + /* Content type. */ + const int type = content_type[content]; + + /* Number of lines that must be parsed from the data file for this + content type. */ + int n_lines; + + /* Current position in vector or matrix. */ + double *cp; + + /* Counter. */ + int i; + + if (type != 1) + n_lines = 1; + else + { + n_lines = n_continuous; + if (section != FULL && diag == NODIAGONAL) + n_lines--; + } + + cp = nr_data[content][cell]; + if (type == 1 && section == LOWER && diag == NODIAGONAL) + cp += n_continuous; + + for (i = 0; i < n_lines; i++) + { + int n_cols; + + if (!nr_read_splits (1)) + return 0; + if (per_factor && !nr_read_factors (cell)) + return 0; + compare = 1; + + switch (type) + { + case 0: + n_cols = n_continuous; + break; + case 1: + switch (section) + { + case LOWER: + n_cols = i + 1; + break; + case UPPER: + cp += i; + n_cols = n_continuous - i; + if (diag == NODIAGONAL) + { + n_cols--; + cp++; + } + break; + case FULL: + n_cols = n_continuous; + break; + default: + assert (0); + } + break; + case 2: + n_cols = 1; + break; + default: + assert (0); + } + + { + int j; + + for (j = 0; j < n_cols; j++) + { + if (!mget_token ()) + return 0; + if (mtoken != MNUM) + { + msg (SE, _("expecting value for %s %s"), + default_dict.var[j]->name, context ()); + return 0; + } + + *cp++ = mtokval; + } + if (!force_eol (content_names[content])) + return 0; + debug_printf (("\n")); + } + + if (section == LOWER) + cp += n_continuous - n_cols; + } + + fill_matrix (content, nr_data[content][cell]); + + return 1; +} + +/* When ROWTYPE_ does not appear in the data, reads the matrices and + writes them to the output file. Returns success. */ +static int +matrix_data_read_without_rowtype (void) +{ + { + int *cp; + + nr_data = pool_alloc (container, (PROX + 1) * sizeof *nr_data); + + { + int i; + + for (i = 0; i <= PROX; i++) + nr_data[i] = NULL; + } + + for (cp = contents; *cp != EOC; cp++) + if (*cp != LPAREN && *cp != RPAREN) + { + int per_factor = is_per_factor[*cp]; + int n_entries; + + n_entries = n_continuous; + if (content_type[*cp] == 1) + n_entries *= n_continuous; + + { + int n_vectors = per_factor ? cells : 1; + int i; + + nr_data[*cp] = pool_alloc (container, + n_vectors * sizeof **nr_data); + + for (i = 0; i < n_vectors; i++) + nr_data[*cp][i] = pool_alloc (container, + n_entries * sizeof ***nr_data); + } + } + } + + for (;;) + { + int *bp, *ep, *np; + + if (!nr_read_splits (0)) + return 0; + + for (bp = contents; *bp != EOC; bp = np) + { + int per_factor; + + /* Trap the CONTENTS that we should parse in this pass + between bp and ep. Set np to the starting bp for next + iteration. */ + if (*bp == LPAREN) + { + ep = ++bp; + while (*ep != RPAREN) + ep++; + np = &ep[1]; + per_factor = 1; + } + else + { + ep = &bp[1]; + while (*ep != EOC && *ep != LPAREN) + ep++; + np = ep; + per_factor = 0; + } + + { + int i; + + for (i = 0; i < (per_factor ? cells : 1); i++) + { + int *cp; + + for (cp = bp; cp < ep; cp++) + if (!nr_read_data_lines (per_factor, i, *cp, cp != bp)) + return 0; + } + } + } + + nr_output_data (); + + if (default_dict.n_splits == 0 || !another_token ()) + return 1; + } +} + +/* Read the split file variables. If COMPARE is 1, compares the + values read to the last values read and returns 1 if they're equal, + 0 otherwise. */ +static int +nr_read_splits (int compare) +{ + static int just_read = 0; + + if (compare && just_read) + { + just_read = 0; + return 1; + } + + if (default_dict.n_splits == 0) + return 1; + + if (single_split) + { + if (!compare) + split_values[0] = ++default_dict.splits[0]->p.mxd.subtype; + return 1; + } + + if (!compare) + just_read = 1; + + { + int i; + + for (i = 0; i < default_dict.n_splits; i++) + { + if (!mget_token ()) + return 0; + if (mtoken != MNUM) + { + msg (SE, _("Syntax error expecting SPLIT FILE value %s."), + context ()); + return 0; + } + + if (!compare) + split_values[i] = mtokval; + else if (split_values[i] != mtokval) + { + msg (SE, _("Expecting value %g for %s."), + split_values[i], default_dict.splits[i]->name); + return 0; + } + } + } + + return 1; +} + +/* Read the factors for cell CELL. If COMPARE is 1, compares the + values read to the last values read and returns 1 if they're equal, + 0 otherwise. */ +static int +nr_read_factors (int cell) +{ + int compare; + + if (n_factors == 0) + return 1; + + assert (max_cell_index >= cell); + if (cell != max_cell_index) + compare = 1; + else + { + compare = 0; + max_cell_index++; + } + + { + int i; + + for (i = 0; i < n_factors; i++) + { + if (!mget_token ()) + return 0; + if (mtoken != MNUM) + { + msg (SE, _("Syntax error expecting factor value %s."), + context ()); + return 0; + } + + if (!compare) + nr_factor_values[i + n_factors * cell] = mtokval; + else if (nr_factor_values[i + n_factors * cell] != mtokval) + { + msg (SE, _("Syntax error expecting value %g for %s %s."), + nr_factor_values[i + n_factors * cell], + factors[i]->name, context ()); + return 0; + } + } + } + + return 1; +} + +/* Write the contents of a cell having content type CONTENT and data + CP to the active file. */ +static void +dump_cell_content (int content, double *cp) +{ + int type = content_type[content]; + + { + st_bare_pad_copy (temp_case->data[rowtype_->fv].s, + content_names[content], 8); + + if (type != 1) + memset (&temp_case->data[varname_->fv].s, ' ', 8); + } + + { + int n_lines = (type == 1) ? n_continuous : 1; + int i; + + for (i = 0; i < n_lines; i++) + { + int j; + + for (j = 0; j < n_continuous; j++) + { + temp_case->data[(default_dict.var + [first_continuous + j]->fv)].f = *cp; + debug_printf (("c:%s(%g) ", + default_dict.var[first_continuous + j]->name, + *cp)); + cp++; + } + if (type == 1) + st_bare_pad_copy (temp_case->data[varname_->fv].s, + default_dict.var[first_continuous + i]->name, + 8); + debug_printf (("\n")); + write_case (); + } + } +} + +/* Finally dump out everything from nr_data[] to the output file. */ +static void +nr_output_data (void) +{ + { + int i; + + for (i = 0; i < default_dict.n_splits; i++) + temp_case->data[default_dict.splits[i]->fv].f = split_values[i]; + } + + if (n_factors) + { + int cell; + + for (cell = 0; cell < cells; cell++) + { + { + int factor; + + for (factor = 0; factor < n_factors; factor++) + { + temp_case->data[factors[factor]->fv].f + = nr_factor_values[factor + cell * n_factors]; + debug_printf (("f:%s ", factors[factor]->name)); + } + } + + { + int content; + + for (content = 0; content <= PROX; content++) + if (is_per_factor[content]) + { + assert (nr_data[content] != NULL + && nr_data[content][cell] != NULL); + + dump_cell_content (content, nr_data[content][cell]); + } + } + } + } + + { + int content; + + { + int factor; + + for (factor = 0; factor < n_factors; factor++) + temp_case->data[factors[factor]->fv].f = SYSMIS; + } + + for (content = 0; content <= PROX; content++) + if (!is_per_factor[content] && nr_data[content] != NULL) + dump_cell_content (content, nr_data[content][0]); + } +} + +/* Back end, with ROWTYPE_. */ + +/* Type of current row. */ +static int wr_content; + +/* All the data for one set of factor values. */ +struct factor_data + { + double *factors; + int n_rows[PROX + 1]; + double *data[PROX + 1]; + struct factor_data *next; + }; + +/* All the data, period. */ +struct factor_data *wr_data; + +/* Current factor. */ +struct factor_data *wr_current; + +static int wr_read_splits (void); +static int wr_output_data (void); +static int wr_read_rowtype (void); +static int wr_read_factors (void); +static int wr_read_indeps (void); +static int matrix_data_read_with_rowtype (void); + +/* When ROWTYPE_ appears in the data, reads the matrices and writes + them to the output file. */ +static void +read_matrices_with_rowtype (void) +{ + mtoken = MNULL; + wr_data = wr_current = NULL; + split_values = NULL; + cells = 0; + + matrix_data_source.read = (void (*)(void)) matrix_data_read_with_rowtype; + vfm_source = &matrix_data_source; + + procedure (NULL, NULL, NULL); + + free (split_values); + fh_close_handle (data_file); +} + +/* Read from the data file and write it to the active file. */ +static int +matrix_data_read_with_rowtype (void) +{ + do + { + if (!wr_read_splits ()) + return 0; + + if (!wr_read_factors ()) + return 0; + + if (!wr_read_indeps ()) + return 0; + } + while (another_token ()); + + wr_output_data (); + return 1; +} + +/* Read the split file variables. If they differ from the previous + set of split variables then output the data. Returns success. */ +static int +wr_read_splits (void) +{ + int compare; + + if (default_dict.n_splits == 0) + return 1; + + if (split_values) + compare = 1; + else + { + compare = 0; + split_values = xmalloc (sizeof *split_values * default_dict.n_splits); + } + + { + int different = 0; + int i; + + for (i = 0; i < default_dict.n_splits; i++) + { + if (!mget_token ()) + return 0; + if (mtoken != MNUM) + { + msg (SE, _("Syntax error %s expecting SPLIT FILE value."), + context ()); + return 0; + } + + if (compare && split_values[i] != mtokval && !different) + { + if (!wr_output_data ()) + return 0; + different = 1; + cells = 0; + } + split_values[i] = mtokval; + } + } + + return 1; +} + +/* Return strcmp()-type comparison of the n_factors factors at _A and + _B. Sort missing values toward the end. */ +static int +compare_factors (const void *pa, const void *pb) +{ + const double *a = (*(struct factor_data **) pa)->factors; + const double *b = (*(struct factor_data **) pb)->factors; + int i; + + for (i = 0; i < n_factors; i++, a++, b++) + { + if (*a == *b) + continue; + + if (*a == SYSMIS) + return 1; + else if (*b == SYSMIS) + return -1; + else + return *a - *b < 0 ? -1 : 1; + } + + return 0; +} + +/* Write out the data for the current split file to the active + file. */ +static int +wr_output_data (void) +{ + { + int i; + + for (i = 0; i < default_dict.n_splits; i++) + temp_case->data[default_dict.splits[i]->fv].f = split_values[i]; + } + + /* Sort the wr_data list. */ + { + struct factor_data **factors; + struct factor_data *iter; + int i; + + factors = xmalloc (sizeof *factors * cells); + + for (i = 0, iter = wr_data; iter; iter = iter->next, i++) + factors[i] = iter; + + qsort (factors, cells, sizeof *factors, compare_factors); + + wr_data = factors[0]; + for (i = 0; i < cells - 1; i++) + factors[i]->next = factors[i + 1]; + factors[cells - 1]->next = NULL; + + free (factors); + } + + /* Write out records for every set of factor values. */ + { + struct factor_data *iter; + + for (iter = wr_data; iter; iter = iter->next) + { + { + int factor; + + for (factor = 0; factor < n_factors; factor++) + { + temp_case->data[factors[factor]->fv].f + = iter->factors[factor]; + debug_printf (("f:%s ", factors[factor]->name)); + } + } + + { + int content; + + for (content = 0; content <= PROX; content++) + { + if (!iter->n_rows[content]) + continue; + + { + int type = content_type[content]; + int n_lines = (type == 1 + ? (n_continuous + - (section != FULL && diag == NODIAGONAL)) + : 1); + + if (n_lines != iter->n_rows[content]) + { + msg (SE, _("Expected %d lines of data for %s content; " + "actually saw %d lines. No data will be " + "output for this content."), + n_lines, content_names[content], + iter->n_rows[content]); + continue; + } + } + + fill_matrix (content, iter->data[content]); + + dump_cell_content (content, iter->data[content]); + } + } + } + } + + pool_destroy (container); + container = pool_create (); + + wr_data = wr_current = NULL; + + return 1; +} + +/* Read ROWTYPE_ from the data file. Return success. */ +static int +wr_read_rowtype (void) +{ + if (wr_content != -1) + { + msg (SE, _("Multiply specified ROWTYPE_ %s."), context ()); + return 0; + } + if (mtoken != MSTR) + { + msg (SE, _("Syntax error %s expecting ROWTYPE_ string."), context ()); + return 0; + } + + { + char s[16]; + char *cp; + + memcpy (s, mtokstr, min (15, mtoklen)); + s[min (15, mtoklen)] = 0; + + for (cp = s; *cp; cp++) + *cp = toupper ((unsigned char) *cp); + + wr_content = string_to_content_type (s, NULL); + } + + if (wr_content == -1) + { + msg (SE, _("Syntax error %s."), context ()); + return 0; + } + + return 1; +} + +/* Read the factors for the current row. Select a set of factors and + point wr_current to it. */ +static int +wr_read_factors (void) +{ + double *factor_values = local_alloc (sizeof *factor_values * n_factors); + + wr_content = -1; + { + int i; + + for (i = 0; i < n_factors; i++) + { + if (!mget_token ()) + goto lossage; + if (mtoken == MSTR) + { + if (!wr_read_rowtype ()) + goto lossage; + if (!mget_token ()) + goto lossage; + } + if (mtoken != MNUM) + { + msg (SE, _("Syntax error expecting factor value %s."), + context ()); + goto lossage; + } + + factor_values[i] = mtokval; + } + } + if (wr_content == -1) + { + if (!mget_token ()) + goto lossage; + if (!wr_read_rowtype ()) + goto lossage; + } + + /* Try the most recent factor first as a simple caching + mechanism. */ + if (wr_current) + { + int i; + + for (i = 0; i < n_factors; i++) + if (factor_values[i] != wr_current->factors[i]) + goto cache_miss; + goto winnage; + } + + /* Linear search through the list. */ +cache_miss: + { + struct factor_data *iter; + + for (iter = wr_data; iter; iter = iter->next) + { + int i; + + for (i = 0; i < n_factors; i++) + if (factor_values[i] != iter->factors[i]) + goto next_item; + + wr_current = iter; + goto winnage; + + next_item: ; + } + } + + /* Not found. Make a new item. */ + { + struct factor_data *new = pool_alloc (container, sizeof *new); + + new->factors = pool_alloc (container, sizeof *new->factors * n_factors); + + { + int i; + + for (i = 0; i < n_factors; i++) + new->factors[i] = factor_values[i]; + } + + { + int i; + + for (i = 0; i <= PROX; i++) + { + new->n_rows[i] = 0; + new->data[i] = NULL; + } + } + + new->next = wr_data; + wr_data = wr_current = new; + cells++; + } + +winnage: + local_free (factor_values); + return 1; + +lossage: + local_free (factor_values); + return 0; +} + +/* Read the independent variables into wr_current. */ +static int +wr_read_indeps (void) +{ + struct factor_data *c = wr_current; + const int type = content_type[wr_content]; + const int n_rows = c->n_rows[wr_content]; + double *cp; + int n_cols; + + /* Allocate room for data if necessary. */ + if (c->data[wr_content] == NULL) + { + int n_items = n_continuous; + if (type == 1) + n_items *= n_continuous; + + c->data[wr_content] = pool_alloc (container, + sizeof **c->data * n_items); + } + + cp = &c->data[wr_content][n_rows * n_continuous]; + + /* Figure out how much to read from this line. */ + switch (type) + { + case 0: + case 2: + if (n_rows > 0) + { + msg (SE, _("Duplicate specification for %s."), + content_names[wr_content]); + return 0; + } + if (type == 0) + n_cols = n_continuous; + else + n_cols = 1; + break; + case 1: + if (n_rows >= n_continuous - (section != FULL && diag == NODIAGONAL)) + { + msg (SE, _("Too many rows of matrix data for %s."), + content_names[wr_content]); + return 0; + } + + switch (section) + { + case LOWER: + n_cols = n_rows + 1; + if (diag == NODIAGONAL) + cp += n_continuous; + break; + case UPPER: + cp += n_rows; + n_cols = n_continuous - n_rows; + if (diag == NODIAGONAL) + { + n_cols--; + cp++; + } + break; + case FULL: + n_cols = n_continuous; + break; + default: + assert (0); + } + break; + default: + assert (0); + } + c->n_rows[wr_content]++; + + debug_printf ((" (c=%p,r=%d,n=%d)", c, n_rows + 1, n_cols)); + + /* Read N_COLS items at CP. */ + { + int j; + + for (j = 0; j < n_cols; j++) + { + if (!mget_token ()) + return 0; + if (mtoken != MNUM) + { + msg (SE, _("Syntax error expecting value for %s %s."), + default_dict.var[first_continuous + j]->name, context ()); + return 0; + } + + *cp++ = mtokval; + } + if (!force_eol (content_names[wr_content])) + return 0; + debug_printf (("\n")); + } + + return 1; +} + +/* Matrix source. */ + +struct case_stream matrix_data_source = + { + NULL, + NULL, + NULL, + NULL, + NULL, + NULL, + "MATRIX DATA", + }; + diff --git a/src/matrix.c b/src/matrix.c new file mode 100644 index 00000000..7e474677 --- /dev/null +++ b/src/matrix.c @@ -0,0 +1,302 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "matrix.h" + +/* Kahan summation formula, Thm. 8, _What Every Computer Scientist + Should Know About Floating-Point Arithmetic_, David Goldberg, + orig. March 1991 issue of Computing Surveys, also at + . + Hopefully your compiler won't try to optimize the code below too + much, because that will ruin the precision. */ +#define KAHAN_SUMMATION_FORMULA(S) \ + do \ + { \ + double S_c; \ + int S_j; \ + \ + S = SUMMATION_ELEMENT (0); \ + S_c = 0.; \ + for (S_j = 1; S_j < SUMMATION_COUNT; S_j++) \ + { \ + double S_y = SUMMATION_ELEMENT (S_j) - S_c; \ + double S_t = S + S_y; \ + S_c = (S_t - S) - S_y; \ + S = S_t; \ + } \ + } \ + while (0) + + +/* Vectors. */ + +/* Allocate a new vector of length N. */ +struct vector * +vec_alloc (int n) +{ + struct vector *vec = xmalloc (sizeof *vec); + vec->data = xmalloc (sizeof *vec->data * n); + vec->n = vec->m = n; + return vec; +} + +/* Change the length of VEC to N. The amount of space allocated will + not be lowered, but may be enlarged. */ +void +vec_realloc (struct vector *vec, int n) +{ + if (n < vec->m) + { + vec->m = n; + vec->data = xrealloc (vec->data, sizeof *vec->data * n); + } + vec->n = n; +} + +/* Free vector VEC. */ +void +vec_free (struct vector *vec) +{ + free (vec->data); + free (vec); +} + +/* Set the values in vector VEC to constant VALUE. */ +#if 0 +void +vec_init (struct vector *vec, double value) +{ + double *p; + int i; + + p = vec->data; + for (i = 0; i < vec->n; i++) + *p++ = value; +} +#endif + +/* Print out vector VEC to stdout for debugging purposes. */ +#if GLOBAL_DEBUGGING +#include +#include "settings.h" + +void +vec_print (const struct vector *vec) +{ + int i; + + for (i = 0; i < vec->n; i++) + { + if (i % ((set_viewwidth - 4) / 8) == 0) + { + if (i) + putchar ('\n'); + printf ("%3d:", i); + } + + printf ("%8g", vec_elem (vec, i)); + } +} +#endif + +/* Return the sum of the values in VEC. */ +double +vec_total (const struct vector *vec) +{ + double sum; + +#define SUMMATION_COUNT (vec->n) +#define SUMMATION_ELEMENT(INDEX) (vec_elem (vec, (INDEX))) + KAHAN_SUMMATION_FORMULA (sum); +#undef SUMMATION_COUNT +#undef SUMMATION_ELEMENT + + return sum; +} + +/* Matrices. */ + +/* Allocate a new matrix with NR rows and NC columns. */ +struct matrix * +mat_alloc (int nr, int nc) +{ + struct matrix *mat = xmalloc (sizeof *mat); + mat->nr = nr; + mat->nc = nc; + mat->m = nr * nc; + mat->data = xmalloc (sizeof *mat->data * nr * nc); + return mat; +} + +/* Set the size of matrix MAT to NR rows and NC columns. The matrix + data array will be enlarged if necessary but will not be shrunk. */ +void +mat_realloc (struct matrix *mat, int nr, int nc) +{ + if (nc * nr > mat->m) + { + mat->m = nc * nr; + mat->data = xrealloc (mat->data, sizeof *mat->data * mat->m); + } + mat->nr = nr; + mat->nc = nc; +} + +/* Free matrix MAT. */ +void +mat_free (struct matrix *mat) +{ + free (mat->data); + free (mat); +} + +/* Set all matrix MAT entries to VALUE. */ +void +mat_init (struct matrix *mat, double value) +{ + double *p; + int i; + + p = mat->data; + for (i = 0; i < mat->nr * mat->nc; i++) + *p++ = value; +} + +/* Set all MAT entries in row R to VALUE. */ +void +mat_init_row (struct matrix *mat, int r, double value) +{ + double *p; + int i; + + p = &mat_elem (mat, r, 0); + for (i = 0; i < mat->nc; i++) + *p++ = value; +} + +/* Set all MAT entries in column C to VALUE. */ +void +mat_init_col (struct matrix *mat, int c, double value) +{ + double *p; + int i; + + p = &mat_elem (mat, 0, c); + for (i = 0; i < mat->nr; i++) + { + *p = value; + p += mat->nc; + } +} + +/* Print out MAT entries to stdout, optionally with row and column + labels ROW_LABELS and COL_LABELS. */ +#if GLOBAL_DEBUGGING +void +mat_print (const struct matrix *mat, + const struct vector *row_labels, + const struct vector *col_labels) +{ + int r, c; + + assert (!row_labels || row_labels->n == mat->nr); + if (col_labels) + { + int c; + + assert (col_labels->n == mat->nc); + if (row_labels) + printf (" "); + for (c = 0; c < mat->nc; c++) + printf ("%8g", vec_elem (col_labels, c)); + } + + for (r = 0; r < mat->nr; r++) + { + if (row_labels) + printf ("%8g:", vec_elem (row_labels, r)); + for (c = 0; c < mat->nc; c++) + printf ("%8g", mat_elem (mat, r, c)); + putchar ('\n'); + } +} +#endif /* GLOBAL_DEBUGGING */ + +/* Calculate row totals for matrix MAT into vector ROW_TOTS. */ +void +mat_row_totals (const struct matrix *mat, struct vector *row_tots) +{ + int r; + + vec_realloc (row_tots, mat->nr); + for (r = 0; r < mat->nr; r++) + { + double sum; + +#define SUMMATION_COUNT (mat->nc) +#define SUMMATION_ELEMENT(INDEX) (mat_elem (mat, r, INDEX)) + KAHAN_SUMMATION_FORMULA (sum); +#undef SUMMATION_COUNT +#undef SUMMATION_ELEMENT + + vec_elem (row_tots, r) = sum; + } +} + +/* Calculate column totals for matrix MAT into vector COL_TOTS. */ +void +mat_col_totals (const struct matrix *mat, struct vector *col_tots) +{ + int c; + + vec_realloc (col_tots, mat->nc); + for (c = 0; c < mat->nc; c++) + { + double sum; + +#define SUMMATION_COUNT (mat->nr) +#define SUMMATION_ELEMENT(INDEX) (mat_elem (mat, INDEX, c)) + KAHAN_SUMMATION_FORMULA (sum); +#undef SUMMATION_COUNT +#undef SUMMATION_ELEMENT + + vec_elem (col_tots, c) = sum; + } +} + +/* Return the grand total for matrix MAT. Of course, if you're also + calculating column or row totals, it would be faster to use + vec_total on one of those sets of totals. */ +double +mat_grand_total (const struct matrix *mat) +{ + double sum; + +#define SUMMATION_COUNT (mat->nr * mat->nc) +#define SUMMATION_ELEMENT(INDEX) (mat->data[INDEX]) + KAHAN_SUMMATION_FORMULA (sum); +#undef SUMMATION_COUNT +#undef SUMMATION_ELEMENT + + return sum; +} diff --git a/src/matrix.h b/src/matrix.h new file mode 100644 index 00000000..c1e5c612 --- /dev/null +++ b/src/matrix.h @@ -0,0 +1,96 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !matrix_h +#define matrix_h 1 + +/* Vector representation. */ +struct vector + { + int n; + int m; + double *data; + }; + +/* Allocate vectors. */ +struct vector *vec_alloc (int n); +void vec_realloc (struct vector *, int n); +void vec_free (struct vector *); + +/* Vector elements. */ +#define vec_elem(VEC, INDEX) ((VEC)->data[INDEX]) + +/* Set the vector to a constant value. */ +void vec_init (struct vector *, double); + +/* Print out the vector to stdout. */ +#if GLOBAL_DEBUGGING +void vec_print (const struct vector *); +#endif + +/* Sum the vector values. */ +double vec_total (const struct vector *); + +/* Matrix representation. */ +struct matrix + { + int nr, nc; + int m; + double *data; + }; + +/* Allocate matrices. */ +struct matrix *mat_alloc (int nr, int nc); +void mat_realloc (struct matrix *, int nr, int nc); +void mat_free (struct matrix *); + +/* Matrix elements. */ +#define mat_elem(MAT, R, C) ((MAT)->data[(C) + (R) * (MAT)->nc]) + +/* Set matrix values to a constant. */ +void mat_init (struct matrix *, double); +void mat_init_row (struct matrix *, int r, double); +void mat_init_col (struct matrix *, int c, double); + +/* Print out the matrix values to stdout, optionally with row and + column labels (for debugging purposes). */ +#if GLOBAL_DEBUGGING +void mat_print (const struct matrix *, + const struct vector *row_labels, const struct vector *col_labels); +#endif + +/* Sum matrix values. */ +void mat_row_totals (const struct matrix *, struct vector *row_tots); +void mat_col_totals (const struct matrix *, struct vector *col_tots); +double mat_grand_total (const struct matrix *); + +/* Chi-square statistics. */ +enum + { + CHISQ_PEARSON, + CHISQ_LIKELIHOOD_RATIO, + CHISQ_FISHER, + CHISQ_CC, + CHISQ_LINEAR, + N_CHISQ + }; + +void mat_chisq (const struct matrix *, double chisq[N_CHISQ], int df[N_CHISQ]); + +#endif /* matrix_h */ diff --git a/src/means.q b/src/means.q new file mode 100644 index 00000000..99432a35 --- /dev/null +++ b/src/means.q @@ -0,0 +1,409 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "magic.h" +#include "var.h" +/* (headers) */ + +#undef DEBUGGING +#define DEBUGGING 1 +#include "debug-print.h" + +/* (specification) + means (mns_): + *tables=custom; + +variables=custom; + +crossbreak=custom; + +format=lab:!labels/nolabels/nocatlabs, + name:!names/nonames, + val:!values/novalues, + fmt:!table/tree; + +missing=miss:!table/include/dependent; + +cells[cl_]=default,count,sum,mean,stddev,variance,all; + +statistics[st_]=anova,linearity,all,none. +*/ +/* (declarations) */ +/* (functions) */ + +#if DEBUGGING +static void debug_print (struct cmd_means *cmd); +#endif + +/* TABLES: Variable lists for each dimension. */ +int n_dim; /* Number of dimensions. */ +int *nv_dim; /* Number of variables in each dimension. */ +struct variable ***v_dim; /* Variables in each dimension. */ + +/* VARIABLES: List of variables. */ +int n_var; +struct variable **v_var; + +/* Parses and executes the T-TEST procedure. */ +int +cmd_means (void) +{ + struct cmd_means cmd; + int success = CMD_FAILURE; + + n_dim = 0; + nv_dim = NULL; + v_dim = NULL; + v_var = NULL; + + lex_match_id ("MEANS"); + if (!parse_means (&cmd)) + goto free; + + if (cmd.sbc_cells) + { + int i; + for (i = 0; i < MNS_CL_count; i++) + if (cmd.a_cells[i]) + break; + if (i >= MNS_CL_count) + cmd.a_cells[MNS_CL_ALL] = 1; + } + else + cmd.a_cells[MNS_CL_DEFAULT] = 1; + if (cmd.a_cells[MNS_CL_DEFAULT] || cmd.a_cells[MNS_CL_ALL]) + cmd.a_cells[MNS_CL_MEAN] = cmd.a_cells[MNS_CL_STDDEV] = cmd.a_cells[MNS_CL_COUNT] = 1; + if (cmd.a_cells[MNS_CL_ALL]) + cmd.a_cells[MNS_CL_SUM] = cmd.a_cells[MNS_CL_VARIANCE] = 1; + + if (cmd.sbc_statistics) + { + if (!cmd.a_statistics[MNS_ST_ANOVA] && !cmd.a_statistics[MNS_ST_LINEARITY]) + cmd.a_statistics[MNS_ST_ANOVA] = 1; + if (cmd.a_statistics[MNS_ST_ALL]) + cmd.a_statistics[MNS_ST_ANOVA] = cmd.a_statistics[MNS_ST_LINEARITY] = 1; + } + + if (!cmd.sbc_tables) + { + msg (SE, _("Missing required subcommand TABLES.")); + goto free; + } + +#if DEBUGGING + debug_print (&cmd); +#endif + + success = CMD_SUCCESS; + +free: + { + int i; + + for (i = 0; i < n_dim; i++) + free (v_dim[i]); + free (nv_dim); + free (v_dim); + free (v_var); + } + + return success; +} + +/* Returns nonzero only if value V is valid as an endpoint for a + dependent variable in integer mode. */ +int +validate_dependent_endpoint (double V) +{ + return V == (int) V && V != LOWEST && V != HIGHEST; +} + +/* Parses the TABLES subcommand. */ +static int +mns_custom_tables (struct cmd_means *cmd) +{ + struct dictionary *dict; + struct dictionary temp_dict; + + if (!lex_match_id ("TABLES") + && (token != T_ID || !is_varname (tokid)) + && token != T_ALL) + return 2; + lex_match ('='); + + if (cmd->sbc_tables || cmd->sbc_crossbreak) + { + msg (SE, _("TABLES or CROSSBREAK subcommand may not appear more " + "than once.")); + return 0; + } + + if (cmd->sbc_variables) + { + dict = &temp_dict; + temp_dict.var = v_var; + temp_dict.nvar = n_var; + + { + int i; + + temp_dict.var_by_name = avl_create (NULL, cmp_variable, NULL); + for (i = 0; i < temp_dict.nvar; i++) + avl_force_insert (temp_dict.var_by_name, temp_dict.var[i]); + } + } + else + dict = &default_dict; + + do + { + int nvl; + struct variable **vl; + + if (!parse_variables (dict, &vl, &nvl, PV_NO_DUPLICATE | PV_NO_SCRATCH)) + return 0; + + n_dim++; + nv_dim = xrealloc (nv_dim, n_dim * sizeof (int)); + v_dim = xrealloc (v_dim, n_dim * sizeof (struct variable **)); + + nv_dim[n_dim - 1] = nvl; + v_dim[n_dim - 1] = vl; + + if (cmd->sbc_variables) + { + int i; + + for (i = 0; i < nv_dim[0]; i++) + { + struct means_proc *v_inf = &v_dim[0][i]->p.mns; + + if (v_inf->min == SYSMIS) + { + msg (SE, _("Variable %s specified on TABLES or " + "CROSSBREAK, but not specified on " + "VARIABLES."), + v_dim[0][i]->name); + return 0; + } + + if (n_dim == 1) + { + v_inf->min = (int) v_inf->min; + v_inf->max = (int) v_inf->max; + } else { + if (v_inf->min == LOWEST || v_inf->max == HIGHEST) + { + msg (SE, _("LOWEST and HIGHEST may not be used " + "for independent variables (%s)."), + v_dim[0][i]->name); + return 0; + } + if (v_inf->min != (int) v_inf->min + || v_inf->max != (int) v_inf->max) + { + msg (SE, _("Independent variables (%s) may not " + "have noninteger endpoints in their " + "ranges."), + v_dim[0][i]->name); + return 0; + } + } + } + } + } + while (lex_match (T_BY)); + + /* Check for duplicates. */ + { + int i; + + for (i = 0; i < default_dict.nvar; i++) + default_dict.var[i]->foo = 0; + for (i = 0; i < dict->nvar; i++) + if (dict->var[i]->foo++) + { + msg (SE, _("Variable %s is multiply specified on TABLES " + "or CROSSBREAK."), + dict->var[i]->name); + return 0; + } + } + + if (cmd->sbc_variables) + avl_destroy (temp_dict.var_by_name, NULL); + + return 1; +} + +/* Parse CROSSBREAK subcommand. */ +static int +mns_custom_crossbreak (struct cmd_means *cmd) +{ + return mns_custom_tables (cmd); +} + +/* Parses the VARIABLES subcommand. */ +static int +mns_custom_variables (struct cmd_means *cmd) +{ + if (cmd->sbc_tables) + { + msg (SE, _("VARIABLES must precede TABLES.")); + return 0; + } + + if (cmd->sbc_variables == 1) + { + int i; + + for (i = 0; i < default_dict.nvar; i++) + default_dict.var[i]->p.mns.min = SYSMIS; + } + + do + { + int orig_n = n_var; + + double min, max; + + if (!parse_variables (&default_dict, &v_var, &n_var, + PV_APPEND | PV_NO_DUPLICATE | PV_NO_SCRATCH)) + return 0; + + if (!lex_force_match ('(')) + return 0; + + /* Lower value. */ + if (token == T_ID + && (!strcmp (tokid, "LO") || lex_id_match ("LOWEST", tokid))) + min = LOWEST; + else + { + if (!lex_force_num ()) + return 0; + min = tokval; + } + lex_get (); + + lex_match (','); + + /* Higher value. */ + if (token == T_ID + && (!strcmp (tokid, "HI") || lex_id_match ("HIGHEST", tokid))) + max = HIGHEST; + else + { + if (!lex_force_num ()) + return 0; + max = tokval; + } + lex_get (); + + if (!lex_force_match (')')) + return 0; + + /* Range check. */ + if (max < min) + { + msg (SE, _("Upper value (%g) is less than lower value " + "(%g) on VARIABLES subcommand."), max, min); + return 0; + } + + { + int i; + + for (i = orig_n; i < n_var; i++) + { + struct means_proc *v_inf = &v_var[i]->p.mns; + + v_inf->min = min; + v_inf->max = max; + } + } + } + while (token != '/' && token != '.'); + + return 1; +} + +#if DEBUGGING +static void +debug_print (struct cmd_means *cmd) +{ + int i; + + printf ("MEANS"); + + if (cmd->sbc_variables) + { + int j = 0; + + printf (" VARIABLES="); + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + + if (v->p.mns.min == SYSMIS) + continue; + if (j++) + printf (" "); + printf ("%s(", v->name); + if (v->p.mns.min == LOWEST) + printf ("LO"); + else + printf ("%g", v->p.mns.min); + printf (","); + if (v->p.mns.max == HIGHEST) + printf ("HI"); + else + printf ("%g", v->p.mns.max); + printf (")"); + } + printf ("\n"); + } + + printf (" TABLES="); + for (i = 0; i < n_dim; i++) + { + int j; + + if (i) + printf (" BY"); + + for (j = 0; j < nv_dim[i]; j++) + { + if (i || j) + printf (" "); + printf (v_dim[i][j]->name); + } + } + printf ("\n"); +} +#endif /* DEBUGGING */ + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/mis-val.c b/src/mis-val.c new file mode 100644 index 00000000..a048e405 --- /dev/null +++ b/src/mis-val.c @@ -0,0 +1,409 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "magic.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +static void debug_print (); +#endif + +/* Variables on MIS VAL. */ +static struct variable **v; +static int nv; + +/* Type of the variables on MIS VAL. */ +static int type; + +/* Width of string variables on MIS VAL. */ +static size_t width; + +/* Items to fill-in var structs with. */ +static int miss_type; +static union value missing[3]; + +static int parse_varnames (void); +static int parse_numeric (void); +static int parse_alpha (void); + +int +cmd_missing_values (void) +{ + int i; + + lex_match_id ("MISSING"); + lex_match_id ("VALUES"); + while (token != '.') + { +#if __CHECKER__ + memset (missing, 0, sizeof missing); +#endif + + if (!parse_varnames ()) + goto fail; + + if (token != ')') + { + if ((type == NUMERIC && !parse_numeric ()) + || (type == ALPHA && !parse_alpha ())) + goto fail; + } + else + miss_type = MISSING_NONE; + + if (!lex_match (')')) + { + msg (SE, _("`)' expected after value specification.")); + goto fail; + } + + for (i = 0; i < nv; i++) + { + v[i]->miss_type = miss_type; + memcpy (v[i]->missing, missing, sizeof v[i]->missing); + } + + lex_match ('/'); + free (v); + } + +#if DEBUGGING + debug_print (); +#endif + + return lex_end_of_command (); + +fail: + free (v); + return CMD_PART_SUCCESS_MAYBE; +} + +static int +parse_varnames (void) +{ + int i; + + if (!parse_variables (NULL, &v, &nv, PV_SAME_TYPE)) + return 0; + if (!lex_match ('(')) + { + msg (SE, _("`(' expected after variable name%s."), nv > 1 ? "s" : ""); + return 0; + } + + type = v[0]->type; + if (type == NUMERIC) + return 1; + + width = v[0]->width; + for (i = 1; i < nv; i++) + if (v[i]->type == ALPHA && v[i]->nv != 1) + { + msg (SE, _("Long string value specified.")); + return 0; + } + else if (v[i]->type == ALPHA && (int) width != v[i]->width) + { + msg (SE, _("Short strings must be of equal width.")); + return 0; + } + + return 1; +} + +/* Number or range? */ +enum + { + MV_NOR_NOTHING, /* Empty. */ + MV_NOR_NUMBER, /* Single number. */ + MV_NOR_RANGE /* Range. */ + }; + +/* A single value or a range. */ +struct num_or_range + { + int type; /* One of NOR_*. */ + double d[2]; /* d[0]=lower bound or value, d[1]=upper bound. */ + }; + +/* Parses something of the form , or LO[WEST] THRU , or + THRU HI[GHEST], or THRU , and sets the appropriate + members of NOR. Returns success. */ +static int +parse_num_or_range (struct num_or_range * nor) +{ + if (lex_match_id ("LO") || lex_match_id ("LOWEST")) + { + nor->type = MV_NOR_RANGE; + if (!lex_force_match_id ("THRU")) + return 0; + if (!lex_force_num ()) + return 0; + nor->d[0] = LOWEST; + nor->d[1] = tokval; + } + else if (token == T_NUM) + { + nor->d[0] = tokval; + lex_get (); + + if (lex_match_id ("THRU")) + { + nor->type = MV_NOR_RANGE; + if (lex_match_id ("HI") || lex_match_id ("HIGHEST")) + nor->d[1] = HIGHEST; + else + { + if (!lex_force_num ()) + return 0; + nor->d[1] = tokval; + lex_get (); + + if (nor->d[0] > nor->d[1]) + { + msg (SE, _("Range %g THRU %g is not valid because %g is " + "greater than %g."), + nor->d[0], nor->d[1], nor->d[0], nor->d[1]); + return 0; + } + } + } + else + nor->type = MV_NOR_NUMBER; + } + else + return -1; + + return 1; +} + +/* Parses a set of numeric missing values and stores them into + `missing[]' and `miss_type' global variables. */ +static int +parse_numeric (void) +{ + struct num_or_range set[3]; + int r; + + set[1].type = set[2].type = MV_NOR_NOTHING; + + /* Get first number or range. */ + r = parse_num_or_range (&set[0]); + if (r < 1) + { + if (r == -1) + msg (SE, _("Number or range expected.")); + return 0; + } + + /* Get second and third optional number or range. */ + lex_match (','); + r = parse_num_or_range (&set[1]); + if (r == 1) + { + lex_match (','); + r = parse_num_or_range (&set[2]); + } + if (r == 0) + return 0; + + /* Force range, if present, into set[0]. */ + if (set[1].type == MV_NOR_RANGE) + { + struct num_or_range t = set[1]; + set[1] = set[0]; + set[0] = t; + } + if (set[2].type == MV_NOR_RANGE) + { + struct num_or_range t = set[2]; + set[2] = set[0]; + set[0] = t; + } + + /* Ensure there's not more than one range, or one range + plus one value. */ + if (set[1].type == MV_NOR_RANGE || set[2].type == MV_NOR_RANGE) + { + msg (SE, _("At most one range can exist in the missing values " + "for any one variable.")); + return 0; + } + if (set[0].type == MV_NOR_RANGE && set[2].type != MV_NOR_NOTHING) + { + msg (SE, _("At most one individual value can be missing along " + "with one range.")); + return 0; + } + + /* Set missing[] from set[]. */ + if (set[0].type == MV_NOR_RANGE) + { + int x = 0; + + if (set[0].d[0] == LOWEST) + { + miss_type = MISSING_LOW; + missing[x++].f = set[0].d[1]; + } + else if (set[0].d[1] == HIGHEST) + { + miss_type = MISSING_HIGH; + missing[x++].f = set[0].d[0]; + } + else + { + miss_type = MISSING_RANGE; + missing[x++].f = set[0].d[0]; + missing[x++].f = set[0].d[1]; + } + + if (set[1].type == MV_NOR_NUMBER) + { + miss_type += 3; + missing[x].f = set[1].d[0]; + } + } + else + { + if (set[0].type == MV_NOR_NUMBER) + { + miss_type = MISSING_1; + missing[0].f = set[0].d[0]; + } + if (set[1].type == MV_NOR_NUMBER) + { + miss_type = MISSING_2; + missing[1].f = set[1].d[0]; + } + if (set[2].type == MV_NOR_NUMBER) + { + miss_type = MISSING_3; + missing[2].f = set[2].d[0]; + } + } + + return 1; +} + +static int +parse_alpha (void) +{ + for (miss_type = 0; token == T_STRING && miss_type < 3; miss_type++) + { + if (ds_length (&tokstr) != width) + { + msg (SE, _("String is not of proper length.")); + return 0; + } + strncpy (missing[miss_type].s, ds_value (&tokstr), MAX_SHORT_STRING); + lex_get (); + lex_match (','); + } + if (miss_type < 1) + { + msg (SE, _("String expected.")); + return 0; + } + + return 1; +} + +/* Copy the missing values from variable SRC to variable DEST. */ +void +copy_missing_values (struct variable *dest, const struct variable *src) +{ + static const int n_values[MISSING_COUNT] = + { + 0, 1, 2, 3, 2, 1, 1, 3, 2, 2, + }; + + assert (dest->width == src->width); + assert (src->miss_type >= 0 && src->miss_type < MISSING_COUNT); + + { + int i; + + dest->miss_type = src->miss_type; + for (i = 0; i < n_values[src->miss_type]; i++) + if (src->type == NUMERIC) + dest->missing[i].f = src->missing[i].f; + else + memcpy (dest->missing[i].s, src->missing[i].s, src->width); + } +} + + +/* Debug output. */ + +#if DEBUGGING +static void +debug_print (void) +{ + int i, j; + + puts (_("Missing value:")); + for (i = 0; i < nvar; i++) + { + printf (" %8s: ", var[i]->name); + if (var[i]->type == ALPHA && var[i]->nv > 1) + puts (_("(long string variable)")); + else + switch (var[i]->miss_type) + { + case MISSING_NONE: + printf (_("(no missing values)\n")); + break; + case MISSING_1: + case MISSING_2: + case MISSING_3: + printf ("(MISSING_%d)", var[i]->miss_type); + for (j = 0; j < var[i]->miss_type; j++) + if (var[i]->type == ALPHA) + printf (" \"%.*s\"", var[i]->width, var[i]->missing[j].s); + else + printf (" %.2g", var[i]->missing[j].f); + printf ("\n"); + break; + case MISSING_RANGE: + printf ("(MISSING_RANGE) %.2g THRU %.2g\n", + var[i]->missing[0].f, var[i]->missing[1].f); + break; + case MISSING_RANGE_1: + printf ("(MISSING_RANGE_1) %.2g THRU %.2g, %.2g\n", + var[i]->missing[0].f, var[i]->missing[1].f, + var[i]->missing[2].f); + break; + default: + printf (_("(!!!INTERNAL ERROR--%d!!!)\n"), var[i]->miss_type); + } + } +} +#endif /* DEBUGGING */ diff --git a/src/misc.c b/src/misc.c new file mode 100644 index 00000000..7c517ad5 --- /dev/null +++ b/src/misc.c @@ -0,0 +1,38 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include "misc.h" + +/* Returns the number of digits in X. */ +int +intlog10 (unsigned x) +{ + int digits = 0; + + do + { + digits++; + x /= 10; + } + while (x > 0); + + return digits; +} + diff --git a/src/misc.h b/src/misc.h new file mode 100644 index 00000000..d8d19702 --- /dev/null +++ b/src/misc.h @@ -0,0 +1,108 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !math_misc_h +#define math_misc_h 1 + +#include + +/* HUGE_VAL is traditionally defined as positive infinity, or + alternatively, DBL_MAX. */ +#if !HAVE_ISINF +#define isinf(X) \ + (fabs (X) == HUGE_VAL) +#endif + +/* A Not a Number is not equal to itself. */ +#if !HAVE_ISNAN +#define isnan(X) \ + ((X) != (X)) +#endif + +/* Finite numbers are not infinities or NaNs. */ +#if !HAVE_FINITE +#define finite(X) \ + (!isinf (X) && !isnan (X)) +#elif HAVE_IEEEFP_H +#include /* Declares finite() under Solaris. */ +#endif + +#if __TURBOC__ +#include /* screwed-up Borland headers define min(), max(), + so we might as well let 'em */ +#endif + +#ifndef min +#if __GNUC__ && !__STRICT_ANSI__ +#define min(A, B) \ + ({ \ + int _a = (A), _b = (B); \ + _a < _b ? _a : _b; \ + }) +#else /* !__GNUC__ */ +#define min(A, B) \ + ((A) < (B) ? (A) : (B)) +#endif /* !__GNUC__ */ +#endif /* !min */ + +#ifndef max +#if __GNUC__ && !__STRICT_ANSI__ +#define max(A, B) \ + ({ \ + int _a = (A), _b = (B); \ + _a > _b ? _a : _b; \ + }) +#else /* !__GNUC__ */ +#define max(A, B) \ + ((A) > (B) ? (A) : (B)) +#endif /* !__GNUC__ */ +#endif /* !max */ + +/* Clamps A to be between B and C. */ +#define range(A, B, C) \ + ((A) < (B) ? (B) : ((A) > (C) ? (C) : (A))) + +/* Divides nonnegative X by positive Y, rounding up. */ +#define DIV_RND_UP(X, Y) \ + (((X) + ((Y) - 1)) / (Y)) + +/* Returns nonnegative difference between {nonnegative X} and {the + least multiple of positive Y greater than or equal to X}. */ +#if __GNUC__ && !__STRICT_ANSI__ +#define REM_RND_UP(X, Y) \ + ({ \ + int rem = (X) % (Y); \ + rem ? (Y) - rem : 0; \ + }) +#else +#define REM_RND_UP(X, Y) \ + ((X) % (Y) ? (Y) - (X) % (Y) : 0) +#endif + +/* Rounds X up to the next multiple of Y. */ +#define ROUND_UP(X, Y) \ + (((X) + ((Y) - 1)) / (Y) * (Y)) + +/* Rounds X down to the previous multiple of Y. */ +#define ROUND_DOWN(X, Y) \ + ((X) / (Y) * (Y)) + +int intlog10 (unsigned); + +#endif /* math/misc.h */ diff --git a/src/modify-vars.c b/src/modify-vars.c new file mode 100644 index 00000000..4fa71fd4 --- /dev/null +++ b/src/modify-vars.c @@ -0,0 +1,522 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include "alloc.h" +#include "avl.h" +#include "bitvector.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vfm.h" + +/* FIXME: should change weighting variable, etc. */ +/* These control the way that compare_variables() does its work. */ +static int forward; /* 1=FORWARD, 0=BACKWARD. */ +static int positional; /* 1=POSITIONAL, 0=ALPHA. */ + +static int compare_variables (const void *pa, const void *pb); + +/* Explains how to modify the variables in a dictionary in conjunction + with the p.mfv field of `variable'. */ +struct var_modification + { + /* REORDER information. */ + struct variable **reorder_list; + + /* RENAME information. */ + struct variable **old_names; + char **new_names; + int n_rename; + + /* DROP/KEEP information. */ + int n_drop; /* Number of variables being dropped. */ + }; + +static struct dictionary *rearrange_dict (struct dictionary *d, + struct var_modification *vm, + int permanent); + +/* Performs MODIFY VARS command. */ +int +cmd_modify_vars (void) +{ + /* Bits indicated whether we've already encountered a subcommand of + this type. */ + unsigned already_encountered = 0; + + /* What we're gonna do to the active file. */ + struct var_modification vm; + + lex_match_id ("MODIFY"); + lex_match_id ("VARS"); + + vm.reorder_list = NULL; + vm.old_names = NULL; + vm.new_names = NULL; + vm.n_rename = 0; + vm.n_drop = 0; + + /* Parse each subcommand. */ + lex_match ('/'); + for (;;) + { + if (lex_match_id ("REORDER")) + { + struct variable **v = NULL; + int nv = 0; + + if (already_encountered & 1) + { + msg (SE, _("REORDER subcommand may be given at most once.")); + goto lossage; + } + already_encountered |= 1; + + lex_match ('='); + do + { + int prev_nv = nv; + + forward = positional = 1; + if (lex_match_id ("FORWARD")); + else if (lex_match_id ("BACKWARD")) + forward = 0; + if (lex_match_id ("POSITIONAL")); + else if (lex_match_id ("ALPHA")) + positional = 0; + + if (lex_match (T_ALL) || token == '/' || token == '.') + { + if (prev_nv != 0) + { + msg (SE, _("Cannot specify ALL after specifying a set " + "of variables.")); + goto lossage; + } + fill_all_vars (&v, &nv, FV_NO_SYSTEM); + } + else + { + if (!lex_match ('(')) + { + msg (SE, _("`(' expected on REORDER subcommand.")); + free (v); + goto lossage; + } + if (!parse_variables (&default_dict, &v, &nv, + PV_APPEND | PV_NO_DUPLICATE)) + { + free (v); + goto lossage; + } + if (!lex_match (')')) + { + msg (SE, _("`)' expected following variable names on " + "REORDER subcommand.")); + free (v); + goto lossage; + } + } + qsort (&v[prev_nv], nv - prev_nv, sizeof *v, compare_variables); + } + while (token != '/' && token != '.'); + + if (nv != default_dict.nvar) + { + size_t nbytes = DIV_RND_UP (default_dict.nvar, 8); + unsigned char *bits = local_alloc (nbytes); + int i; + + memset (bits, 0, nbytes); + for (i = 0; i < nv; i++) + SET_BIT (bits, v[i]->index); + v = xrealloc (v, sizeof *v * default_dict.nvar); + for (i = 0; i < default_dict.nvar; i++) + if (!TEST_BIT (bits, i)) + v[nv++] = default_dict.var[i]; + local_free (bits); + } + + vm.reorder_list = v; + } + else if (lex_match_id ("RENAME")) + { + if (already_encountered & 2) + { + msg (SE, _("RENAME subcommand may be given at most once.")); + goto lossage; + } + already_encountered |= 2; + + lex_match ('='); + do + { + int prev_nv_1 = vm.n_rename; + int prev_nv_2 = vm.n_rename; + + if (!lex_match ('(')) + { + msg (SE, _("`(' expected on RENAME subcommand.")); + goto lossage; + } + if (!parse_variables (&default_dict, &vm.old_names, &vm.n_rename, + PV_APPEND | PV_NO_DUPLICATE)) + goto lossage; + if (!lex_match ('=')) + { + msg (SE, _("`=' expected between lists of new and old variable " + "names on RENAME subcommand.")); + goto lossage; + } + if (!parse_DATA_LIST_vars (&vm.new_names, &prev_nv_1, PV_APPEND)) + goto lossage; + if (prev_nv_1 != vm.n_rename) + { + int i; + + msg (SE, _("Differing number of variables in old name list " + "(%d) and in new name list (%d)."), + vm.n_rename - prev_nv_2, prev_nv_1 - prev_nv_2); + for (i = 0; i < prev_nv_1; i++) + free (&vm.new_names[i]); + free (&vm.new_names); + vm.new_names = NULL; + goto lossage; + } + if (!lex_match (')')) + { + msg (SE, _("`)' expected after variable lists on RENAME " + "subcommand.")); + goto lossage; + } + } + while (token != '.' && token != '/'); + } + else if (lex_match_id ("KEEP")) + { + struct variable **keep_vars; + int nv; + int counter; + int i; + + if (already_encountered & 4) + { + msg (SE, _("KEEP subcommand may be given at most once. It may not" + "be given in conjunction with the DROP subcommand.")); + goto lossage; + } + already_encountered |= 4; + + lex_match ('='); + if (!parse_variables (&default_dict, &keep_vars, &nv, PV_NONE)) + goto lossage; + + /* Transform the list of variables to keep into a list of + variables to drop. First sort the keep list, then figure + out which variables are missing. */ + forward = positional = 1; + qsort (keep_vars, nv, sizeof *keep_vars, compare_variables); + + vm.n_drop = default_dict.nvar - nv; + + counter = 0; + for (i = 0; i < nv; i++) + { + while (counter < keep_vars[i]->index) + default_dict.var[counter++]->p.mfv.drop_this_var = 1; + default_dict.var[counter++]->p.mfv.drop_this_var = 0; + } + while (counter < nv) + default_dict.var[counter++]->p.mfv.drop_this_var = 1; + + free (keep_vars); + } + else if (lex_match_id ("DROP")) + { + struct variable **drop_vars; + int nv; + int i; + + if (already_encountered & 4) + { + msg (SE, _("DROP subcommand may be given at most once. It may not" + "be given in conjunction with the KEEP subcommand.")); + goto lossage; + } + already_encountered |= 4; + + lex_match ('='); + if (!parse_variables (&default_dict, &drop_vars, &nv, PV_NONE)) + goto lossage; + for (i = 0; i < default_dict.nvar; i++) + default_dict.var[i]->p.mfv.drop_this_var = 0; + for (i = 0; i < nv; i++) + drop_vars[i]->p.mfv.drop_this_var = 1; + vm.n_drop = nv; + free (drop_vars); + } + else if (lex_match_id ("MAP")) + { + struct dictionary *new_dict = rearrange_dict (&default_dict, &vm, 0); + if (!new_dict) + goto lossage; + /* FIXME: display new dictionary. */ + } + else + { + if (token == T_ID) + msg (SE, _("Unrecognized subcommand name `%s'."), tokid); + else + msg (SE, _("Subcommand name expected.")); + goto lossage; + } + + if (token == '.') + break; + if (token != '/') + { + msg (SE, _("`/' or `.' expected.")); + goto lossage; + } + lex_get (); + } + + { + int i; + + if (already_encountered & (1 | 4)) + { + /* Read the data. */ + procedure (NULL, NULL, NULL); + } + + if (NULL == rearrange_dict (&default_dict, &vm, 1)) + goto lossage; + + free (vm.reorder_list); + free (vm.old_names); + for (i = 0; i < vm.n_rename; i++) + free (vm.new_names[i]); + free (vm.new_names); + + return CMD_SUCCESS; + } + +lossage: + { + int i; + + free (vm.reorder_list); + free (vm.old_names); + for (i = 0; i < vm.n_rename; i++) + free (vm.new_names[i]); + free (vm.new_names); + return CMD_FAILURE; + } +} + +/* Compares a pair of variables according to the settings in `forward' + and `positional', returning a strcmp()-type result. */ +static int +compare_variables (const void *pa, const void *pb) +{ + const struct variable *a = *(const struct variable **) pa; + const struct variable *b = *(const struct variable **) pb; + + int result = positional ? a->index - b->index : strcmp (a->name, b->name); + return forward ? result : -result; +} + +/* (Possibly) rearranges variables and (possibly) removes some + variables and (possibly) renames some more variables in dictionary + D. There are two modes of operation, distinguished by the value of + PERMANENT: + + If PERMANENT is nonzero, then the dictionary is modified in place. + Returns the new dictionary on success or NULL if there would have + been duplicate variable names in the resultant dictionary (in this + case the dictionary has not been modified). + + If PERMANENT is zero, then the dictionary is copied to a new + dictionary structure that retains most of the same deep structure + as D. The p.mfv.new_name field of each variable is set to what + would become the variable's new name if PERMANENT were nonzero. + Returns the new dictionary. */ +static struct dictionary * +rearrange_dict (struct dictionary * d, struct var_modification * vm, int permanent) +{ + struct dictionary *n; + + struct variable **save_var; + + /* Linked list of variables for deletion. */ + struct variable *head, *tail; + + int i; + + /* First decide what dictionary to modify. */ + if (permanent == 0) + { + n = xmalloc (sizeof *n); + *n = *d; + } + else + n = d; + save_var = n->var; + + /* Perform first half of renaming. */ + if (permanent) + { + for (i = 0; i < d->nvar; i++) + d->var[i]->p.mfv.new_name[0] = 0; + d->var = xmalloc (sizeof *d->var * d->nvar); + } + else + for (i = 0; i < d->nvar; i++) + strcpy (d->var[i]->p.mfv.new_name, d->var[i]->name); + for (i = 0; i < vm->n_rename; i++) + strcpy (vm->old_names[i]->p.mfv.new_name, vm->new_names[i]); + + /* Copy the variable list, reordering if appropriate. */ + if (vm->reorder_list) + memcpy (n->var, vm->reorder_list, sizeof *n->var * d->nvar); + else if (!permanent) + for (i = 0; i < d->nvar; i++) + n->var[i] = d->var[i]; + + /* Drop all the unwanted variables. */ + head = NULL; + if (vm->n_drop) + { + int j; + + n->nvar = d->nvar - vm->n_drop; + for (i = j = 0; i < n->nvar; i++) + { + while (n->var[j]->p.mfv.drop_this_var != 0) + { + if (permanent) + { + /* If this is permanent, then we have to keep a list + of all the dropped variables because they must be + free()'d, but can't be until we know that there + aren't any duplicate variable names. */ + if (head) + tail = tail->p.mfv.next = n->var[j]; + else + head = tail = n->var[j]; + } + j++; + } + n->var[i] = n->var[j++]; + } + if (permanent) + tail->p.mfv.next = NULL; + } + + /* Check for duplicate variable names if appropriate. */ + if (permanent && vm->n_rename) + { + struct variable **v; + + if (vm->reorder_list) + v = vm->reorder_list; /* Reuse old buffer if possible. */ + else + v = xmalloc (sizeof *v * n->nvar); + memcpy (v, n->var, sizeof *v * n->nvar); + forward = 1, positional = 0; + qsort (v, n->nvar, sizeof *v, compare_variables); + for (i = 1; i < n->nvar; i++) + if (!strcmp (n->var[i]->name, n->var[i - 1]->name)) + { + msg (SE, _("Duplicate variable name `%s' after renaming."), + n->var[i]->name); + if (vm->reorder_list == NULL) + free (v); + n->var = save_var; + return NULL; + } + if (vm->reorder_list == NULL) + free (v); + } + + /* Delete unwanted variables and finalize renaming if + appropriate. */ + if (permanent) + { + /* Delete dropped variables for good. */ + for (; head; head = tail) + { + tail = head->p.mfv.next; + clear_variable (n, head); + free (head); + } + + /* Remove names from all renamed variables. */ + head = NULL; + for (i = 0; i < n->nvar; i++) + if (n->var[i]->p.mfv.new_name[0]) + { + avl_force_delete (n->var_by_name, n->var[i]); + if (head) + tail = tail->p.mfv.next = n->var[i]; + else + head = tail = n->var[i]; + } + if (head) + tail->p.mfv.next = NULL; + + /* Put names onto renamed variables. */ + for (; head; head = head->p.mfv.next) + { + strcpy (head->name, head->p.mfv.new_name); + avl_force_insert (n->var_by_name, head); + } + free (save_var); + + /* As a final step the index fields must be redone. */ + for (i = 0; i < n->nvar; i++) + n->var[i]->index = i; + } + + return n; +} diff --git a/src/numeric.c b/src/numeric.c new file mode 100644 index 00000000..f80865d1 --- /dev/null +++ b/src/numeric.c @@ -0,0 +1,213 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "cases.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Parses the NUMERIC command. */ +int +cmd_numeric (void) +{ + int i; + + /* Names of variables to create. */ + char **v; + int nv; + + /* Format spec for variables to create. f.type==-1 if default is to + be used. */ + struct fmt_spec f; + + lex_match_id ("NUMERIC"); + do + { + if (!parse_DATA_LIST_vars (&v, &nv, PV_NONE)) + return CMD_PART_SUCCESS_MAYBE; + + /* Get the optional format specification. */ + if (lex_match ('(')) + { + if (!parse_format_specifier (&f, 0)) + goto fail; + if (formats[f.type].cat & FCAT_STRING) + { + msg (SE, _("Format type %s may not be used with a numeric " + "variable."), fmt_to_string (&f)); + goto fail; + } + + if (!lex_match (')')) + { + msg (SE, _("`)' expected after output format.")); + goto fail; + } + } + else + f.type = -1; + + /* Create each variable. */ + for (i = 0; i < nv; i++) + { + struct variable *new_var = create_variable (&default_dict, v[i], + NUMERIC, 0); + if (!new_var) + msg (SE, _("There is already a variable named %s."), v[i]); + else + { + if (f.type != -1) + new_var->print = new_var->write = f; + envector (new_var); + } + } + + /* Clean up. */ + for (i = 0; i < nv; i++) + free (v[i]); + free (v); + } + while (lex_match ('/')); + + return lex_end_of_command (); + + /* If we have an error at a point where cleanup is required, + flow-of-control comes here. */ +fail: + for (i = 0; i < nv; i++) + free (v[i]); + free (v); + return CMD_PART_SUCCESS_MAYBE; +} + +/* Parses the STRING command. */ +int +cmd_string (void) +{ + int i; + + /* Names of variables to create. */ + char **v; + int nv; + + /* Format spec for variables to create. */ + struct fmt_spec f; + + /* Width of variables to create. */ + int width; + + lex_match_id ("STRING"); + do + { + if (!parse_DATA_LIST_vars (&v, &nv, PV_NONE)) + return CMD_PART_SUCCESS_MAYBE; + + if (!lex_force_match ('(') + || !parse_format_specifier (&f, 0)) + goto fail; + if (!(formats[f.type].cat & FCAT_STRING)) + { + msg (SE, _("Format type %s may not be used with a string " + "variable."), fmt_to_string (&f)); + goto fail; + } + + if (!lex_match (')')) + { + msg (SE, _("`)' expected after output format.")); + goto fail; + } + + switch (f.type) + { + case FMT_A: + width = f.w; + break; + case FMT_AHEX: + width = f.w / 2; + break; + default: + assert (0); + } + + /* Create each variable. */ + for (i = 0; i < nv; i++) + { + struct variable *new_var = create_variable (&default_dict, v[i], + ALPHA, width); + if (!new_var) + msg (SE, _("There is already a variable named %s."), v[i]); + else + { + new_var->print = new_var->write = f; + envector (new_var); + } + } + + /* Clean up. */ + for (i = 0; i < nv; i++) + free (v[i]); + free (v); + } + while (lex_match ('/')); + + return lex_end_of_command (); + + /* If we have an error at a point where cleanup is required, + flow-of-control comes here. */ +fail: + for (i = 0; i < nv; i++) + free (v[i]); + free (v); + return CMD_PART_SUCCESS_MAYBE; +} + +/* Parses the LEAVE command. */ +int +cmd_leave (void) +{ + struct variable **v; + int nv; + + int i; + + lex_match_id ("LEAVE"); + if (!parse_variables (NULL, &v, &nv, PV_NONE)) + return CMD_FAILURE; + for (i = 0; i < nv; i++) + { + if (v[i]->left) + continue; + devector (v[i]); + v[i]->left = 1; + envector (v[i]); + } + free (v); + + return lex_end_of_command (); +} diff --git a/src/output.c b/src/output.c new file mode 100644 index 00000000..8cf5bafa --- /dev/null +++ b/src/output.c @@ -0,0 +1,1324 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "error.h" +#include "filename.h" +#include "lexer.h" +#include "misc.h" +#include "output.h" +#include "settings.h" +#include "str.h" + +/* FIXME? Should the output configuration format be changed to + drivername:classname:devicetype:options, where devicetype is zero + or more of screen, printer, listing? */ + +/* FIXME: Have the reentrancy problems been solved? */ + +/* Where the output driver name came from. */ +enum + { + OUTP_S_COMMAND_LINE, /* Specified by the user. */ + OUTP_S_INIT_FILE /* `default' or the init file. */ + }; + +/* Names the output drivers to be used. */ +struct outp_names + { + char *name; /* Name of the output driver. */ + int source; /* OUTP_S_* */ + struct outp_names *next, *prev; + }; + +/* Defines an init file macro. */ +struct outp_defn + { + char *key; + char *value; + struct outp_defn *next, *prev; + }; + +static struct outp_defn *outp_macros; +static struct outp_names *outp_configure_vec; + +struct outp_driver_class_list *outp_class_list; +struct outp_driver *outp_driver_list; + +char *outp_title; +char *outp_subtitle; + +/* A set of OUTP_DEV_* bits indicating the devices that are + disabled. */ +int disabled_devices; + +static void destroy_driver (struct outp_driver *); +static void configure_driver (char *); + +#if GLOBAL_DEBUGGING +/* This mechanism attempts to catch reentrant use of outp_driver_list. */ +static int iterating_driver_list; + +#define reentrancy() msg (FE, _("Attempt to iterate driver list reentrantly.")) +#endif + +/* Add a class to the class list. */ +static void +add_class (struct outp_class *class) +{ + struct outp_driver_class_list *new_list = xmalloc (sizeof *new_list); + + new_list->class = class; + new_list->ref_count = 0; + + if (!outp_class_list) + { + outp_class_list = new_list; + new_list->next = NULL; + } + else + { + new_list->next = outp_class_list; + outp_class_list = new_list; + } +} + +/* Finds the outp_names in outp_configure_vec with name between BP and + EP exclusive. */ +static struct outp_names * +search_names (char *bp, char *ep) +{ + struct outp_names *n; + + for (n = outp_configure_vec; n; n = n->next) + if ((int) strlen (n->name) == ep - bp && !memcmp (n->name, bp, ep - bp)) + return n; + return NULL; +} + +/* Deletes outp_names NAME from outp_configure_vec. */ +static void +delete_name (struct outp_names * n) +{ + free (n->name); + if (n->prev) + n->prev->next = n->next; + if (n->next) + n->next->prev = n->prev; + if (n == outp_configure_vec) + outp_configure_vec = n->next; + free (n); +} + +/* Adds the name between BP and EP exclusive to list + outp_configure_vec with source SOURCE. */ +static void +add_name (char *bp, char *ep, int source) +{ + struct outp_names *n = xmalloc (sizeof *n); + n->name = xmalloc (ep - bp + 1); + memcpy (n->name, bp, ep - bp); + n->name[ep - bp] = 0; + n->source = source; + n->next = outp_configure_vec; + n->prev = NULL; + if (outp_configure_vec) + outp_configure_vec->prev = n; + outp_configure_vec = n; +} + +/* Checks that outp_configure_vec is empty, bitches & clears it if it + isn't. */ +static void +check_configure_vec (void) +{ + struct outp_names *n; + + for (n = outp_configure_vec; n; n = n->next) + if (n->source == OUTP_S_COMMAND_LINE) + msg (ME, _("Unknown output driver `%s'."), n->name); + else + msg (IE, _("Output driver `%s' referenced but never defined."), n->name); + outp_configure_clear (); +} + +/* Searches outp_configure_vec for the name between BP and EP + exclusive. If found, it is deleted, then replaced by the names + given in EP+1, if any. */ +static void +expand_name (char *bp, char *ep) +{ + struct outp_names *n = search_names (bp, ep); + if (!n) + return; + delete_name (n); + + bp = ep + 1; + for (;;) + { + while (isspace ((unsigned char) *bp)) + bp++; + ep = bp; + while (*ep && !isspace ((unsigned char) *ep)) + ep++; + if (bp == ep) + return; + if (!search_names (bp, ep)) + add_name (bp, ep, OUTP_S_INIT_FILE); + bp = ep; + } +} + +/* Looks for a macro with key KEY, and returns the corresponding value + if found, or NULL if not. */ +const char * +find_defn_value (const char *key) +{ + static char buf[INT_DIGITS + 1]; + struct outp_defn *d; + + for (d = outp_macros; d; d = d->next) + if (!strcmp (key, d->key)) + return d->value; + if (!strcmp (key, "viewwidth")) + { + sprintf (buf, "%d", set_viewwidth); + return buf; + } + else if (!strcmp (key, "viewlength")) + { + sprintf (buf, "%d", set_viewlength); + return buf; + } + else + return getenv (key); +} + +/* Initializes global variables. */ +int +outp_init (void) +{ + extern struct outp_class ascii_class; +#if !NO_POSTSCRIPT + extern struct outp_class postscript_class; + extern struct outp_class epsf_class; +#endif +#if !NO_HTML + extern struct outp_class html_class; +#endif + + char def[] = "default"; + +#if !NO_HTML + add_class (&html_class); +#endif +#if !NO_POSTSCRIPT + add_class (&epsf_class); + add_class (&postscript_class); +#endif + add_class (&ascii_class); + + add_name (def, &def[strlen (def)], OUTP_S_INIT_FILE); + + return 1; +} + +/* Deletes all the output macros. */ +static void +delete_macros (void) +{ + struct outp_defn *d, *next; + + for (d = outp_macros; d; d = next) + { + next = d->next; + free (d->key); + free (d->value); + free (d); + } +} + +/* Reads the initialization file; initializes outp_driver_list. */ +int +outp_read_devices (void) +{ + int result = 0; + + char *init_fn; + + FILE *f = NULL; + struct string line; + struct file_locator where; + +#if GLOBAL_DEBUGGING + if (iterating_driver_list) + reentrancy (); +#endif + + init_fn = fn_search_path (fn_getenv_default ("STAT_OUTPUT_INIT_FILE", + "devices"), + fn_getenv_default ("STAT_OUTPUT_INIT_PATH", + config_path), + NULL); + where.filename = init_fn; + where.line_number = 0; + err_push_file_locator (&where); + + if (init_fn == NULL) + { + msg (IE, _("Cannot find output initialization file. Use `-vv' to view " + "search path.")); + goto exit; + } + + msg (VM (1), _("%s: Opening device description file..."), init_fn); + f = fopen (init_fn, "r"); + if (f == NULL) + { + msg (IE, _("Opening %s: %s."), init_fn, strerror (errno)); + goto exit; + } + + ds_init (NULL, &line, 128); + for (;;) + { + char *cp; + + if (!ds_get_config_line (f, &line, &where)) + { + if (ferror (f)) + msg (ME, _("Reading %s: %s."), init_fn, strerror (errno)); + break; + } + for (cp = ds_value (&line); isspace ((unsigned char) *cp); cp++); + if (!strncmp ("define", cp, 6) && isspace ((unsigned char) cp[6])) + outp_configure_macro (&cp[7]); + else if (*cp) + { + char *ep; + for (ep = cp; *ep && *ep != ':' && *ep != '='; ep++); + if (*ep == '=') + expand_name (cp, ep); + else if (*ep == ':') + { + struct outp_names *n = search_names (cp, ep); + if (n) + { + configure_driver (cp); + delete_name (n); + } + } + else + msg (IS, _("Syntax error.")); + } + } + result = 1; + + check_configure_vec (); + +exit: + err_pop_file_locator (&where); + if (f && -1 == fclose (f)) + msg (MW, _("Closing %s: %s."), init_fn, strerror (errno)); + free (init_fn); + ds_destroy (&line); + delete_macros (); + if (outp_driver_list == NULL) + msg (MW, _("No output drivers are active.")); + + if (result) + msg (VM (2), _("Device definition file read successfully.")); + else + msg (VM (1), _("Error reading device definition file.")); + return result; +} + +/* Clear the list of drivers to configure. */ +void +outp_configure_clear (void) +{ + struct outp_names *n, *next; + + for (n = outp_configure_vec; n; n = next) + { + next = n->next; + free (n->name); + free (n); + } + outp_configure_vec = NULL; +} + +/* Adds the name BP to the list of drivers to configure into + outp_driver_list. */ +void +outp_configure_add (char *bp) +{ + char *ep = &bp[strlen (bp)]; + if (!search_names (bp, ep)) + add_name (bp, ep, OUTP_S_COMMAND_LINE); +} + +/* Defines one configuration macro based on the text in BP, which + should be of the form `KEY=VALUE'. */ +void +outp_configure_macro (char *bp) +{ + struct outp_defn *d; + char *ep; + + while (isspace ((unsigned char) *bp)) + bp++; + ep = bp; + while (*ep && !isspace ((unsigned char) *ep) && *ep != '=') + ep++; + + d = xmalloc (sizeof *d); + d->key = xmalloc (ep - bp + 1); + memcpy (d->key, bp, ep - bp); + d->key[ep - bp] = 0; + + /* Earlier definitions for a particular KEY override later ones. */ + if (find_defn_value (d->key)) + { + free (d->key); + free (d); + return; + } + + if (*ep == '=') + ep++; + while (isspace ((unsigned char) *ep)) + ep++; + d->value = fn_interp_vars (ep, find_defn_value); + d->next = outp_macros; + d->prev = NULL; + if (outp_macros) + outp_macros->prev = d; + outp_macros = d; +} + +/* Destroys all the drivers in driver list *DL and sets *DL to + NULL. */ +void +destroy_list (struct outp_driver ** dl) +{ + struct outp_driver *d, *next; + + for (d = *dl; d; d = next) + { + destroy_driver (d); + next = d->next; + free (d); + } + *dl = NULL; +} + +/* Closes all the output drivers. */ +int +outp_done (void) +{ +#if GLOBAL_DEBUGGING + if (iterating_driver_list) + reentrancy (); +#endif + destroy_list (&outp_driver_list); + + return 1; +} + +/* Display on stdout a list of all registered driver classes. */ +void +outp_list_classes (void) +{ + int width = set_viewwidth; + struct outp_driver_class_list *c; + + printf (_("Driver classes:\n\t")); + width -= 8; + for (c = outp_class_list; c; c = c->next) + { + if ((int) strlen (c->class->name) + 1 > width) + { + printf ("\n\t"); + width = set_viewwidth - 8; + } + else + putc (' ', stdout); + fputs (c->class->name, stdout); + } + putc('\n', stdout); +} + +static int op_token; /* `=', 'a', 0. */ +static struct string op_tokstr; +static char *prog; + +/* Parses a token from prog into op_token, op_tokstr. Sets op_token + to '=' on an equals sign, to 'a' on a string or identifier token, + or to 0 at end of line. Returns the new op_token. */ +static int +tokener (void) +{ + if (op_token == 0) + { + msg (IS, _("Syntax error.")); + return 0; + } + + while (isspace ((unsigned char) *prog)) + prog++; + if (!*prog) + { + op_token = 0; + return 0; + } + + if (*prog == '=') + op_token = *prog++; + else + { + ds_clear (&op_tokstr); + + if (*prog == '\'' || *prog == '"') + { + int quote = *prog++; + + while (*prog && *prog != quote) + { + if (*prog != '\\') + ds_putchar (&op_tokstr, *prog++); + else + { + int c; + + prog++; + assert ((int) *prog); /* How could a line end in `\'? */ + switch (*prog++) + { + case '\'': + c = '\''; + break; + case '"': + c = '"'; + break; + case '?': + c = '?'; + break; + case '\\': + c = '\\'; + break; + case '}': + c = '}'; + break; + case 'a': + c = '\a'; + break; + case 'b': + c = '\b'; + break; + case 'f': + c = '\f'; + break; + case 'n': + c = '\n'; + break; + case 'r': + c = '\r'; + break; + case 't': + c = '\t'; + break; + case 'v': + c = '\v'; + break; + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + { + c = prog[-1] - '0'; + while (*prog >= '0' && *prog <= '7') + c = c * 8 + *prog++ - '0'; + } + break; + case 'x': + case 'X': + { + c = 0; + while (isxdigit ((unsigned char) *prog)) + { + c *= 16; + if (isdigit ((unsigned char) *prog)) + c += *prog - '0'; + else + c += (tolower ((unsigned char) (*prog)) + - 'a' + 10); + prog++; + } + } + break; + default: + msg (IS, _("Syntax error in string constant.")); + } + ds_putchar (&op_tokstr, (unsigned char) c); + } + } + prog++; + } + else + while (*prog && !isspace ((unsigned char) *prog) && *prog != '=') + ds_putchar (&op_tokstr, *prog++); + op_token = 'a'; + } + + return 1; +} + +/* Applies the user-specified options in string S to output driver D + (at configuration time). */ +static void +parse_options (char *s, struct outp_driver * d) +{ + prog = s; + op_token = -1; + + ds_init (NULL, &op_tokstr, 64); + while (tokener ()) + { + char key[65]; + + if (op_token != 'a') + { + msg (IS, _("Syntax error in options.")); + break; + } + + ds_truncate (&op_tokstr, 64); + strcpy (key, ds_value (&op_tokstr)); + + tokener (); + if (op_token != '=') + { + msg (IS, _("Syntax error in options (`=' expected).")); + break; + } + + tokener (); + if (op_token != 'a') + { + msg (IS, _("Syntax error in options (value expected after `=').")); + break; + } + d->class->option (d, key, &op_tokstr); + } + ds_destroy (&op_tokstr); +} + +/* Find the driver in outp_driver_list with name NAME. */ +static struct outp_driver * +find_driver (char *name) +{ + struct outp_driver *d; + +#if GLOBAL_DEBUGGING + if (iterating_driver_list) + reentrancy (); +#endif + for (d = outp_driver_list; d; d = d->next) + if (!strcmp (d->name, name)) + return d; + return NULL; +} + +/* Tokenize string S into colon-separated fields, removing leading and + trailing whitespace on tokens. Returns a pointer to the + null-terminated token, which is formed by setting a NUL character + into the string. After the first call, subsequent calls should set + S to NULL. CP should be consistent across calls. Returns NULL + after all fields have been used up. + + FIXME: Should ignore colons inside double quotes. */ +static char * +colon_tokenize (char *s, char **cp) +{ + char *token; + + if (!s) + { + s = *cp; + if (*s == 0) + return NULL; + } + token = s += strspn (s, " \t\v\r"); + *cp = strchr (s, ':'); + if (*cp == NULL) + s = *cp = strchr (s, 0); + else + s = (*cp)++; + while (s > token && strchr (" \t\v\r", s[-1])) + s--; + *s = 0; + return token; +} + +/* String S is in format: + DRIVERNAME:CLASSNAME:DEVICETYPE:OPTIONS + Adds a driver to outp_driver_list pursuant to the specification + provided. */ +static void +configure_driver (char *s) +{ + char *token, *cp; + struct outp_driver *d = NULL, *iter; + struct outp_driver_class_list *c = NULL; + + s = fn_interp_vars (s, find_defn_value); + + /* Driver name. */ + token = colon_tokenize (s, &cp); + if (!token) + { + msg (IS, _("Driver name expected.")); + goto error; + } + + d = xmalloc (sizeof *d); + + d->class = NULL; + d->name = xstrdup (token); + d->driver_open = 0; + d->page_open = 0; + + d->next = d->prev = NULL; + + d->device = OUTP_DEV_NONE; + + d->ext = NULL; + + /* Class name. */ + token = colon_tokenize (NULL, &cp); + if (!token) + { + msg (IS, _("Class name expected.")); + goto error; + } + + for (c = outp_class_list; c; c = c->next) + if (!strcmp (c->class->name, token)) + break; + if (!c) + { + msg (IS, _("Unknown output driver class `%s'."), token); + goto error; + } + + d->class = c->class; + if (!c->ref_count && !d->class->open_global (d->class)) + { + msg (IS, _("Can't initialize output driver class `%s'."), + d->class->name); + goto error; + } + c->ref_count++; + if (!d->class->preopen_driver (d)) + { + msg (IS, _("Can't initialize output driver `%s' of class `%s'."), + d->name, d->class->name); + goto error; + } + + /* Device types. */ + token = colon_tokenize (NULL, &cp); + if (token) + { + char *sp, *type; + + for (type = strtok_r (token, " \t\r\v", &sp); type; + type = strtok_r (NULL, " \t\r\v", &sp)) + { + if (!strcmp (type, "listing")) + d->device |= OUTP_DEV_LISTING; + else if (!strcmp (type, "screen")) + d->device |= OUTP_DEV_SCREEN; + else if (!strcmp (type, "printer")) + d->device |= OUTP_DEV_PRINTER; + else + { + msg (IS, _("Unknown device type `%s'."), type); + goto error; + } + } + } + + /* Options. */ + token = colon_tokenize (NULL, &cp); + if (token) + parse_options (token, d); + if (!d->class->postopen_driver (d)) + { + msg (IS, _("Can't complete initialization of output driver `%s' of " + "class `%s'."), d->name, d->class->name); + goto error; + } + + /* Find like-named driver and delete. */ + iter = find_driver (d->name); + if (iter) + destroy_driver (iter); + + /* Add to list. */ + d->next = outp_driver_list; + d->prev = NULL; + if (outp_driver_list) + outp_driver_list->prev = d; + outp_driver_list = d; + goto exit; + +error: + if (d) + destroy_driver (d); +exit: + free (s); +} + +/* Destroys output driver D. */ +static void +destroy_driver (struct outp_driver *d) +{ + if (d->page_open) + d->class->close_page (d); + if (d->class) + { + struct outp_driver_class_list *c; + + if (d->driver_open) + d->class->close_driver (d); + + for (c = outp_class_list; c; c = c->next) + if (c->class == d->class) + break; + assert (c != NULL); + + c->ref_count--; + if (c->ref_count == 0) + { + if (!d->class->close_global (d->class)) + msg (IS, _("Can't deinitialize output driver class `%s'."), + d->class->name); + } + } + free (d->name); + + /* Remove this driver from the global driver list. */ + if (d->prev) + d->prev->next = d->next; + if (d->next) + d->next->prev = d->prev; + if (d == outp_driver_list) + outp_driver_list = d->next; +} + +static int +option_cmp (const void *a, const void *b) +{ + const struct outp_option *o1 = a; + const struct outp_option *o2 = b; + return strcmp (o1->keyword, o2->keyword); +} + +/* Tries to match S as one of the keywords in TAB, with corresponding + information structure INFO. Returns category code or 0 on failure; + if category code is negative then stores subcategory in *SUBCAT. */ +int +outp_match_keyword (const char *s, struct outp_option *tab, + struct outp_option_info *info, int *subcat) +{ + char *cp; + struct outp_option *oip; + + /* Form hash table. */ + if (NULL == info->initial) + { + /* Count items. */ + int count, i; + char s[256], *cp; + struct outp_option *ptr[255], **oip; + + for (count = 0; tab[count].keyword[0]; count++) + ; + + /* Sort items. */ + qsort (tab, count, sizeof *tab, option_cmp); + + cp = s; + oip = ptr; + *cp = tab[0].keyword[0]; + *oip++ = &tab[0]; + for (i = 0; i < count; i++) + if (tab[i].keyword[0] != *cp) + { + *++cp = tab[i].keyword[0]; + *oip++ = &tab[i]; + } + *++cp = 0; + + info->initial = xstrdup (s); + info->options = xmalloc (sizeof *info->options * (cp - s)); + memcpy (info->options, ptr, sizeof *info->options * (cp - s)); + } + + cp = info->initial; + oip = *info->options; + + if (s[0] == 0) + return 0; + cp = strchr (info->initial, s[0]); + if (!cp) + return 0; +#if 0 + printf (_("Trying to find keyword `%s'...\n"), s); +#endif + oip = info->options[cp - info->initial]; + while (oip->keyword[0] == s[0]) + { +#if 0 + printf ("- %s\n", oip->keyword); +#endif + if (!strcmp (s, oip->keyword)) + { + if (oip->cat < 0) + *subcat = oip->subcat; + return oip->cat; + } + oip++; + } + + return 0; +} + +/* Encapsulate two characters in a single int. */ +#define TWO_CHARS(A, B) \ + ((A) + ((B)<<8)) + +/* Determines the size of a dimensional measurement and returns the + size in units of 1/72000". Units if not specified explicitly are + inches for values under 50, millimeters otherwise. Returns 0, + stores NULL to *TAIL on error; otherwise returns dimension, stores + address of next */ +int +outp_evaluate_dimension (char *dimen, char **tail) +{ + char *s = dimen; + char *ptail; + double value; + + value = strtod (s, &ptail); + if (ptail == s) + goto lossage; + if (*ptail == '-') + { + double b, c; + s = &ptail[1]; + b = strtod (s, &ptail); + if (b <= 0.0 || ptail == s) + goto lossage; + if (*ptail != '/') + goto lossage; + s = &ptail[1]; + c = strtod (s, &ptail); + if (c <= 0.0 || ptail == s) + goto lossage; + s = ptail; + if (approx_eq (c, 0.0)) + goto lossage; + if (value > 0) + value += b / c; + else + value -= b / c; + } + else if (*ptail == '/') + { + double b; + s = &ptail[1]; + b = strtod (s, &ptail); + if (approx_le (b, 0.0) || ptail == s) + goto lossage; + s = ptail; + value /= b; + } + else + s = ptail; + if (*s == 0 || isspace ((unsigned char) *s)) + { + if (value < 50.0) + value *= 72000; + else + value *= 72000 / 25.4; + } + else + { + double factor; + + /* Standard TeX units are supported. */ + if (*s == '"') + factor = 72000, s++; + else + switch (TWO_CHARS (s[0], s[1])) + { + case TWO_CHARS ('p', 't'): + factor = 72000 / 72.27; + break; + case TWO_CHARS ('p', 'c'): + factor = 72000 / 72.27 * 12.0; + break; + case TWO_CHARS ('i', 'n'): + factor = 72000; + break; + case TWO_CHARS ('b', 'p'): + factor = 72000 / 72.0; + break; + case TWO_CHARS ('c', 'm'): + factor = 72000 / 2.54; + break; + case TWO_CHARS ('m', 'm'): + factor = 72000 / 25.4; + break; + case TWO_CHARS ('d', 'd'): + factor = 72000 / 72.27 * 1.0700086; + break; + case TWO_CHARS ('c', 'c'): + factor = 72000 / 72.27 * 12.840104; + break; + case TWO_CHARS ('s', 'p'): + factor = 72000 / 72.27 / 65536.0; + break; + default: + msg (SE, _("Unit \"%s\" is unknown in dimension \"%s\"."), s, dimen); + *tail = NULL; + return 0; + } + ptail += 2; + value *= factor; + } + if (approx_lt (value, 0.0)) + goto lossage; + if (tail) + *tail = ptail; + return value + 0.5; + +lossage: + *tail = NULL; + msg (SE, _("Bad dimension \"%s\"."), dimen); + return 0; +} + +/* Stores the dimensions in 1/72000" units of paper identified by + SIZE, which is of form `HORZ x VERT' or `HORZ by VERT' where each + of HORZ and VERT are dimensions, into *H and *V. Return nonzero on + success. */ +static int +internal_get_paper_size (char *size, int *h, int *v) +{ + char *tail; + + while (isspace ((unsigned char) *size)) + size++; + *h = outp_evaluate_dimension (size, &tail); + if (tail == NULL) + return 0; + while (isspace ((unsigned char) *tail)) + tail++; + if (*tail == 'x') + tail++; + else if (*tail == 'b' && tail[1] == 'y') + tail += 2; + else + { + msg (SE, _("`x' expected in paper size `%s'."), size); + return 0; + } + *v = outp_evaluate_dimension (tail, &tail); + if (tail == NULL) + return 0; + while (isspace ((unsigned char) *tail)) + tail++; + if (*tail) + { + msg (SE, _("Trailing garbage `%s' on paper size `%s'."), tail, size); + return 0; + } + + return 1; +} + +/* Stores the dimensions, in 1/72000" units, of paper identified by + SIZE into *H and *V. SIZE may be a pair of dimensions of form `H x + V', or it may be a case-insensitive paper identifier, which is + looked up in the `papersize' configuration file. Returns nonzero + on success. May modify SIZE. */ +/* Don't read further unless you've got a strong stomach. */ +int +outp_get_paper_size (char *size, int *h, int *v) +{ + struct paper_size + { + char *name; + int use; + int h, v; + }; + + static struct paper_size cache[4]; + static int use; + + FILE *f; + char *pprsz_fn; + + struct string line; + struct file_locator where; + + int free_it = 0; + int result = 0; + int min_value, min_index; + char *ep; + int i; + + while (isspace ((unsigned char) *size)) + size++; + if (isdigit ((unsigned char) *size)) + return internal_get_paper_size (size, h, v); + ep = size; + while (*ep) + ep++; + while (isspace ((unsigned char) *ep) && ep >= size) + ep--; + if (ep == size) + { + msg (SE, _("Paper size name must not be empty.")); + return 0; + } + + ep++; + if (*ep) + *ep = 0; + + use++; + for (i = 0; i < 4; i++) + if (cache[i].name != NULL && !strcasecmp (cache[i].name, size)) + { + *h = cache[i].h; + *v = cache[i].v; + cache[i].use = use; + return 1; + } + + pprsz_fn = fn_search_path (fn_getenv_default ("STAT_OUTPUT_PAPERSIZE_FILE", + "papersize"), + fn_getenv_default ("STAT_OUTPUT_INIT_PATH", + config_path), + NULL); + + where.filename = pprsz_fn; + where.line_number = 0; + err_push_file_locator (&where); + + if (pprsz_fn == NULL) + { + msg (IE, _("Cannot find `papersize' configuration file.")); + goto exit; + } + + msg (VM (1), _("%s: Opening paper size definition file..."), pprsz_fn); + f = fopen (pprsz_fn, "r"); + if (!f) + { + msg (IE, _("Opening %s: %s."), pprsz_fn, strerror (errno)); + goto exit; + } + + ds_init (NULL, &line, 128); + for (;;) + { + char *cp, *bp, *ep; + + if (!ds_get_config_line (f, &line, &where)) + { + if (ferror (f)) + msg (ME, _("Reading %s: %s."), pprsz_fn, strerror (errno)); + break; + } + for (cp = ds_value (&line); isspace ((unsigned char) *cp); cp++); + if (*cp == 0) + continue; + if (*cp != '"') + goto lex_error; + for (bp = ep = cp + 1; *ep && *ep != '"'; ep++); + if (!*ep) + goto lex_error; + *ep = 0; + if (0 != strcasecmp (bp, size)) + continue; + + for (cp = ep + 1; isspace ((unsigned char) *cp); cp++); + if (*cp == '=') + { + size = xmalloc (ep - bp + 1); + strcpy (size, bp); + free_it = 1; + continue; + } + size = &ep[1]; + break; + + lex_error: + msg (IE, _("Syntax error in paper size definition.")); + } + + /* We found the one we want! */ + result = internal_get_paper_size (size, h, v); + if (result) + { + min_value = cache[0].use; + min_index = 0; + for (i = 1; i < 4; i++) + if (cache[0].use < min_value) + { + min_value = cache[i].use; + min_index = i; + } + free (cache[min_index].name); + cache[min_index].name = xstrdup (size); + cache[min_index].use = use; + cache[min_index].h = *h; + cache[min_index].v = *v; + } + +exit: + err_pop_file_locator (&where); + ds_destroy (&line); + if (free_it) + free (size); + + if (result) + msg (VM (2), _("Paper size definition file read successfully.")); + else + msg (VM (1), _("Error reading paper size definition file.")); + + return result; +} + +/* If D is NULL, returns the first enabled driver if any, NULL if + none. Otherwise D must be the last driver returned by this + function, in which case the next enabled driver is returned or NULL + if that was the last. */ +struct outp_driver * +outp_drivers (struct outp_driver *d) +{ +#if GLOBAL_DEBUGGING + struct outp_driver *orig_d = d; +#endif + + for (;;) + { + if (d == NULL) + d = outp_driver_list; + else + d = d->next; + + if (d == NULL + || (d->driver_open + && (d->device == 0 + || (d->device & disabled_devices) != d->device))) + break; + } + +#if GLOBAL_DEBUGGING + if (d && !orig_d) + { + if (iterating_driver_list++) + reentrancy (); + } + else if (orig_d && !d) + { + assert (iterating_driver_list == 1); + iterating_driver_list = 0; + } +#endif + + return d; +} + +/* Enables (if ENABLE is nonzero) or disables (if ENABLE is zero) the + device(s) given in mask DEVICE. */ +void +outp_enable_device (int enable, int device) +{ + if (enable) + disabled_devices &= ~device; + else + disabled_devices |= device; +} + +/* Ejects the paper on device D, if the page is not blank. */ +int +outp_eject_page (struct outp_driver *d) +{ + if (d->page_open == 0) + return 1; + + if (d->cp_y != 0) + { + d->cp_x = d->cp_y = 0; + + if (d->class->close_page (d) == 0) + msg (ME, _("Error closing page on %s device of %s class."), + d->name, d->class->name); + if (d->class->open_page (d) == 0) + { + msg (ME, _("Error opening page on %s device of %s class."), + d->name, d->class->name); + return 0; + } + } + return 1; +} + +/* Returns the width of string S, in device units, when output on + device D. */ +int +outp_string_width (struct outp_driver *d, const char *s) +{ + struct outp_text text; + + text.options = OUTP_T_JUST_LEFT; + ls_init (&text.s, (char *) s, strlen (s)); + d->class->text_metrics (d, &text); + + return text.h; +} diff --git a/src/output.h b/src/output.h new file mode 100644 index 00000000..00e5b23d --- /dev/null +++ b/src/output.h @@ -0,0 +1,289 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !output_h +#define output_h 1 + +#include "str.h" + +/* A rectangle. */ +struct rect + { + int x1, y1; /* Upper left. */ + int x2, y2; /* Lower right, not part of the rectangle. */ + }; + +#if __GNUC__ > 1 && defined(__OPTIMIZE__) +extern inline int width (rect r) __attribute__ ((const)); +extern inline int height (rect r) __attribute__ ((const)); + +extern inline int +width (rect r) +{ + return r.x2 - r.x1 + 1; +} + +extern inline int +height (rect r) +{ + return r.y2 - r.y1 + 1; +} +#else /* !__GNUC__ */ +#define width(R) \ + ((R).x2 - (R).x1 + 1) +#define height(R) \ + ((R).y2 - (R).y1 + 1) +#endif /* !__GNUC__ */ + +/* Color descriptor. */ +struct color + { + int flags; /* 0=normal, 1=transparent (ignore r,g,b). */ + int r; /* Red component, 0-65535. */ + int g; /* Green component, 0-65535. */ + int b; /* Blue component, 0-65535. */ + }; + +/* Mount positions for the four basic fonts. Do not change the values. */ +enum + { + OUTP_F_R, /* Roman font. */ + OUTP_F_I, /* Italic font. */ + OUTP_F_B, /* Bold font. */ + OUTP_F_BI /* Bold-italic font. */ + }; + +/* Line styles. These must match: + som.h:SLIN_* + ascii.c:ascii_line_*() + postscript.c:ps_line_*() */ +enum + { + OUTP_L_NONE = 0, /* No line. */ + OUTP_L_SINGLE = 1, /* Single line. */ + OUTP_L_DOUBLE = 2, /* Double line. */ + OUTP_L_SPECIAL = 3, /* Special line of driver-defined style. */ + + OUTP_L_COUNT /* Number of line styles. */ + }; + +/* Contains a line style for each part of an intersection. */ +struct outp_styles + { + int l; /* left */ + int t; /* top */ + int r; /* right */ + int b; /* bottom */ + }; + +/* Text display options. */ +enum + { + OUTP_T_NONE = 0, + + /* Must match tab.h:TAB_*. */ + OUTP_T_JUST_MASK = 00003, /* Justification mask. */ + OUTP_T_JUST_RIGHT = 00000, /* Right justification. */ + OUTP_T_JUST_LEFT = 00001, /* Left justification. */ + OUTP_T_JUST_CENTER = 00002, /* Center justification. */ + + OUTP_T_HORZ = 00010, /* Horizontal size is specified. */ + OUTP_T_VERT = 00020, /* (Max) vertical size is specified. */ + + OUTP_T_0 = 00140, /* Normal orientation. */ + OUTP_T_CC90 = 00040, /* 90 degrees counterclockwise. */ + OUTP_T_CC180 = 00100, /* 180 degrees counterclockwise. */ + OUTP_T_CC270 = 00140, /* 270 degrees counterclockwise. */ + OUTP_T_C90 = 00140, /* 90 degrees clockwise. */ + OUTP_T_C180 = 00100, /* 180 degrees clockwise. */ + OUTP_T_C270 = 00040, /* 270 degrees clockwise. */ + + /* Internal use by drivers only. */ + OUTP_T_INTERNAL_DRAW = 01000 /* 1=Draw the text, 0=Metrics only. */ + }; + +/* Describes text output. */ +struct outp_text + { + /* Public. */ + int options; /* What is specified. */ + struct len_string s; /* String. */ + int h, v; /* Horizontal, vertical size. */ + int x, y; /* Position. */ + + /* Internal use only. */ + int w, l; /* Width, length. */ + }; + +struct som_table; +struct outp_driver; + +/* Defines a class of output driver. */ +struct outp_class + { + /* Basic class information. */ + const char *name; /* Name of this driver class. */ + int magic; /* Driver-specific constant. */ + int special; /* Boolean value. */ + + /* Static member functions. */ + int (*open_global) (struct outp_class *); + int (*close_global) (struct outp_class *); + int *(*font_sizes) (struct outp_class *, int *n_valid_sizes); + + /* Virtual member functions. */ + int (*preopen_driver) (struct outp_driver *); + void (*option) (struct outp_driver *, const char *key, + const struct string *value); + int (*postopen_driver) (struct outp_driver *); + int (*close_driver) (struct outp_driver *); + + int (*open_page) (struct outp_driver *); + int (*close_page) (struct outp_driver *); + + /* special != 0: Used to submit tables for output. */ + void (*submit) (struct outp_driver *, struct som_table *); + + /* special != 0: Methods below need not be defined. */ + + /* Line methods. */ + void (*line_horz) (struct outp_driver *, const struct rect *, + const struct color *, int style); + void (*line_vert) (struct outp_driver *, const struct rect *, + const struct color *, int style); + void (*line_intersection) (struct outp_driver *, const struct rect *, + const struct color *, + const struct outp_styles *style); + + /* Drawing methods. */ + void (*box) (struct outp_driver *, const struct rect *, + const struct color *bord, const struct color *fill); + void (*polyline_begin) (struct outp_driver *, const struct color *); + void (*polyline_point) (struct outp_driver *, int, int); + void (*polyline_end) (struct outp_driver *); + + /* Text methods. */ + void (*text_set_font_by_name) (struct outp_driver *, const char *s); + void (*text_set_font_by_position) (struct outp_driver *, int); + void (*text_set_font_family) (struct outp_driver *, const char *s); + const char *(*text_get_font_name) (struct outp_driver *); + const char *(*text_get_font_family) (struct outp_driver *); + int (*text_set_size) (struct outp_driver *, int); + int (*text_get_size) (struct outp_driver *, int *em_width); + void (*text_metrics) (struct outp_driver *, struct outp_text *); + void (*text_draw) (struct outp_driver *, struct outp_text *); + }; + +/* Device types. */ +enum + { + OUTP_DEV_NONE = 0, /* None of the below. */ + OUTP_DEV_LISTING = 001, /* Listing device. */ + OUTP_DEV_SCREEN = 002, /* Screen device. */ + OUTP_DEV_PRINTER = 004, /* Printer device. */ + OUTP_DEV_DISABLED = 010 /* Broken device. */ + }; + +/* Defines the configuration of an output driver. */ +struct outp_driver + { + struct outp_class *class; /* Driver class. */ + char *name; /* Name of this driver. */ + int driver_open; /* 1=driver is open, 0=driver is closed. */ + int page_open; /* 1=page is open, 0=page is closed. */ + + struct outp_driver *next, *prev; /* Next, previous output driver in list. */ + + int device; /* Zero or more of OUTP_DEV_*. */ + int res, horiz, vert; /* Device resolution. */ + int width, length; /* Page size. */ + + int cp_x, cp_y; /* Current position. */ + int font_height; /* Default font character height. */ + int prop_em_width; /* Proportional font em width. */ + int fixed_width; /* Fixed-pitch font character width. */ + int horiz_line_width[OUTP_L_COUNT]; /* Width of horizontal lines. */ + int vert_line_width[OUTP_L_COUNT]; /* Width of vertical lines. */ + int horiz_line_spacing[1 << OUTP_L_COUNT]; + int vert_line_spacing[1 << OUTP_L_COUNT]; + + void *ext; /* Private extension record. */ + void *prc; /* Per-procedure extension record. */ + }; + +/* Option structure for the keyword recognizer. */ +struct outp_option + { + const char *keyword; /* Keyword name. */ + int cat; /* Category. */ + int subcat; /* Subcategory. */ + }; + +/* Information structure for the keyword recognizer. */ +struct outp_option_info + { + char *initial; /* Initial characters. */ + struct outp_option **options; /* Search starting points. */ + }; + +/* A list of driver classes. */ +struct outp_driver_class_list + { + int ref_count; + struct outp_class *class; + struct outp_driver_class_list *next; + }; + +/* List of known output driver classes. */ +extern struct outp_driver_class_list *outp_class_list; + +/* List of configured output drivers. */ +extern struct outp_driver *outp_driver_list; + +/* Title, subtitle. */ +extern char *outp_title; +extern char *outp_subtitle; + +int outp_init (void); +int outp_read_devices (void); +int outp_done (void); + +void outp_configure_clear (void); +void outp_configure_add (char *); +void outp_configure_macro (char *); + +void outp_list_classes (void); + +void outp_enable_device (int enable, int device); +struct outp_driver *outp_drivers (struct outp_driver *); + +int outp_match_keyword (const char *, struct outp_option *, + struct outp_option_info *, int *); + +int outp_evaluate_dimension (char *, char **); +int outp_get_paper_size (char *, int *h, int *v); + +int outp_eject_page (struct outp_driver *); + +int outp_string_width (struct outp_driver *, const char *); + +/* Imported from som-frnt.c. */ +void som_destroy_driver (struct outp_driver *); + +#endif /* output.h */ diff --git a/src/pfm-read.c b/src/pfm-read.c new file mode 100644 index 00000000..d5ddd21d --- /dev/null +++ b/src/pfm-read.c @@ -0,0 +1,1065 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "file-handle.h" +#include "format.h" +#include "getline.h" +#include "magic.h" +#include "misc.h" +#include "pfm.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* pfm's file_handle extension. */ +struct pfm_fhuser_ext + { + FILE *file; /* Actual file. */ + + struct dictionary *dict; /* File's dictionary. */ + int weight_index; /* 0-based index of weight variable, or -1. */ + + unsigned char *trans; /* 256-byte character set translation table. */ + + int nvars; /* Number of variables. */ + int *vars; /* Variable widths, 0 for numeric. */ + int case_size; /* Number of `value's per case. */ + + unsigned char buf[83]; /* Input buffer. */ + unsigned char *bp; /* Buffer pointer. */ + int cc; /* Current character. */ + }; + +static struct fh_ext_class pfm_r_class; + +static int +corrupt_msg (struct file_handle *h, const char *format,...) + __attribute__ ((format (printf, 2, 3))); + +/* Displays a corruption error. */ +static int +corrupt_msg (struct file_handle *h, const char *format, ...) +{ + struct pfm_fhuser_ext *ext = h->ext; + char buf[1024]; + + { + va_list args; + + va_start (args, format); + vsnprintf (buf, 1024, format, args); + va_end (args); + } + + { + char *title; + struct error e; + + e.class = ME; + getl_location (&e.where.filename, &e.where.line_number); + e.title = title = local_alloc (strlen (h->fn) + 80); + sprintf (title, _("portable file %s corrupt at offset %ld: "), + h->fn, ftell (ext->file) - (82 - (long) (ext->bp - ext->buf))); + e.text = buf; + + err_vmsg (&e); + + local_free (title); + } + + return 0; +} + +/* Closes a portable file after we're done with it. */ +static void +pfm_close (struct file_handle * h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + if (EOF == fclose (ext->file)) + msg (ME, _("%s: Closing portable file: %s."), h->fn, strerror (errno)); + free (ext->vars); + free (ext->trans); + free (h->ext); +} + +/* Displays the message X with corrupt_msg, then jumps to the lossage + label. */ +#define lose(X) \ + do \ + { \ + corrupt_msg X; \ + goto lossage; \ + } \ + while (0) + +/* Read an 80-character line into handle H's buffer. Return + success. */ +static int +fill_buf (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + if (80 != fread (ext->buf, 1, 80, ext->file)) + lose ((h, _("Unexpected end of file."))); + + /* PORTME: line ends. */ + { + int c; + + c = getc (ext->file); + if (c != '\n' && c != '\r') + lose ((h, _("Bad line end."))); + + c = getc (ext->file); + if (c != '\n' && c != '\r') + ungetc (c, ext->file); + } + + if (ext->trans) + { + int i; + + for (i = 0; i < 80; i++) + ext->buf[i] = ext->trans[ext->buf[i]]; + } + + ext->bp = ext->buf; + + return 1; + + lossage: + return 0; +} + +/* Read a single character into cur_char. Return success; */ +static int +read_char (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + if (ext->bp >= &ext->buf[80] && !fill_buf (h)) + return 0; + ext->cc = *ext->bp++; + return 1; +} + +/* Advance a single character. */ +#define advance() if (!read_char (h)) goto lossage + +/* Skip a single character if present, and return whether it was + skipped. */ +static inline int +skip_char (struct file_handle *h, int c) +{ + struct pfm_fhuser_ext *ext = h->ext; + + if (ext->cc == c) + { + advance (); + return 1; + } + lossage: + return 0; +} + +/* Skip a single character if present, and return whether it was + skipped. */ +#define match(C) skip_char (h, C) + +static int read_header (struct file_handle *h); +static int read_version_data (struct file_handle *h, struct pfm_read_info *inf); +static int read_variables (struct file_handle *h); +static int read_value_label (struct file_handle *h); +void dump_dictionary (struct dictionary *dict); + +/* Reads the dictionary from file with handle H, and returns it in a + dictionary structure. This dictionary may be modified in order to + rename, reorder, and delete variables, etc. */ +struct dictionary * +pfm_read_dictionary (struct file_handle *h, struct pfm_read_info *inf) +{ + /* The file handle extension record. */ + struct pfm_fhuser_ext *ext; + + /* Check whether the file is already open. */ + if (h->class == &pfm_r_class) + { + ext = h->ext; + return ext->dict; + } + else if (h->class != NULL) + { + msg (ME, _("Cannot read file %s as portable file: already opened " + "for %s."), + fh_handle_name (h), h->class->name); + return NULL; + } + + msg (VM (1), _("%s: Opening portable-file handle %s for reading."), + fh_handle_filename (h), fh_handle_name (h)); + + /* Open the physical disk file. */ + ext = xmalloc (sizeof (struct pfm_fhuser_ext)); + ext->file = fopen (h->norm_fn, "rb"); + if (ext->file == NULL) + { + msg (ME, _("An error occurred while opening \"%s\" for reading " + "as a portable file: %s."), h->fn, strerror (errno)); + err_cond_fail (); + free (ext); + return NULL; + } + + /* Initialize the sfm_fhuser_ext structure. */ + h->class = &pfm_r_class; + h->ext = ext; + ext->dict = NULL; + ext->trans = NULL; + if (!fill_buf (h)) + goto lossage; + advance (); + + /* Read the header. */ + if (!read_header (h)) + goto lossage; + + /* Read version, date info, product identification. */ + if (!read_version_data (h, inf)) + goto lossage; + + /* Read variables. */ + if (!read_variables (h)) + goto lossage; + + /* Value labels. */ + while (match (77 /* D */)) + if (!read_value_label (h)) + goto lossage; + + if (!match (79 /* F */)) + lose ((h, _("Data record expected."))); + + msg (VM (2), _("Read portable-file dictionary successfully.")); + +#if DEBUGGING + dump_dictionary (ext->dict); +#endif + return ext->dict; + + lossage: + /* Come here on unsuccessful completion. */ + msg (VM (1), _("Error reading portable-file dictionary.")); + + fclose (ext->file); + if (ext && ext->dict) + free_dictionary (ext->dict); + free (ext); + h->class = NULL; + h->ext = NULL; + return NULL; +} + +/* Read a floating point value and return its value, or + second_lowest_value on error. */ +static double +read_float (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + double num = 0.; + int got_dot = 0; + int got_digit = 0; + int exponent = 0; + int neg = 0; + + /* Skip leading spaces. */ + while (match (126 /* space */)) + ; + + if (match (137 /* * */)) + { + advance (); /* Probably a dot (.) but doesn't appear to matter. */ + return SYSMIS; + } + else if (match (141 /* - */)) + neg = 1; + + for (;;) + { + if (ext->cc >= 64 /* 0 */ && ext->cc <= 93 /* T */) + { + got_digit++; + + /* Make sure that multiplication by 30 will not overflow. */ + if (num > DBL_MAX * (1. / 30.)) + /* The value of the digit doesn't matter, since we have already + gotten as many digits as can be represented in a `double'. + This doesn't necessarily mean the result will overflow. + The exponent may reduce it to within range. + + We just need to record that there was another + digit so that we can multiply by 10 later. */ + ++exponent; + else + num = (num * 30.0) + (ext->cc - 64); + + /* Keep track of the number of digits after the decimal point. + If we just divided by 30 here, we would lose precision. */ + if (got_dot) + --exponent; + } + else if (!got_dot && ext->cc == 127 /* . */) + /* Record that we have found the decimal point. */ + got_dot = 1; + else + /* Any other character terminates the number. */ + break; + + advance (); + } + + if (!got_digit) + lose ((h, "Number expected.")); + + if (ext->cc == 130 /* + */ || ext->cc == 141 /* - */) + { + /* Get the exponent. */ + long int exp = 0; + int neg_exp = ext->cc == 141 /* - */; + + for (;;) + { + advance (); + + if (ext->cc < 64 /* 0 */ || ext->cc > 93 /* T */) + break; + + if (exp > LONG_MAX / 30) + goto overflow; + exp = exp * 30 + (ext->cc - 64); + } + + /* We don't check whether there were actually any digits, but we + probably should. */ + if (neg_exp) + exp = -exp; + exponent += exp; + } + + if (!match (142 /* / */)) + lose ((h, _("Missing numeric terminator."))); + + /* Multiply NUM by 30 to the EXPONENT power, checking for overflow. */ + + if (exponent < 0) + num *= pow (30.0, (double) exponent); + else if (exponent > 0) + { + if (num > DBL_MAX * pow (30.0, (double) -exponent)) + goto overflow; + num *= pow (30.0, (double) exponent); + } + + if (neg) + return -num; + else + return num; + + overflow: + if (neg) + return -DBL_MAX / 10.; + else + return DBL_MAX / 10; + + lossage: + return second_lowest_value; +} + +/* Read an integer and return its value, or NOT_INT on failure. */ +int +read_int (struct file_handle *h) +{ + double f = read_float (h); + + if (f == second_lowest_value) + goto lossage; + if (floor (f) != f || f >= INT_MAX || f <= INT_MIN) + lose ((h, _("Bad integer format."))); + return f; + + lossage: + return NOT_INT; +} + +/* Reads a string and returns its value in a static buffer, or NULL on + failure. The buffer can be deallocated by calling with a NULL + argument. */ +static unsigned char * +read_string (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + static char *buf; + int n; + + if (h == NULL) + { + free (buf); + buf = NULL; + return NULL; + } + else if (buf == NULL) + buf = xmalloc (256); + + n = read_int (h); + if (n == NOT_INT) + return NULL; + if (n < 0 || n > 255) + lose ((h, _("Bad string length %d."), n)); + + { + int i; + + for (i = 0; i < n; i++) + { + buf[i] = ext->cc; + advance (); + } + } + + buf[n] = 0; + return buf; + + lossage: + return NULL; +} + +/* Reads the 464-byte file header. */ +int +read_header (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + /* For now at least, just ignore the vanity splash strings. */ + { + int i; + + for (i = 0; i < 200; i++) + advance (); + } + + { + unsigned char src[256]; + int trans_temp[256]; + int i; + + for (i = 0; i < 256; i++) + { + src[i] = (unsigned char) ext->cc; + advance (); + } + + for (i = 0; i < 256; i++) + trans_temp[i] = -1; + + /* 0 is used to mark untranslatable characters, so we have to mark + it specially. */ + trans_temp[src[64]] = 64; + for (i = 0; i < 256; i++) + if (trans_temp[src[i]] == -1) + trans_temp[src[i]] = i; + + ext->trans = xmalloc (256); + for (i = 0; i < 256; i++) + ext->trans[i] = trans_temp[i] == -1 ? 0 : trans_temp[i]; + + /* Translate the input buffer. */ + for (i = 0; i < 80; i++) + ext->buf[i] = ext->trans[ext->buf[i]]; + ext->cc = ext->trans[ext->cc]; + } + + { + unsigned char sig[8] = {92, 89, 92, 92, 89, 88, 91, 93}; + int i; + + for (i = 0; i < 8; i++) + if (!match (sig[i])) + lose ((h, "Missing SPSSPORT signature.")); + } + + return 1; + + lossage: + return 0; +} + +/* Reads the version and date info record, as well as product and + subproduct identification records if present. */ +int +read_version_data (struct file_handle *h, struct pfm_read_info *inf) +{ + struct pfm_fhuser_ext *ext = h->ext; + + /* Version. */ + if (!match (74 /* A */)) + lose ((h, "Unrecognized version code %d.", ext->cc)); + + /* Date. */ + { + static const int map[] = {6, 7, 8, 9, 3, 4, 0, 1}; + char *date = read_string (h); + int i; + + if (!date) + return 0; + if (strlen (date) != 8) + lose ((h, _("Bad date string length %d."), strlen (date))); + for (i = 0; i < 8; i++) + { + if (date[i] < 64 /* 0 */ || date[i] > 73 /* 9 */) + lose ((h, _("Bad character in date."))); + if (inf) + inf->creation_date[map[i]] = date[i] - 64 /* 0 */ + '0'; + } + if (inf) + { + inf->creation_date[2] = inf->creation_date[5] = ' '; + inf->creation_date[10] = 0; + } + } + + /* Time. */ + { + static const int map[] = {0, 1, 3, 4, 6, 7}; + char *time = read_string (h); + int i; + + if (!time) + return 0; + if (strlen (time) != 6) + lose ((h, _("Bad time string length %d."), strlen (time))); + for (i = 0; i < 6; i++) + { + if (time[i] < 64 /* 0 */ || time[i] > 73 /* 9 */) + lose ((h, _("Bad character in time."))); + if (inf) + inf->creation_time[map[i]] = time[i] - 64 /* 0 */ + '0'; + } + if (inf) + { + inf->creation_time[2] = inf->creation_time[5] = ' '; + inf->creation_time[8] = 0; + } + } + + /* Product. */ + if (match (65 /* 1 */)) + { + char *product; + + product = read_string (h); + if (product == NULL) + return 0; + if (inf) + strncpy (inf->product, product, 61); + } + else if (inf) + inf->product[0] = 0; + + /* Subproduct. */ + if (match (67 /* 3 */)) + { + char *subproduct; + + subproduct = read_string (h); + if (subproduct == NULL) + return 0; + if (inf) + strncpy (inf->subproduct, subproduct, 61); + } + else if (inf) + inf->subproduct[0] = 0; + return 1; + + lossage: + return 0; +} + +static int +convert_format (struct file_handle *h, int fmt[3], struct fmt_spec *v, + struct variable *vv) +{ + if (fmt[0] < 0 + || (size_t) fmt[0] >= sizeof translate_fmt / sizeof *translate_fmt) + lose ((h, _("%s: Bad format specifier byte %d."), vv->name, fmt[0])); + + v->type = translate_fmt[fmt[0]]; + v->w = fmt[1]; + v->d = fmt[2]; + + /* FIXME? Should verify the resulting specifier more thoroughly. */ + + if (v->type == -1) + lose ((h, _("%s: Bad format specifier byte (%d)."), vv->name, fmt[0])); + if ((vv->type == ALPHA) ^ ((formats[v->type].cat & FCAT_STRING) != 0)) + lose ((h, _("%s variable %s has %s format specifier %s."), + vv->type == ALPHA ? _("String") : _("Numeric"), + vv->name, + formats[v->type].cat & FCAT_STRING ? _("string") : _("numeric"), + formats[v->type].name)); + return 1; + + lossage: + return 0; +} + +/* Translation table from SPSS character code to this computer's + native character code (which is probably ASCII). */ +static const unsigned char spss2ascii[256] = + { + " " + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ." + "<(+|&[]!$*);^-/|,%_>?`:$@'=\" ~- 0123456789 -() {}\\ " + " " + }; + +/* Translate string S into ASCII. */ +static void +asciify (char *s) +{ + for (; *s; s++) + *s = spss2ascii[(unsigned char) *s]; +} + +static int parse_value (struct file_handle *, union value *, struct variable *); + +/* Read information on all the variables. */ +static int +read_variables (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + int i; + + if (!match (68 /* 4 */)) + lose ((h, _("Expected variable count record."))); + + ext->nvars = read_int (h); + if (ext->nvars <= 0 || ext->nvars == NOT_INT) + lose ((h, _("Invalid number of variables %d."), ext->nvars)); + ext->vars = xmalloc (sizeof *ext->vars * ext->nvars); + + /* Purpose of this value is unknown. It is typically 161. */ + { + int x = read_int (h); + + if (x == NOT_INT) + goto lossage; + if (x != 161) + corrupt_msg (h, _("Unexpected flag value %d."), x); + } + + ext->dict = new_dictionary (0); + + if (match (70 /* 6 */)) + { + char *name = read_string (h); + if (!name) + goto lossage; + + strcpy (ext->dict->weight_var, name); + asciify (ext->dict->weight_var); + } + + for (i = 0; i < ext->nvars; i++) + { + int width; + unsigned char *name; + int fmt[6]; + struct variable *v; + int j; + + if (!match (71 /* 7 */)) + lose ((h, _("Expected variable record."))); + + width = read_int (h); + if (width == NOT_INT) + goto lossage; + if (width < 0) + lose ((h, _("Invalid variable width %d."), width)); + ext->vars[i] = width; + + name = read_string (h); + if (name == NULL) + goto lossage; + for (j = 0; j < 6; j++) + { + fmt[j] = read_int (h); + if (fmt[j] == NOT_INT) + goto lossage; + } + + /* Verify first character of variable name. + + Weirdly enough, there is no # character in the SPSS portable + character set, so we can't check for it. */ + if (strlen (name) > 8) + lose ((h, _("position %d: Variable name has %u characters."), + i, strlen (name))); + if ((name[0] < 74 /* A */ || name[0] > 125 /* Z */) + && name[0] != 152 /* @ */) + lose ((h, _("position %d: Variable name begins with invalid " + "character."), i)); + if (name[0] >= 100 /* a */ && name[0] <= 125 /* z */) + { + corrupt_msg (h, _("position %d: Variable name begins with " + "lowercase letter %c."), + i, name[0] - 100 + 'a'); + name[0] -= 26 /* a - A */; + } + + /* Verify remaining characters of variable name. */ + for (j = 1; j < (int) strlen (name); j++) + { + int c = name[j]; + + if (c >= 100 /* a */ && c <= 125 /* z */) + { + corrupt_msg (h, _("position %d: Variable name character %d " + "is lowercase letter %c."), + i, j + 1, c - 100 + 'a'); + name[j] -= 26 /* z - Z */; + } + else if ((c >= 64 /* 0 */ && c <= 99 /* Z */) + || c == 127 /* . */ || c == 152 /* @ */ + || c == 136 /* $ */ || c == 146 /* _ */) + name[j] = c; + else + lose ((h, _("position %d: character `\\%03o' is not " + "valid in a variable name."), i, c)); + } + + asciify (name); + if (width < 0 || width > 255) + lose ((h, "Bad width %d for variable %s.", width, name)); + + v = create_variable (ext->dict, name, width ? ALPHA : NUMERIC, width); + v->get.fv = v->fv; + if (v == NULL) + lose ((h, _("Duplicate variable name %s."), name)); + if (!convert_format (h, &fmt[0], &v->print, v)) + goto lossage; + if (!convert_format (h, &fmt[3], &v->write, v)) + goto lossage; + + /* Range missing values. */ + if (match (75 /* B */)) + { + v->miss_type = MISSING_RANGE; + if (!parse_value (h, &v->missing[0], v) + || !parse_value (h, &v->missing[1], v)) + goto lossage; + } + else if (match (74 /* A */)) + { + v->miss_type = MISSING_HIGH; + if (!parse_value (h, &v->missing[0], v)) + goto lossage; + } + else if (match (73 /* 9 */)) + { + v->miss_type = MISSING_LOW; + if (!parse_value (h, &v->missing[0], v)) + goto lossage; + } + + /* Single missing values. */ + while (match (72 /* 8 */)) + { + static const int map_next[MISSING_COUNT] = + { + MISSING_1, MISSING_2, MISSING_3, -1, + MISSING_RANGE_1, MISSING_LOW_1, MISSING_HIGH_1, + -1, -1, -1, + }; + + static const int map_ofs[MISSING_COUNT] = + { + -1, 0, 1, 2, -1, -1, -1, 2, 1, 1, + }; + + v->miss_type = map_next[v->miss_type]; + if (v->miss_type == -1) + lose ((h, _("Bad missing values for %s."), v->name)); + + assert (map_ofs[v->miss_type] != -1); + if (!parse_value (h, &v->missing[map_ofs[v->miss_type]], v)) + goto lossage; + } + + if (match (76 /* C */)) + { + char *label = read_string (h); + + if (label == NULL) + goto lossage; + + v->label = xstrdup (label); + asciify (v->label); + } + } + ext->case_size = ext->dict->nval; + + if (ext->dict->weight_var[0] != 0 + && !find_dict_variable (ext->dict, ext->dict->weight_var)) + lose ((h, _("Weighting variable %s not present in dictionary."), + ext->dict->weight_var)); + + return 1; + + lossage: + return 0; +} + +/* Parse a value for variable VV into value V. Returns success. */ +static int +parse_value (struct file_handle *h, union value *v, struct variable *vv) +{ + if (vv->type == ALPHA) + { + char *mv = read_string (h); + int j; + + if (mv == NULL) + return 0; + + strncpy (v->s, mv, 8); + for (j = 0; j < 8; j++) + if (v->s[j]) + v->s[j] = spss2ascii[v->s[j]]; + else + /* Value labels are always padded with spaces. */ + v->s[j] = ' '; + } + else + { + v->f = read_float (h); + if (v->f == second_lowest_value) + return 0; + } + + return 1; +} + +/* Parse a value label record and return success. */ +static int +read_value_label (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + /* Variables. */ + int nv; + struct variable **v; + + /* Labels. */ + int n_labels; + + int i; + + nv = read_int (h); + if (nv == NOT_INT) + return 0; + + v = xmalloc (sizeof *v * nv); + for (i = 0; i < nv; i++) + { + char *name = read_string (h); + if (name == NULL) + goto lossage; + asciify (name); + + v[i] = find_dict_variable (ext->dict, name); + if (v[i] == NULL) + lose ((h, _("Unknown variable %s while parsing value labels."), name)); + + if (v[0]->width != v[i]->width) + lose ((h, _("Cannot assign value labels to %s and %s, which " + "have different variable types or widths."), + v[0]->name, v[i]->name)); + } + + n_labels = read_int (h); + if (n_labels == NOT_INT) + goto lossage; + + for (i = 0; i < n_labels; i++) + { + union value val; + char *label; + struct value_label *vl; + + int j; + + if (!parse_value (h, &val, v[0])) + goto lossage; + + label = read_string (h); + if (label == NULL) + goto lossage; + asciify (label); + + /* Create a label. */ + vl = xmalloc (sizeof *vl); + vl->v = val; + vl->s = xstrdup (label); + vl->ref_count = nv; + + /* Assign the value_label's to each variable. */ + for (j = 0; j < nv; j++) + { + struct variable *var = v[j]; + struct value_label *old; + + /* Create AVL tree if necessary. */ + if (!var->val_lab) + var->val_lab = avl_create (NULL, val_lab_cmp, + (void *) (var->width)); + + old = avl_replace (var->val_lab, vl); + if (old == NULL) + continue; + + if (var->type == NUMERIC) + lose ((h, _("Duplicate label for value %g for variable %s."), + vl->v.f, var->name)); + else + lose ((h, _("Duplicate label for value `%.*s' for variable %s."), + var->width, vl->v.s, var->name)); + + free_value_label (old); + } + } + free (v); + return 1; + + lossage: + free (v); + return 0; +} + +/* Reads one case from portable file H into the value array PERM + according to the instuctions given in associated dictionary DICT, + which must have the get.fv elements appropriately set. Returns + nonzero only if successful. */ +int +pfm_read_case (struct file_handle *h, union value *perm, struct dictionary *dict) +{ + struct pfm_fhuser_ext *ext = h->ext; + + union value *temp, *tp; + int i; + + /* Check for end of file. */ + if (ext->cc == 99 /* Z */) + return 0; + + /* The first concern is to obtain a full case relative to the data + file. (Cases in the data file have no particular relationship to + cases in the active file.) */ + tp = temp = local_alloc (sizeof *tp * ext->case_size); + for (tp = temp, i = 0; i < ext->nvars; i++) + if (ext->vars[i] == 0) + { + tp->f = read_float (h); + if (tp->f == second_lowest_value) + goto unexpected_eof; + tp++; + } + else + { + char *s = read_string (h); + if (s == NULL) + goto unexpected_eof; + asciify (s); + + st_bare_pad_copy (tp->s, s, ext->vars[i]); + tp += DIV_RND_UP (ext->vars[i], MAX_SHORT_STRING); + } + + /* Translate a case in data file format to a case in active file + format. */ + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + if (v->get.fv == -1) + continue; + + if (v->type == NUMERIC) + perm[v->fv].f = temp[v->get.fv].f; + else + memcpy (&perm[v->fv].s, &temp[v->get.fv], v->width); + } + + local_free (temp); + return 1; + + unexpected_eof: + lose ((h, _("End of file midway through case."))); + + lossage: + local_free (temp); + return 0; +} + +static struct fh_ext_class pfm_r_class = +{ + 5, + N_("reading as a portable file"), + pfm_close, +}; diff --git a/src/pfm-write.c b/src/pfm-write.c new file mode 100644 index 00000000..0683f39a --- /dev/null +++ b/src/pfm-write.c @@ -0,0 +1,510 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "error.h" +#include "file-handle.h" +#include "gmp/gmp.h" +#include "magic.h" +#include "pfm.h" +#include "str.h" +#include "var.h" +#include "version.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* pfm writer file_handle extension. */ +struct pfm_fhuser_ext + { + FILE *file; /* Actual file. */ + + int lc; /* Number of characters on this line so far. */ + + int nvars; /* Number of variables. */ + int *vars; /* Variable widths. */ + }; + +static struct fh_ext_class pfm_w_class; + +static int bufwrite (struct file_handle *h, const void *buf, size_t nbytes); +static int write_header (struct file_handle *h); +static int write_version_data (struct file_handle *h); +static int write_variables (struct file_handle *h, struct dictionary *d); +static int write_value_labels (struct file_handle *h, struct dictionary *d); + +/* Writes the dictionary DICT to portable file HANDLE. Returns + nonzero only if successful. */ +int +pfm_write_dictionary (struct file_handle *handle, struct dictionary *dict) +{ + struct pfm_fhuser_ext *ext; + + if (handle->class != NULL) + { + msg (ME, _("Cannot write file %s as portable file: already opened " + "for %s."), + fh_handle_name (handle), handle->class->name); + return 0; + } + + msg (VM (1), _("%s: Opening portable-file handle %s for writing."), + fh_handle_filename (handle), fh_handle_name (handle)); + + /* Open the physical disk file. */ + handle->class = &pfm_w_class; + handle->ext = ext = xmalloc (sizeof (struct pfm_fhuser_ext)); + ext->file = fopen (handle->norm_fn, "wb"); + ext->lc = 0; + if (ext->file == NULL) + { + msg (ME, _("An error occurred while opening \"%s\" for writing " + "as a portable file: %s."), handle->fn, strerror (errno)); + err_cond_fail (); + free (ext); + return 0; + } + + { + int i; + + ext->nvars = dict->nvar; + ext->vars = xmalloc (sizeof *ext->vars * dict->nvar); + for (i = 0; i < dict->nvar; i++) + ext->vars[i] = dict->var[i]->width; + } + + /* Write the file header. */ + if (!write_header (handle)) + goto lossage; + + /* Write version data. */ + if (!write_version_data (handle)) + goto lossage; + + /* Write variables. */ + if (!write_variables (handle, dict)) + goto lossage; + + /* Write value labels. */ + if (!write_value_labels (handle, dict)) + goto lossage; + + /* Write beginning of data marker. */ + if (!bufwrite (handle, "F", 1)) + goto lossage; + + msg (VM (2), _("Wrote portable-file header successfully.")); + + return 1; + +lossage: + msg (VM (1), _("Error writing portable-file header.")); + fclose (ext->file); + free (ext->vars); + handle->class = NULL; + handle->ext = NULL; + return 0; +} + +/* Write NBYTES starting at BUF to the portable file represented by + H. Break lines properly every 80 characters. */ +static int +bufwrite (struct file_handle *h, const void *buf, size_t nbytes) +{ + struct pfm_fhuser_ext *ext = h->ext; + + assert (buf != NULL); + while (nbytes + ext->lc >= 80) + { + size_t n = 80 - ext->lc; + + if (n && 1 != fwrite (buf, n, 1, ext->file)) + goto lossage; + + /* PORTME: line ends. */ + if (1 != fwrite ("\r\n", 2, 1, ext->file)) + goto lossage; + + nbytes -= n; + *((char **) &buf) += n; + ext->lc = 0; + } + + if (nbytes && 1 != fwrite (buf, nbytes, 1, ext->file)) + goto lossage; + ext->lc += nbytes; + + return 1; + + lossage: + abort (); + msg (ME, _("%s: Writing portable file: %s."), h->fn, strerror (errno)); + return 0; +} + +/* Write D to the portable file as a floating-point field, and return + success. */ +static int +write_float (struct file_handle *h, double d) +{ + int neg = 0; + char *mantissa; + int mantissa_len; + mp_exp_t exponent; + char *buf, *cp; + int success; + + if (d < 0.) + { + d = -d; + neg = 1; + } + + if (d == fabs (SYSMIS) || d == HUGE_VAL) + return bufwrite (h, "*.", 2); + + /* Use GNU libgmp2 to convert D into base-30. */ + { + mpf_t f; + + mpf_init_set_d (f, d); + mantissa = mpf_get_str (NULL, &exponent, 30, 0, f); + mpf_clear (f); + + for (cp = mantissa; *cp; cp++) + *cp = toupper (*cp); + } + + /* Choose standard or scientific notation. */ + mantissa_len = (int) strlen (mantissa); + cp = buf = local_alloc (mantissa_len + 32); + if (neg) + *cp++ = '-'; + if (mantissa_len == 0) + *cp++ = '0'; + else if (exponent < -4 || exponent > (mp_exp_t) mantissa_len) + { + /* Scientific notation. */ + *cp++ = mantissa[0]; + *cp++ = '.'; + cp = stpcpy (cp, &mantissa[1]); + cp = spprintf (cp, "%+ld", (long) (exponent - 1)); + } + else if (exponent <= 0) + { + /* Standard notation, D <= 1. */ + *cp++ = '.'; + memset (cp, '0', -exponent); + cp += -exponent; + cp = stpcpy (cp, mantissa); + } + else + { + /* Standard notation, D > 1. */ + memcpy (cp, mantissa, exponent); + cp += exponent; + *cp++ = '.'; + cp = stpcpy (cp, &mantissa[exponent]); + } + *cp++ = '/'; + + success = bufwrite (h, buf, cp - buf); + local_free (buf); + free (mantissa); + return success; +} + +/* Write N to the portable file as an integer field, and return success. */ +static int +write_int (struct file_handle *h, int n) +{ + char buf[64]; + char *bp = &buf[64]; + int neg = 0; + + *--bp = '/'; + + if (n < 0) + { + n = -n; + neg = 1; + } + + do + { + int r = n % 30; + + /* PORTME: character codes. */ + if (r < 10) + *--bp = r + '0'; + else + *--bp = r - 10 + 'A'; + + n /= 30; + } + while (n > 0); + + if (neg) + *--bp = '-'; + + return bufwrite (h, bp, &buf[64] - bp); +} + +/* Write S to the portable file as a string field. */ +static int +write_string (struct file_handle *h, const char *s) +{ + size_t n = strlen (s); + return write_int (h, (int) n) && bufwrite (h, s, n); +} + +/* Write file header. */ +static int +write_header (struct file_handle *h) +{ + /* PORTME. */ + { + int i; + + for (i = 0; i < 5; i++) + if (!bufwrite (h, "ASCII SPSS PORT FILE ", 40)) + return 0; + } + + { + /* PORTME: Translation table from SPSS character code to this + computer's native character code (which is probably ASCII). */ + static const unsigned char spss2ascii[256] = + { + "0000000000000000000000000000000000000000000000000000000000000000" + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz ." + "<(+|&[]!$*);^-/|,%_>?`:$@'=\"000000~-0000123456789000-()0{}\\00000" + "0000000000000000000000000000000000000000000000000000000000000000" + }; + + if (!bufwrite (h, spss2ascii, 256)) + return 0; + } + + if (!bufwrite (h, "SPSSPORT", 8)) + return 0; + + return 1; +} + +/* Writes version, date, and identification records. */ +static int +write_version_data (struct file_handle *h) +{ + if (!bufwrite (h, "A", 1)) + return 0; + + { + char date_str[9]; + char time_str[7]; + time_t t; + struct tm tm; + struct tm *tmp; + + if ((time_t) -1 == time (&t)) + { + tm.tm_sec = tm.tm_min = tm.tm_hour = tm.tm_mon = tm.tm_year = 0; + tm.tm_mday = 1; + tmp = &tm; + } + else + tmp = localtime (&t); + + sprintf (date_str, "%04d%02d%02d", + tmp->tm_year + 1900, tmp->tm_mon + 1, tmp->tm_mday); + sprintf (time_str, "%02d%02d%02d", tmp->tm_hour, tmp->tm_min, tmp->tm_sec); + if (!write_string (h, date_str) || !write_string (h, time_str)) + return 0; + } + + /* Product identification. */ + if (!bufwrite (h, "1", 1) || !write_string (h, version)) + return 0; + + /* Subproduct identification. */ + if (!bufwrite (h, "3", 1) || !write_string (h, host_system)) + return 0; + + return 1; +} + +/* Write format F to file H, and return success. */ +static int +write_format (struct file_handle *h, struct fmt_spec *f) +{ + return (write_int (h, formats[f->type].spss) + && write_int (h, f->w) + && write_int (h, f->d)); +} + +/* Write value V for variable VV to file H, and return success. */ +static int +write_value (struct file_handle *h, union value *v, struct variable *vv) +{ + if (vv->type == NUMERIC) + return write_float (h, v->f); + else + return write_int (h, vv->width) && bufwrite (h, v->s, vv->width); +} + +/* Write variable records, and return success. */ +static int +write_variables (struct file_handle *h, struct dictionary *dict) +{ + int i; + + if (!bufwrite (h, "4", 1) || !write_int (h, dict->nvar) + || !write_int (h, 161)) + return 0; + + for (i = 0; i < dict->nvar; i++) + { + static const char *miss_types[MISSING_COUNT] = + { + "", "8", "88", "888", "B ", "9", "A", "B 8", "98", "A8", + }; + + const char *m; + int j; + + struct variable *v = dict->var[i]; + + if (!bufwrite (h, "7", 1) || !write_int (h, v->width) + || !write_string (h, v->name) + || !write_format (h, &v->print) || !write_format (h, &v->write)) + return 0; + + for (m = miss_types[v->miss_type], j = 0; j < (int) strlen (m); j++) + if ((m[j] != ' ' && !bufwrite (h, &m[j], 1)) + || !write_value (h, &v->missing[j], v)) + return 0; + + if (v->label && (!bufwrite (h, "C", 1) || !write_string (h, v->label))) + return 0; + } + + return 1; +} + +/* Write value labels to disk. FIXME: Inefficient. */ +static int +write_value_labels (struct file_handle *h, struct dictionary *dict) +{ + int i; + + for (i = 0; i < dict->nvar; i++) + { + avl_traverser iter; + struct variable *v = dict->var[i]; + struct value_label *vl; + + if (v->val_lab == NULL) + continue; + + if (!bufwrite (h, "D", 1) + || !write_int (h, 1) + || !write_string (h, v->name) + || !write_int (h, avl_count (v->val_lab))) + return 0; + + avl_traverser_init (iter); + while (NULL != (vl = avl_traverse (v->val_lab, &iter))) + if (!write_value (h, &vl->v, v) + || !write_string (h, vl->s)) + return 0; + } + + return 1; +} + +/* Writes case ELEM to the portable file represented by H. Returns + success. */ +int +pfm_write_case (struct file_handle *h, const union value *elem) +{ + struct pfm_fhuser_ext *ext = h->ext; + + int i; + + for (i = 0; i < ext->nvars; i++) + { + const int width = ext->vars[i]; + + if (width == 0) + { + if (!write_float (h, elem[i].f)) + return 0; + } + else + { + if (!write_int (h, width) || !bufwrite (h, elem->c, width)) + return 0; + } + } + + return 1; +} + +/* Closes a portable file after we're done with it. */ +static void +pfm_close (struct file_handle *h) +{ + struct pfm_fhuser_ext *ext = h->ext; + + { + char buf[80]; + + int n = 80 - ext->lc; + if (n == 0) + n = 80; + + memset (buf, 'Z', n); + bufwrite (h, buf, n); + } + + if (EOF == fclose (ext->file)) + msg (ME, _("%s: Closing portable file: %s."), h->fn, strerror (errno)); + + free (ext->vars); + free (ext); +} + +static struct fh_ext_class pfm_w_class = +{ + 6, + N_("writing as a portable file"), + pfm_close, +}; diff --git a/src/pfm.h b/src/pfm.h new file mode 100644 index 00000000..ebf4401e --- /dev/null +++ b/src/pfm.h @@ -0,0 +1,56 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !pfm_h +#define pfm_h 1 + +/* Portable file manager (pfm). + + This module is in charge of reading and writing portable files. + pfm is an fhuser, so see file-handle.h for the fhuser interface. */ + +/* Portable file types. */ +enum + { + PFM_COMM, + PFM_TAPE + }; + +/* Information produced by pfm_read_dictionary() that doesn't fit into + a dictionary struct. */ +struct pfm_read_info + { + char creation_date[11]; /* `dd mm yyyy' plus a null. */ + char creation_time[9]; /* `hh:mm:ss' plus a null. */ + char product[61]; /* Product name plus a null. */ + char subproduct[61]; /* Subproduct name plus a null. */ + }; + +struct dictionary; +struct file_handle; +union value; + +struct dictionary *pfm_read_dictionary (struct file_handle *, + struct pfm_read_info *); +int pfm_read_case (struct file_handle *, union value *, struct dictionary *); + +int pfm_write_dictionary (struct file_handle *, struct dictionary *); +int pfm_write_case (struct file_handle *, const union value *elem); + +#endif /* !pfm_h */ diff --git a/src/pool.c b/src/pool.c new file mode 100644 index 00000000..cce54af9 --- /dev/null +++ b/src/pool.c @@ -0,0 +1,734 @@ +/* PSPP - computes sample statistics. + Copyright (C) 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if HAVE_CONFIG_H +#include +#endif +#include +#include +#include "alloc.h" +#include "pool.h" + +/* Fast, low-overhead memory block suballocator. */ +struct pool + { + struct pool *parent; /* Pool of which this pool is a subpool. */ + struct pool_block *blocks; /* Blocks owned by the pool. */ + struct pool_gizmo *gizmos; /* Other stuff owned by the pool. */ + }; + +/* Pool block. */ +struct pool_block + { + struct pool_block *prev; + struct pool_block *next; + size_t ofs; + }; + +/* Gizmo types. */ +enum + { + POOL_GIZMO_MALLOC, + POOL_GIZMO_FILE, + POOL_GIZMO_SUBPOOL, + POOL_GIZMO_REGISTERED, + }; + +/* Pool routines can maintain objects (`gizmos') as well as doing + suballocation. + This structure is used to keep track of them. */ +struct pool_gizmo + { + struct pool_gizmo *prev; + struct pool_gizmo *next; + + long serial; /* Serial number. */ + int type; /* Type of this gizmo. */ + + /* Type-dependent info. */ + union + { + FILE *file; /* POOL_GIZMO_FILE. */ + struct pool *subpool; /* POOL_GIZMO_SUBPOOL. */ + + /* POOL_GIZMO_REGISTERED. */ + struct + { + void (*free) (void *p); + void *p; + } + registered; + } + p; + }; + +/* Rounds X up to the next multiple of Y. */ +#ifndef ROUND_UP +#define ROUND_UP(X, Y) \ + (((X) + ((Y) - 1)) / (Y) * (Y)) +#endif + +/* Types that provide typically useful alignment sizes. */ +union align + { + void *op; + void (*fp) (void); + long l; + double d; + }; + +/* This should be the alignment size used by malloc(). The size of + the union above is correct, if not optimal, in all known cases. */ +#if defined (i386) || defined (__i386__) +#define ALIGN_SIZE 4 /* Save some extra memory. */ +#else +#define ALIGN_SIZE sizeof (union align) +#endif + +/* DISCRETE_BLOCKS may be declared as nonzero to prevent suballocation + of blocks. This is useful under memory debuggers like Checker + because it allows the source location of bugs to be more accurately + pinpointed. + + On the other hand, if we're testing the library, then we want to + test the library's real functionality, not its crippled, slow, + simplified functionality. */ +#if __CHECKER__ && !SELF_TEST +#define DISCRETE_BLOCKS 1 +#endif + +/* Enable debug code if appropriate. */ +#undef DEBUGGING +#if SELF_TEST +#define DEBUGGING 1 +#endif + +/* Size of each block allocated in the pool, in bytes. + Should be at least 1k. */ +#ifndef BLOCK_SIZE +#define BLOCK_SIZE 1024 +#endif + +/* Maximum size of a suballocated block. Larger blocks are allocated + directly with malloc() to avoid memory wastage at the end of a + suballocation block. */ +#ifndef MAX_SUBALLOC +#define MAX_SUBALLOC 64 +#endif + +/* Sizes of some structures with alignment padding included. */ +#define POOL_BLOCK_SIZE ROUND_UP (sizeof (struct pool_block), ALIGN_SIZE) +#define POOL_GIZMO_SIZE ROUND_UP (sizeof (struct pool_gizmo), ALIGN_SIZE) +#define POOL_SIZE ROUND_UP (sizeof (struct pool), ALIGN_SIZE) + +/* Serial number used to keep track of gizmos for mark/release. */ +static long serial = 0; + +/* Prototypes. */ +static void add_gizmo (struct pool *, struct pool_gizmo *); +static void free_gizmo (struct pool_gizmo *); +static void delete_gizmo (struct pool *, struct pool_gizmo *); + +#if !PSPP +static void *xmalloc (size_t); +static void *xrealloc (void *, size_t); +#endif + +/* General routines. */ + +/* Creates and returns a new memory pool, which allows malloc()'d + blocks to be suballocated in a time- and space-efficient manner. + The entire contents of the memory pool are freed at once. + + In addition, other objects can be associated with a memory pool. + These are released when the pool is destroyed. */ +struct pool * +pool_create (void) +{ + struct pool_block *block; + struct pool *pool; + + block = xmalloc (BLOCK_SIZE); + block->prev = block->next = block; + block->ofs = POOL_BLOCK_SIZE + POOL_SIZE; + + pool = (struct pool *) (((char *) block) + POOL_BLOCK_SIZE); + pool->parent = NULL; + pool->blocks = block; + pool->gizmos = NULL; + + return pool; +} + +/* Destroy the specified pool, including all subpools. */ +void +pool_destroy (struct pool *pool) +{ + if (pool == NULL) + return; + + if (pool->parent) + delete_gizmo (pool, + (void *) (((char *) pool) + POOL_SIZE + POOL_BLOCK_SIZE)); + + { + struct pool_gizmo *cur, *next; + + for (cur = pool->gizmos; cur; cur = next) + { + next = cur->next; + free_gizmo (cur); + } + } + + { + struct pool_block *cur, *next; + + pool->blocks->prev->next = NULL; + for (cur = pool->blocks; cur; cur = next) + { + next = cur->next; + free (cur); + } + } +} + +/* Suballocation routines. */ + +/* Allocates a memory region AMT bytes in size from POOL and returns a + pointer to the region's start. */ +void * +pool_alloc (struct pool *pool, size_t amt) +{ + assert (pool != NULL); + +#if !DISCRETE_BLOCKS /* Help identify source of bugs for Checker users. */ + if (amt <= MAX_SUBALLOC) + { + struct pool_block *b = pool->blocks; + b->ofs = ROUND_UP (b->ofs, ALIGN_SIZE); + if (b->ofs + amt <= BLOCK_SIZE) + { + void *const p = ((char *) b) + b->ofs; + b->ofs += amt; + return p; + } + + b = xmalloc (BLOCK_SIZE); + b->next = pool->blocks; + b->prev = pool->blocks->prev; + b->ofs = POOL_BLOCK_SIZE + amt; + + pool->blocks->prev->next = b; + pool->blocks = pool->blocks->prev = b; + + return ((char *) b) + POOL_BLOCK_SIZE; + } + else +#endif /* !DISCRETE_BLOCKS */ + return pool_malloc (pool, amt); +} + +/* Duplicates STRING within POOL and returns a pointer to the + duplicate. */ +char * +pool_strdup (struct pool *pool, const char *string) +{ + size_t amt; + void *p; + + assert (pool && string); + amt = strlen (string) + 1; + + /* Note that strings need not be aligned on any boundary. */ + { +#if !DISCRETE_BLOCKS + struct pool_block *const b = pool->blocks; + + if (b->ofs + amt <= BLOCK_SIZE) + { + p = ((char *) b) + b->ofs; + b->ofs += amt; + } + else +#endif + p = pool_alloc (pool, amt); + } + + memcpy (p, string, amt); + return p; +} + +/* Standard allocation routines. */ + +/* Allocates AMT bytes using malloc(), to be managed by POOL, and + returns a pointer to the beginning of the block. + If POOL is a null pointer, then allocates a normal memory block + with malloc(). */ +void * +pool_malloc (struct pool *pool, size_t amt) +{ + if (pool != NULL) + { + if (amt != 0) + { + struct pool_gizmo *g = xmalloc (amt + POOL_GIZMO_SIZE); + g->type = POOL_GIZMO_MALLOC; + add_gizmo (pool, g); + + return ((char *) g) + POOL_GIZMO_SIZE; + } + else + return NULL; + } + else + return xmalloc (amt); +} + +/* Changes the allocation size of the specified memory block P managed + by POOL to AMT bytes and returns a pointer to the beginning of the + block. + If POOL is a null pointer, then the block is reallocated in the + usual way with realloc(). */ +void * +pool_realloc (struct pool *pool, void *p, size_t amt) +{ + if (pool != NULL) + { + if (p != NULL) + { + if (amt != 0) + { + struct pool_gizmo *g; + + g = xrealloc (((char *) p) - POOL_GIZMO_SIZE, + amt + POOL_GIZMO_SIZE); + if (g->next) + g->next->prev = g; + if (g->prev) + g->prev->next = g; + else + pool->gizmos = g; + + return ((char *) g) + POOL_GIZMO_SIZE; + } + else + { + pool_free (pool, p); + return NULL; + } + } + else + return pool_malloc (pool, amt); + } + else + return xrealloc (p, amt); +} + +/* Frees block P managed by POOL. + If POOL is a null pointer, then the block is freed as usual with + free(). */ +void +pool_free (struct pool *pool, void *p) +{ + if (pool != NULL && p != NULL) + { + struct pool_gizmo *g = (void *) (((char *) p) - POOL_GIZMO_SIZE); + delete_gizmo (pool, g); + free (g); + } + else + free (p); +} + +/* Gizmo allocations. */ + +/* Creates and returns a pool as a subpool of POOL. + The subpool will be destroyed automatically when POOL is destroyed. + It may also be destroyed explicitly in advance. */ +struct pool * +pool_create_subpool (struct pool *pool) +{ + struct pool *subpool; + struct pool_gizmo *g; + + assert (pool != NULL); + subpool = pool_create (); + subpool->parent = pool; + + g = (void *) (((char *) subpool) + subpool->blocks->ofs); + subpool->blocks->ofs += POOL_GIZMO_SIZE; + + g->type = POOL_GIZMO_SUBPOOL; + g->p.subpool = subpool; + + add_gizmo (pool, g); + + return subpool; +} + +/* Opens file FILENAME with mode MODE and returns a handle to it + if successful or a null pointer if not. + The file will be closed automatically when POOL is destroyed, or it + may be closed explicitly in advance using pool_fclose. */ +FILE * +pool_fopen (struct pool *pool, const char *filename, const char *mode) +{ + FILE *f; + + assert (pool && filename && mode); + f = fopen (filename, mode); + if (f == NULL) + return NULL; + + { + struct pool_gizmo *g = pool_alloc (pool, sizeof *g); + g->type = POOL_GIZMO_FILE; + g->p.file = f; + add_gizmo (pool, g); + } + + return f; +} + +/* Closes file FILE managed by POOL. */ +int +pool_fclose (struct pool *pool, FILE *file) +{ + assert (pool && file); + if (fclose (file) == EOF) + return EOF; + + { + struct pool_gizmo *g; + + for (g = pool->gizmos; g; g = g->next) + if (g->type == POOL_GIZMO_FILE && g->p.file == file) + { + delete_gizmo (pool, g); + break; + } + } + + return 0; +} + +/* Registers FREE to be called with argument P. + P should be unique among those registered in POOL so that it can be + uniquely identified by pool_unregister(). + If not unregistered, FREE will be called with argument P when POOL + is destroyed. */ +void +pool_register (struct pool *pool, void (*free) (void *), void *p) +{ + assert (pool && free && p); + + { + struct pool_gizmo *g = pool_alloc (pool, sizeof *g); + g->type = POOL_GIZMO_REGISTERED; + g->p.registered.free = free; + g->p.registered.p = p; + add_gizmo (pool, g); + } +} + +/* Unregisters previously registered P from POOL. + Returns nonzero only if P was found to be registered in POOL. */ +int +pool_unregister (struct pool *pool, void *p) +{ + assert (pool && p); + + { + struct pool_gizmo *g; + + for (g = pool->gizmos; g; g = g->next) + if (g->type == POOL_GIZMO_REGISTERED && g->p.registered.p == p) + { + delete_gizmo (pool, g); + return 1; + } + } + + return 0; +} + +/* Partial freeing. */ + +/* Notes the state of POOL into MARK so that it may be restored + by a call to pool_release(). */ +void +pool_mark (struct pool *pool, struct pool_mark *mark) +{ + assert (pool && mark); + + mark->block = pool->blocks; + mark->ofs = pool->blocks->ofs; + + mark->serial = serial; +} + +/* Restores to POOL the state recorded in MARK. */ +void +pool_release (struct pool *pool, const struct pool_mark *mark) +{ + assert (pool && mark); + + { + struct pool_gizmo *cur, *next; + + for (cur = pool->gizmos; cur && cur->serial >= mark->serial; cur = next) + { + next = cur->next; + free_gizmo (cur); + } + + if (cur != NULL) + { + cur->prev = NULL; + pool->gizmos = cur; + } + else + pool->gizmos = NULL; + } + + { + struct pool_block *cur, *next, *last; + + last = pool->blocks->prev; + for (cur = pool->blocks; cur != mark->block; cur = next) + { + next = cur->next; + assert (next != cur); + + free (cur); + } + + cur->prev = last; + last->next = pool->blocks = cur; + + cur->ofs = mark->ofs; + } +} + +/* Private functions. */ + +/* Adds GIZMO at the beginning of POOL's gizmo list. */ +static void +add_gizmo (struct pool *pool, struct pool_gizmo *gizmo) +{ + assert (pool && gizmo); + + gizmo->next = pool->gizmos; + gizmo->prev = NULL; + if (pool->gizmos) + pool->gizmos->prev = gizmo; + pool->gizmos = gizmo; + + gizmo->serial = serial++; +} + +/* Removes GIZMO from POOL's gizmo list. */ +static void +delete_gizmo (struct pool *pool, struct pool_gizmo *gizmo) +{ + assert (pool && gizmo); + + if (gizmo->prev) + gizmo->prev->next = gizmo->next; + else + pool->gizmos = gizmo->next; + if (gizmo->next) + gizmo->next->prev = gizmo->prev; +} + +/* Frees any of GIZMO's internal state. + GIZMO's data must not be referenced after calling this function. */ +static void +free_gizmo (struct pool_gizmo *gizmo) +{ + assert (gizmo != NULL); + + switch (gizmo->type) + { + case POOL_GIZMO_MALLOC: + free (gizmo); + break; + case POOL_GIZMO_FILE: + fclose (gizmo->p.file); /* Ignore errors. */ + break; + case POOL_GIZMO_SUBPOOL: + gizmo->p.subpool->parent = NULL; + pool_destroy (gizmo->p.subpool); + break; + case POOL_GIZMO_REGISTERED: + gizmo->p.registered.free (gizmo->p.registered.p); + break; + default: + assert (0); + } +} + +/* Memory allocation. */ + +#if !PSPP +/* Allocates SIZE bytes of space using malloc(). Aborts if out of + memory. */ +static void * +xmalloc (size_t size) +{ + void *vp; + if (size == 0) + return NULL; + vp = malloc (size); + assert (vp != NULL); + if (vp == NULL) + abort (); + return vp; +} + +/* Reallocates P to be SIZE bytes long using realloc(). Aborts if out + of memory. */ +static void * +xrealloc (void *p, size_t size) +{ + if (p == NULL) + return xmalloc (size); + if (size == 0) + { + free (p); + return NULL; + } + p = realloc (p, size); + if (p == NULL) + abort (); + return p; +} +#endif /* !PSPP */ + +/* Self-test routine. */ + +#if SELF_TEST +#include +#include +#include +#include +#include + +#define N_ITERATIONS 8192 +#define N_FILES 16 + +/* Self-test routine. + This is not exhaustive, but it can be useful. */ +int +main (int argc, char **argv) +{ + int seed; + + if (argc == 2) + seed = atoi (argv[1]); + else + seed = time (0) * 257 % 32768; + + for (;;) + { + struct pool *pool; + struct pool_mark m1, m2; + FILE *files[N_FILES]; + int cur_file; + long i; + + printf ("Random number seed: %d\n", seed); + srand (seed++); + + printf ("Creating pool...\n"); + pool = pool_create (); + + printf ("Marking pool state...\n"); + pool_mark (pool, &m1); + + printf (" Populating pool with random-sized small objects...\n"); + for (i = 0; i < N_ITERATIONS; i++) + { + size_t size = rand () % MAX_SUBALLOC; + void *p = pool_alloc (pool, size); + memset (p, 0, size); + } + + printf (" Marking pool state...\n"); + pool_mark (pool, &m2); + + printf (" Populating pool with random-sized small " + "and large objects...\n"); + for (i = 0; i < N_ITERATIONS; i++) + { + size_t size = rand () % (2 * MAX_SUBALLOC); + void *p = pool_alloc (pool, size); + memset (p, 0, size); + } + + printf (" Releasing pool state...\n"); + pool_release (pool, &m2); + + printf (" Populating pool with random objects and gizmos...\n"); + for (i = 0; i < N_FILES; i++) + files[i] = NULL; + cur_file = 0; + for (i = 0; i < N_ITERATIONS; i++) + { + int type = rand () % 32; + + if (type == 0) + { + if (files[cur_file] != NULL + && EOF == pool_fclose (pool, files[cur_file])) + printf ("error on fclose: %s\n", strerror (errno)); + + files[cur_file] = pool_fopen (pool, "/dev/null", "r"); + + if (++cur_file >= N_FILES) + cur_file = 0; + } + else if (type == 1) + pool_create_subpool (pool); + else + { + size_t size = rand () % (2 * MAX_SUBALLOC); + void *p = pool_alloc (pool, size); + memset (p, 0, size); + } + } + + printf ("Releasing pool state...\n"); + pool_release (pool, &m1); + + printf ("Destroying pool...\n"); + pool_destroy (pool); + + putchar ('\n'); + } +} + +#endif /* SELF_TEST */ + +/* + Local variables: + compile-command: "gcc -DSELF_TEST=1 -W -Wall -I. -o pool_test pool.c" + End: +*/ diff --git a/src/pool.h b/src/pool.h new file mode 100644 index 00000000..117e0c5b --- /dev/null +++ b/src/pool.h @@ -0,0 +1,67 @@ +/* PSPP - computes sample statistics. + Copyright (C) 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !pool_h +#define pool_h 1 + +#include + +/* Records the state of a pool for later restoration. */ +struct pool_mark + { + /* Current block and offset into it. */ + struct pool_block *block; + size_t ofs; + + /* Current serial number to allow freeing of gizmos. */ + long serial; + }; + +/* General routines. */ +struct pool *pool_create (void); +void pool_destroy (struct pool *); + +/* Suballocation routines. */ +void *pool_alloc (struct pool *, size_t); +char *pool_strdup (struct pool *, const char *); +char *pool_strcat (struct pool *, const char *, ...); + +/* Standard allocation routines. */ +void *pool_malloc (struct pool *, size_t); +void *pool_realloc (struct pool *, void *, size_t); +void pool_free (struct pool *, void *); + +/* Gizmo allocations. */ +struct pool *pool_create_subpool (struct pool *); +FILE *pool_fopen (struct pool *, const char *, const char *); +int pool_fclose (struct pool *, FILE *); + +/* Custom allocations. */ +void pool_register (struct pool *, void (*free) (void *), void *p); +int pool_unregister (struct pool *, void *); + +/* Partial freeing. */ +void pool_mark (struct pool *, struct pool_mark *); +void pool_release (struct pool *, const struct pool_mark *); + +#if GLOBAL_DEBUGGING +void pool_dump (const struct pool *, const char *title); +#endif + +#endif /* pool.h */ diff --git a/src/postscript.c b/src/postscript.c new file mode 100644 index 00000000..8e6fa488 --- /dev/null +++ b/src/postscript.c @@ -0,0 +1,2966 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +/*this #if encloses the remainder of the file. */ +#if !NO_POSTSCRIPT + +#include +#include +#include +#include +#include + +#if HAVE_UNISTD_H +#include +#endif + +#if TIME_WITH_SYS_TIME +#include +#include +#else +#if HAVE_SYS_TIME_H +#include +#else +#include +#endif +#endif + +#include "alloc.h" +#include "bitvector.h" +#include "error.h" +#include "filename.h" +#include "font.h" +#include "getline.h" +#include "hash.h" +#include "main.h" +#include "misc.h" +#include "misc.h" +#include "output.h" +#include "version.h" + +/* FIXMEs: + + optimize-text-size not implemented. + + Line buffering is the only possibility; page buffering should also + be possible. + + max-fonts-simult + + Should add a field to give a file that has a list of fonts + typically used. + + Should add an option that tells the driver it can emit %%Include:'s. + + Should have auto-encode=true stream-edit or whatever to allow + addition to list of encodings. + + Should align fonts of different sizes along their baselines (see + text()). */ + +/* PostScript driver options: (defaults listed first) + + output-file="pspp.ps" + color=yes|no + data=clean7bit|clean8bit|binary + line-ends=lf|crlf + + paper-size=letter (see "papersize" file) + orientation=portrait|landscape + headers=on|off + + left-margin=0.5in + right-margin=0.5in + top-margin=0.5in + bottom-margin=0.5in + + font-dir=devps + prologue-file=ps-prologue + device-file=DESC + encoding-file=ps-encodings + auto-encode=true|false + + prop-font-family=T + fixed-font-family=C + font-size=10000 + + line-style=thick|double + line-gutter=0.5pt + line-spacing=0.5pt + line-width=0.5pt + line-width-thick=1pt + + optimize-text-size=1|0|2 + optimize-line-size=1|0 + max-fonts-simult=0 Max # of fonts in printer memory at once (0=infinite) + */ + +/* The number of `psus' (PostScript driver UnitS) per inch. Although + this is a #define, the value is expected never to change. If it + does, review all uses. */ +#define PSUS 72000 + +/* Magic numbers for PostScript and EPSF drivers. */ +enum + { + MAGIC_PS, + MAGIC_EPSF + }; + +/* Orientations. */ +enum + { + OTN_PORTRAIT, /* Portrait. */ + OTN_LANDSCAPE /* Landscape. */ + }; + +/* Output options. */ +enum + { + OPO_MIRROR_HORZ = 001, /* 1=Mirror across a horizontal axis. */ + OPO_MIRROR_VERT = 002, /* 1=Mirror across a vertical axis. */ + OPO_ROTATE_180 = 004, /* 1=Rotate the page 180 degrees. */ + OPO_COLOR = 010, /* 1=Enable color. */ + OPO_HEADERS = 020, /* 1=Draw headers at top of page. */ + OPO_AUTO_ENCODE = 040, /* 1=Add encodings semi-intelligently. */ + OPO_DOUBLE_LINE = 0100 /* 1=Double lines instead of thick lines. */ + }; + +/* Data allowed in output. */ +enum + { + ODA_CLEAN7BIT, /* 0x09, 0x0a, 0x0d, 0x1b...0x7e */ + ODA_CLEAN8BIT, /* 0x09, 0x0a, 0x0d, 0x1b...0xff */ + ODA_BINARY, /* 0x00...0xff */ + ODA_COUNT + }; + +/* Types of lines for purpose of caching. */ +enum + { + horz, /* Single horizontal. */ + dbl_horz, /* Double horizontal. */ + spl_horz, /* Special horizontal. */ + vert, /* Single vertical. */ + dbl_vert, /* Double vertical. */ + spl_vert, /* Special vertical. */ + n_line_types + }; + +/* Cached line. */ +struct line_form + { + int ind; /* Independent var. Don't reorder. */ + int mdep; /* Maximum number of dependent var pairs. */ + int ndep; /* Current number of dependent var pairs. */ + int dep[1][2]; /* Dependent var pairs. */ + }; + +/* Contents of ps_driver_ext.loaded. */ +struct font_entry + { + char *dit; /* Font Groff name. */ + struct font_desc *font; /* Font descriptor. */ + }; + +/* Combines a font with a font size for benefit of generated code. */ +struct ps_font_combo + { + struct font_entry *font; /* Font. */ + int size; /* Font size. */ + int index; /* PostScript index. */ + }; + +/* A font encoding. */ +struct ps_encoding + { + char *filename; /* Normalized filename of this encoding. */ + int index; /* Index value. */ + }; + +/* PostScript output driver extension record. */ +struct ps_driver_ext + { + /* User parameters. */ + int orientation; /* OTN_PORTRAIT or OTN_LANDSCAPE. */ + int output_options; /* OPO_*. */ + int data; /* ODA_*. */ + + int left_margin; /* Left margin in psus. */ + int right_margin; /* Right margin in psus. */ + int top_margin; /* Top margin in psus. */ + int bottom_margin; /* Bottom margin in psus. */ + + char eol[3]; /* End of line--CR, LF, or CRLF. */ + + char *font_dir; /* Font directory relative to font path. */ + char *prologue_fn; /* Prologue's filename relative to font dir. */ + char *desc_fn; /* DESC filename relative to font dir. */ + char *encoding_fn; /* Encoding's filename relative to font dir. */ + + char *prop_family; /* Default proportional font family. */ + char *fixed_family; /* Default fixed-pitch font family. */ + int font_size; /* Default font size (psus). */ + + int line_gutter; /* Space around lines. */ + int line_space; /* Space between lines. */ + int line_width; /* Width of lines. */ + int line_width_thick; /* Width of thick lines. */ + + int text_opt; /* Text optimization level. */ + int line_opt; /* Line optimization level. */ + int max_fonts; /* Max # of simultaneous fonts (0=infinite). */ + + /* Internal state. */ + struct file_ext file; /* Output file. */ + int page_number; /* Current page number. */ + int file_page_number; /* Page number in this file. */ + int w, l; /* Paper size. */ + struct hsh_table *lines[n_line_types]; /* Line buffers. */ + + struct font_entry *prop; /* Default Roman proportional font. */ + struct font_entry *fixed; /* Default Roman fixed-pitch font. */ + struct hsh_table *loaded; /* Fonts in memory. */ + + struct hsh_table *combos; /* Combinations of fonts with font sizes. */ + struct ps_font_combo *last_font; /* PostScript selected font. */ + int next_combo; /* Next font combo position index. */ + + struct hsh_table *encodings;/* Set of encodings. */ + int next_encoding; /* Next font encoding index. */ + + /* Currently selected font. */ + struct font_entry *current; /* Current font. */ + char *family; /* Font family. */ + int size; /* Size in psus. */ + } +ps_driver_ext; + +/* Transform logical y-ordinate Y into a page ordinate. */ +#define YT(Y) (this->length - (Y)) + +/* Prototypes. */ +static int postopen (struct file_ext *); +static int preclose (struct file_ext *); +static void draw_headers (struct outp_driver *this); + +static int compare_font_entry (const void *, const void *, void *param); +static unsigned hash_font_entry (const void *, void *param); +static void free_font_entry (void *, void *foo); +static struct font_entry *load_font (struct outp_driver *, const char *dit); +static void init_fonts (void); + +static void dump_lines (struct outp_driver *this); + +static void read_ps_encodings (struct outp_driver *this); +static int compare_ps_encoding (const void *pa, const void *pb, void *foo); +static unsigned hash_ps_encoding (const void *pa, void *foo); +static void free_ps_encoding (void *a, void *foo); +static void add_encoding (struct outp_driver *this, char *filename); +static struct ps_encoding *default_encoding (struct outp_driver *this); + +static int compare_ps_combo (const void *pa, const void *pb, void *foo); +static unsigned hash_ps_combo (const void *pa, void *foo); +static void free_ps_combo (void *a, void *foo); + +static char *quote_ps_name (char *dest, const char *string); +static char *quote_ps_string (char *dest, const char *string); + +/* Driver initialization. */ + +int +ps_open_global (struct outp_class *this unused) +{ + init_fonts (); + groff_init (); + return 1; +} + +int +ps_close_global (struct outp_class *this unused) +{ + return 1; +} + +int * +ps_font_sizes (struct outp_class *this unused, int *n_valid_sizes) +{ + /* Allow fonts up to 1" in height. */ + static int valid_sizes[] = + {1, PSUS, 0, 0}; + + assert (n_valid_sizes != NULL); + *n_valid_sizes = 1; + return valid_sizes; +} + +int +ps_preopen_driver (struct outp_driver *this) +{ + struct ps_driver_ext *x; + + int i; + + assert (this->driver_open == 0); + msg (VM (1), _("PostScript driver initializing as `%s'..."), this->name); + + this->ext = x = xmalloc (sizeof (struct ps_driver_ext)); + this->res = PSUS; + this->horiz = this->vert = 1; + this->width = this->length = 0; + + x->orientation = OTN_PORTRAIT; + x->output_options = OPO_COLOR | OPO_HEADERS | OPO_AUTO_ENCODE; + x->data = ODA_CLEAN7BIT; + + x->left_margin = x->right_margin = + x->top_margin = x->bottom_margin = PSUS / 2; + + strcpy (x->eol, "\n"); + + x->font_dir = NULL; + x->prologue_fn = NULL; + x->desc_fn = NULL; + x->encoding_fn = NULL; + + x->prop_family = NULL; + x->fixed_family = NULL; + x->font_size = PSUS * 10 / 72; + + x->line_gutter = PSUS / 144; + x->line_space = PSUS / 144; + x->line_width = PSUS / 144; + x->line_width_thick = PSUS / 48; + + x->text_opt = -1; + x->line_opt = -1; + x->max_fonts = 0; + + x->file.filename = NULL; + x->file.mode = "wb"; + x->file.file = NULL; + x->file.sequence_no = &x->page_number; + x->file.param = this; + x->file.postopen = postopen; + x->file.preclose = preclose; + x->page_number = 0; + x->w = x->l = 0; + + x->file_page_number = 0; + for (i = 0; i < n_line_types; i++) + x->lines[i] = NULL; + x->last_font = NULL; + + x->prop = NULL; + x->fixed = NULL; + x->loaded = NULL; + + x->next_combo = 0; + x->combos = NULL; + + x->encodings = hsh_create (31, compare_ps_encoding, hash_ps_encoding, + free_ps_encoding, NULL); + x->next_encoding = 0; + + x->current = NULL; + x->family = NULL; + x->size = 0; + + return 1; +} + +int +ps_postopen_driver (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open == 0); + + if (this->width == 0) + { + this->width = PSUS * 17 / 2; /* Defaults to 8.5"x11". */ + this->length = PSUS * 11; + } + + if (x->text_opt == -1) + x->text_opt = (this->device & OUTP_DEV_SCREEN) ? 0 : 1; + if (x->line_opt == -1) + x->line_opt = (this->device & OUTP_DEV_SCREEN) ? 0 : 1; + + x->w = this->width; + x->l = this->length; + if (x->orientation == OTN_LANDSCAPE) + { + int temp = this->width; + this->width = this->length; + this->length = temp; + } + this->width -= x->left_margin + x->right_margin; + this->length -= x->top_margin + x->bottom_margin; + if (x->output_options & OPO_HEADERS) + { + this->length -= 3 * x->font_size; + x->top_margin += 3 * x->font_size; + } + if (NULL == x->file.filename) + x->file.filename = xstrdup ("pspp.ps"); + + if (x->font_dir == NULL) + x->font_dir = xstrdup ("devps"); + if (x->prologue_fn == NULL) + x->prologue_fn = xstrdup ("ps-prologue"); + if (x->desc_fn == NULL) + x->desc_fn = xstrdup ("DESC"); + if (x->encoding_fn == NULL) + x->encoding_fn = xstrdup ("ps-encodings"); + + if (x->prop_family == NULL) + x->prop_family = xstrdup ("H"); + if (x->fixed_family == NULL) + x->fixed_family = xstrdup ("C"); + + read_ps_encodings (this); + + x->family = NULL; + x->size = PSUS / 6; + + if (this->length / x->font_size < 15) + { + msg (SE, _("PostScript driver: The defined page is not long " + "enough to hold margins and headers, plus least 15 " + "lines of the default fonts. In fact, there's only " + "room for %d lines of each font at the default size " + "of %d.%03d points."), + this->length / x->font_size, + x->font_size / 1000, x->font_size % 1000); + return 0; + } + + this->driver_open = 1; + msg (VM (2), _("%s: Initialization complete."), this->name); + + return 1; +} + +int +ps_close_driver (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + int i; + + assert (this->driver_open == 1); + msg (VM (2), _("%s: Beginning closing..."), this->name); + + fn_close_ext (&x->file); + free (x->file.filename); + free (x->font_dir); + free (x->prologue_fn); + free (x->desc_fn); + free (x->encoding_fn); + free (x->prop_family); + free (x->fixed_family); + free (x->family); + for (i = 0; i < n_line_types; i++) + hsh_destroy (x->lines[i]); + hsh_destroy (x->encodings); + hsh_destroy (x->combos); + hsh_destroy (x->loaded); + free (x); + + this->driver_open = 0; + msg (VM (3), _("%s: Finished closing."), this->name); + + return 1; +} + +/* font_entry comparison function for hash tables. */ +static int +compare_font_entry (const void *a, const void *b, void *foobar unused) +{ + return strcmp (((struct font_entry *) a)->dit, ((struct font_entry *) b)->dit); +} + +/* font_entry hash function for hash tables. */ +static unsigned +hash_font_entry (const void *a, void *foobar unused) +{ + return hashpjw (((struct font_entry *) a)->dit); +} + +/* font_entry destructor function for hash tables. */ +static void +free_font_entry (void *pa, void *foo unused) +{ + struct font_entry *a = pa; + free (a->dit); + free (a); +} + +/* Generic option types. */ +enum +{ + boolean_arg = -10, + pos_int_arg, + dimension_arg, + string_arg, + nonneg_int_arg +}; + +/* All the options that the PostScript driver supports. */ +static struct outp_option option_tab[] = +{ + /* *INDENT-OFF* */ + {"output-file", 1, 0}, + {"paper-size", 2, 0}, + {"orientation", 3, 0}, + {"color", boolean_arg, 0}, + {"data", 4, 0}, + {"auto-encode", boolean_arg, 5}, + {"headers", boolean_arg, 1}, + {"left-margin", pos_int_arg, 0}, + {"right-margin", pos_int_arg, 1}, + {"top-margin", pos_int_arg, 2}, + {"bottom-margin", pos_int_arg, 3}, + {"font-dir", string_arg, 0}, + {"prologue-file", string_arg, 1}, + {"device-file", string_arg, 2}, + {"encoding-file", string_arg, 3}, + {"prop-font-family", string_arg, 5}, + {"fixed-font-family", string_arg, 6}, + {"font-size", pos_int_arg, 4}, + {"optimize-text-size", nonneg_int_arg, 0}, + {"optimize-line-size", nonneg_int_arg, 1}, + {"max-fonts-simult", nonneg_int_arg, 2}, + {"line-ends", 6, 0}, + {"line-style", 7, 0}, + {"line-width", dimension_arg, 2}, + {"line-gutter", dimension_arg, 3}, + {"line-width", dimension_arg, 4}, + {"line-width-thick", dimension_arg, 5}, + {"", 0, 0}, + /* *INDENT-ON* */ +}; +static struct outp_option_info option_info; + +void +ps_option (struct outp_driver *this, const char *key, const struct string *val) +{ + struct ps_driver_ext *x = this->ext; + int cat, subcat; + char *value = ds_value (val); + + cat = outp_match_keyword (key, option_tab, &option_info, &subcat); + + switch (cat) + { + case 0: + msg (SE, _("Unknown configuration parameter `%s' for PostScript device " + "driver."), key); + break; + case 1: + free (x->file.filename); + x->file.filename = xstrdup (value); + break; + case 2: + outp_get_paper_size (value, &this->width, &this->length); + break; + case 3: + if (!strcmp (value, "portrait")) + x->orientation = OTN_PORTRAIT; + else if (!strcmp (value, "landscape")) + x->orientation = OTN_LANDSCAPE; + else + msg (SE, _("Unknown orientation `%s'. Valid orientations are " + "`portrait' and `landscape'."), value); + break; + case 4: + if (!strcmp (value, "clean7bit") || !strcmp (value, "Clean7Bit")) + x->data = ODA_CLEAN7BIT; + else if (!strcmp (value, "clean8bit") + || !strcmp (value, "Clean8Bit")) + x->data = ODA_CLEAN8BIT; + else if (!strcmp (value, "binary") || !strcmp (value, "Binary")) + x->data = ODA_BINARY; + else + msg (SE, _("Unknown value for `data'. Valid values are `clean7bit', " + "`clean8bit', and `binary'.")); + break; + case 6: + if (!strcmp (value, "lf")) + strcpy (x->eol, "\n"); + else if (!strcmp (value, "crlf")) + strcpy (x->eol, "\r\n"); + else + msg (SE, _("Unknown value for `line-ends'. Valid values are `lf' and " + "`crlf'.")); + break; + case 7: + if (!strcmp (value, "thick")) + x->output_options &= ~OPO_DOUBLE_LINE; + else if (!strcmp (value, "double")) + x->output_options |= OPO_DOUBLE_LINE; + else + msg (SE, _("Unknown value for `line-style'. Valid values are `thick' " + "and `double'.")); + break; + case boolean_arg: + { + int setting; + int mask; + + if (!strcmp (value, "on") || !strcmp (value, "true") + || !strcmp (value, "yes") || atoi (value)) + setting = 1; + else if (!strcmp (value, "off") || !strcmp (value, "false") + || !strcmp (value, "no") || !strcmp (value, "0")) + setting = 0; + else + { + msg (SE, _("Boolean value expected for %s."), key); + return; + } + switch (subcat) + { + case 0: + mask = OPO_COLOR; + break; + case 1: + mask = OPO_HEADERS; + break; + case 2: + mask = OPO_MIRROR_HORZ; + break; + case 3: + mask = OPO_MIRROR_VERT; + break; + case 4: + mask = OPO_ROTATE_180; + break; + case 5: + mask = OPO_AUTO_ENCODE; + break; + default: + assert (0); + } + if (setting) + x->output_options |= mask; + else + x->output_options &= ~mask; + } + break; + case pos_int_arg: + { + char *tail; + int arg; + + errno = 0; + arg = strtol (value, &tail, 0); + if (arg < 1 || errno == ERANGE || *tail) + { + msg (SE, _("Positive integer required as value for `%s'."), key); + break; + } + if ((subcat == 4 || subcat == 5) && arg < 1000) + { + msg (SE, _("Default font size must be at least 1 point (value " + "of 1000 for key `%s')."), key); + break; + } + switch (subcat) + { + case 0: + x->left_margin = arg; + break; + case 1: + x->right_margin = arg; + break; + case 2: + x->top_margin = arg; + break; + case 3: + x->bottom_margin = arg; + break; + case 4: + x->font_size = arg; + break; + default: + assert (0); + } + } + break; + case dimension_arg: + { + int dimension = outp_evaluate_dimension (value, NULL); + + if (dimension <= 0) + { + msg (SE, _("Value for `%s' must be a dimension of positive " + "length (i.e., `1in')."), key); + break; + } + switch (subcat) + { + case 2: + x->line_width = dimension; + break; + case 3: + x->line_gutter = dimension; + break; + case 4: + x->line_width = dimension; + break; + case 5: + x->line_width_thick = dimension; + break; + default: + assert (0); + } + } + break; + case string_arg: + { + char **dest; + switch (subcat) + { + case 0: + dest = &x->font_dir; + break; + case 1: + dest = &x->prologue_fn; + break; + case 2: + dest = &x->desc_fn; + break; + case 3: + dest = &x->encoding_fn; + break; + case 5: + dest = &x->prop_family; + break; + case 6: + dest = &x->fixed_family; + break; + default: + assert (0); + } + if (*dest) + free (*dest); + *dest = xstrdup (value); + } + break; + case nonneg_int_arg: + { + char *tail; + int arg; + + errno = 0; + arg = strtol (value, &tail, 0); + if (arg < 0 || errno == ERANGE || *tail) + { + msg (SE, _("Nonnegative integer required as value for `%s'."), key); + break; + } + switch (subcat) + { + case 0: + x->text_opt = arg; + break; + case 1: + x->line_opt = arg; + break; + case 2: + x->max_fonts = arg; + break; + default: + assert (0); + } + } + break; +#if __CHECKER__ + case 42000: + assert (0); +#endif + default: + assert (0); + } +} + +/* Looks for a PostScript font file or config file in all the + appropriate places. Returns the filename on success, NULL on + failure. */ +/* PORTME: Filename operations. */ +static char * +find_ps_file (struct outp_driver *this, const char *name) +{ + struct ps_driver_ext *x = this->ext; + char *cp; + + /* x->font_dir + name: "devps/ps-encodings". */ + char *basename; + + /* Usually equal to groff_font_path. */ + char *pathname; + + /* Final filename. */ + char *fn; + + /* Make basename. */ + basename = local_alloc (strlen (x->font_dir) + 1 + strlen (name) + 1); + cp = stpcpy (basename, x->font_dir); + *cp++ = DIR_SEPARATOR; + strcpy (cp, name); + + /* Decide on search path. */ + { + const char *pre_pathname; + + pre_pathname = getenv ("STAT_GROFF_FONT_PATH"); + if (pre_pathname == NULL) + pre_pathname = getenv ("GROFF_FONT_PATH"); + if (pre_pathname == NULL) + pre_pathname = groff_font_path; + pathname = fn_tilde_expand (pre_pathname); + } + + /* Search all possible places for the file. */ + fn = fn_search_path (basename, pathname, NULL); + if (fn == NULL) + fn = fn_search_path (basename, config_path, NULL); + if (fn == NULL) + fn = fn_search_path (name, pathname, NULL); + if (fn == NULL) + fn = fn_search_path (name, config_path, NULL); + free (pathname); + local_free (basename); + + return fn; +} + +/* Encodings. */ + +/* Hash table comparison function for ps_encoding's. */ +static int +compare_ps_encoding (const void *pa, const void *pb, void *foo unused) +{ + const struct ps_encoding *a = pa; + const struct ps_encoding *b = pb; + + return strcmp (a->filename, b->filename); +} + +/* Hash table hash function for ps_encoding's. */ +static unsigned +hash_ps_encoding (const void *pa, void *foo unused) +{ + const struct ps_encoding *a = pa; + + return hashpjw (a->filename); +} + +/* Hash table free function for ps_encoding's. */ +static void +free_ps_encoding (void *pa, void *foo unused) +{ + struct ps_encoding *a = pa; + + free (a->filename); + free (a); +} + +/* Iterates through the list of encodings used for this driver + instance, reads each of them from disk, and writes them as + PostScript code to the output file. */ +static void +output_encodings (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + struct hsh_iterator iter; + struct ps_encoding *pe; + + struct string line, buf; + + ds_init (NULL, &line, 128); + ds_init (NULL, &buf, 128); + hsh_iterator_init (iter); + while ((pe = hsh_foreach (x->encodings, &iter)) != NULL) + { + FILE *f; + + msg (VM (1), _("%s: %s: Opening PostScript font encoding..."), + this->name, pe->filename); + + f = fopen (pe->filename, "r"); + if (!f) + { + msg (IE, _("PostScript driver: Cannot open encoding file `%s': %s. " + "Substituting ISOLatin1Encoding for missing encoding."), + pe->filename, strerror (errno)); + fprintf (x->file.file, "/E%x ISOLatin1Encoding def%s", + pe->index, x->eol); + } + else + { + struct file_locator where; + + const char *tab[256]; + + char *pschar; + char *code; + int code_val; + char *fubar; + + const char *notdef = ".notdef"; + + int i; + + for (i = 0; i < 256; i++) + tab[i] = notdef; + + where.filename = pe->filename; + where.line_number = 0; + err_push_file_locator (&where); + + while (ds_get_config_line (f, &buf, &where)) + { + char *sp; + + pschar = strtok_r (ds_value (&buf), " \t\r\n", &sp); + code = strtok_r (NULL, " \t\r\n", &sp); + if (*pschar == 0 || *code == 0) + continue; + code_val = strtol (code, &fubar, 0); + if (*fubar) + { + msg (IS, _("PostScript driver: Invalid numeric format.")); + continue; + } + if (code_val < 0 || code_val > 255) + { + msg (IS, _("PostScript driver: Codes must be between 0 " + "and 255. (%d is not allowed.)"), code_val); + break; + } + tab[code_val] = local_alloc (strlen (pschar) + 1); + strcpy ((char *) (tab[code_val]), pschar); + } + err_pop_file_locator (&where); + + ds_clear (&line); + ds_printf (&line, "/E%x[", pe->index); + for (i = 0; i < 257; i++) + { + char temp[288]; + + if (i < 256) + { + quote_ps_name (temp, tab[i]); + if (tab[i] != notdef) + local_free (tab[i]); + } + else + strcpy (temp, "]def"); + + if (ds_length (&line) + strlen (temp) > 70) + { + ds_concat (&line, x->eol); + fputs (ds_value (&line), x->file.file); + ds_clear (&line); + } + ds_concat (&line, temp); + } + ds_concat (&line, x->eol); + fputs (ds_value (&line), x->file.file); + + if (fclose (f) == EOF) + msg (MW, _("PostScript driver: Error closing encoding file `%s'."), + pe->filename); + + msg (VM (2), _("%s: PostScript font encoding read successfully."), + this->name); + } + } + ds_destroy (&line); + ds_destroy (&buf); +} + +/* Finds the ps_encoding in THIS that corresponds to the file with + name NORM_FILENAME, which must have previously been normalized with + normalize_filename(). */ +static struct ps_encoding * +get_encoding (struct outp_driver *this, const char *norm_filename) +{ + struct ps_driver_ext *x = this->ext; + struct ps_encoding *pe; + + pe = (struct ps_encoding *) hsh_find (x->encodings, (void *) &norm_filename); + return pe; +} + +/* Searches the filesystem for an encoding file with name FILENAME; + returns its malloc'd, normalized name if found, otherwise NULL. */ +static char * +find_encoding_file (struct outp_driver *this, char *filename) +{ + char *cp, *temp; + + if (filename == NULL) + return NULL; + while (isspace ((unsigned char) *filename)) + filename++; + for (cp = filename; *cp && !isspace ((unsigned char) *cp); cp++) + ; + if (cp == filename) + return NULL; + *cp = 0; + + temp = find_ps_file (this, filename); + if (temp == NULL) + return NULL; + + filename = fn_normalize (temp); + assert (filename != NULL); + free (temp); + + return filename; +} + +/* Adds the encoding represented by the not-necessarily-normalized + file FILENAME to the list of encodings, if it exists and is not + already in the list. */ +static void +add_encoding (struct outp_driver *this, char *filename) +{ + struct ps_driver_ext *x = this->ext; + + struct ps_encoding **pe; + + filename = find_encoding_file (this, filename); + if (!filename) + return; + + pe = (struct ps_encoding **) hsh_probe (x->encodings, (void *) &filename); + if (*pe) + { + free (filename); + return; + } + *pe = xmalloc (sizeof **pe); + (*pe)->filename = filename; + (*pe)->index = x->next_encoding++; +} + +/* Finds the file on disk that contains the list of encodings to + include in the output file, then adds those encodings to the list + of encodings. */ +static void +read_ps_encodings (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + /* Encodings file. */ + char *encoding_fn; /* `ps-encodings' filename. */ + FILE *f; + + struct string line; + struct file_locator where; + + /* It's okay if there's no list of encodings; not everyone cares. */ + encoding_fn = find_ps_file (this, x->encoding_fn); + if (encoding_fn == NULL) + return; + free (encoding_fn); + + msg (VM (1), _("%s: %s: Opening PostScript encoding list file."), + this->name, encoding_fn); + f = fopen (encoding_fn, "r"); + if (!f) + { + msg (IE, _("Opening %s: %s."), encoding_fn, strerror (errno)); + return; + } + + where.filename = encoding_fn; + where.line_number = 0; + err_push_file_locator (&where); + + ds_init (NULL, &line, 128); + + for (;;) + { + char *bp; + + if (!ds_get_config_line (f, &line, &where)) + { + if (ferror (f)) + msg (ME, _("Reading %s: %s."), encoding_fn, strerror (errno)); + break; + } + + add_encoding (this, bp); + } + + ds_destroy (&line); + err_pop_file_locator (&where); + + if (-1 == fclose (f)) + msg (MW, _("Closing %s: %s."), encoding_fn, strerror (errno)); + + msg (VM (2), _("%s: PostScript encoding list file read successfully."), this->name); +} + +/* Creates a default encoding for driver D that can be substituted for + an unavailable encoding. */ +struct ps_encoding * +default_encoding (struct outp_driver *d) +{ + struct ps_driver_ext *x = d->ext; + static struct ps_encoding *enc; + + if (!enc) + { + enc = xmalloc (sizeof *enc); + enc->filename = xstrdup (_("<>")); + enc->index = x->next_encoding++; + } + return enc; +} + +/* Basic file operations. */ + +/* Variables for the prologue. */ +struct ps_variable + { + const char *key; + const char *value; + }; + +static struct ps_variable *ps_var_tab; + +/* Searches ps_var_tab for a ps_variable with key KEY, and returns the + associated value. */ +static const char * +ps_get_var (const char *key) +{ + struct ps_variable *v; + + for (v = ps_var_tab; v->key; v++) + if (!strcmp (key, v->key)) + return v->value; + return NULL; +} + +/* Writes the PostScript prologue to file F. */ +static int +postopen (struct file_ext *f) +{ + static struct ps_variable dict[] = + { + {"bounding-box", 0}, + {"creator", 0}, + {"date", 0}, + {"data", 0}, + {"orientation", 0}, + {"user", 0}, + {"host", 0}, + {"prop-font", 0}, + {"fixed-font", 0}, + {"scale-factor", 0}, + {"paper-width", 0}, + {"paper-length", 0}, + {"left-margin", 0}, + {"top-margin", 0}, + {"line-width", 0}, + {"line-width-thick", 0}, + {"title", 0}, + {"source-file", 0}, + {0, 0}, + }; + char boundbox[INT_DIGITS * 4 + 4]; +#if HAVE_UNISTD_H + char host[128]; +#endif + char scaling[INT_DIGITS + 5]; + time_t curtime; + struct tm *loctime; + char *p, *cp; + char paper_width[INT_DIGITS + 1]; + char paper_length[INT_DIGITS + 1]; + char left_margin[INT_DIGITS + 1]; + char top_margin[INT_DIGITS + 1]; + char line_width[INT_DIGITS + 1]; + char line_width_thick[INT_DIGITS + 1]; + + struct outp_driver *this = f->param; + struct ps_driver_ext *x = this->ext; + + char *prologue_fn = find_ps_file (this, x->prologue_fn); + FILE *prologue_file; + + char *buf = NULL; + size_t buf_size = 0; + + x->loaded = hsh_create (31, compare_font_entry, hash_font_entry, + free_font_entry, NULL); + + { + char *font_name = local_alloc (2 + max (strlen (x->prop_family), + strlen (x->fixed_family))); + + strcpy (stpcpy (font_name, x->prop_family), "R"); + x->prop = load_font (this, font_name); + + strcpy (stpcpy (font_name, x->fixed_family), "R"); + x->fixed = load_font (this, font_name); + + local_free(font_name); + } + + x->current = x->prop; + x->family = xstrdup (x->prop_family); + x->size = x->font_size; + + { + int *h = this->horiz_line_width, *v = this->vert_line_width; + + this->cp_x = this->cp_y = 0; + this->font_height = x->font_size; + { + struct char_metrics *metric; + + metric = font_get_char_metrics (x->prop->font, '0'); + this->prop_em_width = ((metric + ? metric->width : x->prop->font->space_width) + * x->font_size / 1000); + + metric = font_get_char_metrics (x->fixed->font, '0'); + this->fixed_width = ((metric + ? metric->width : x->fixed->font->space_width) + * x->font_size / 1000); + } + + h[0] = v[0] = 0; + h[1] = v[1] = 2 * x->line_gutter + x->line_width; + if (x->output_options & OPO_DOUBLE_LINE) + h[2] = v[2] = 2 * x->line_gutter + 2 * x->line_width + x->line_space; + else + h[2] = v[2] = 2 * x->line_gutter + x->line_width_thick; + h[3] = v[3] = 2 * x->line_gutter + x->line_width; + + { + int i; + + for (i = 0; i < (1 << OUTP_L_COUNT); i++) + { + int bit; + + /* Maximum width of any line type so far. */ + int max = 0; + + for (bit = 0; bit < OUTP_L_COUNT; bit++) + if ((i & (1 << bit)) && h[bit] > max) + max = h[bit]; + this->horiz_line_spacing[i] = this->vert_line_spacing[i] = max; + } + } + } + + if (x->output_options & OPO_AUTO_ENCODE) + { + /* It's okay if this is done more than once since add_encoding() + is idempotent over identical encodings. */ + add_encoding (this, x->prop->font->encoding); + add_encoding (this, x->fixed->font->encoding); + } + + x->file_page_number = 0; + + errno = 0; + if (prologue_fn == NULL) + { + msg (IE, _("Cannot find PostScript prologue. The use of `-vv' " + "on the command line is suggested as a debugging aid.")); + return 0; + } + + msg (VM (1), _("%s: %s: Opening PostScript prologue..."), + this->name, prologue_fn); + prologue_file = fopen (prologue_fn, "rb"); + if (prologue_file == NULL) + { + fclose (prologue_file); + free (prologue_fn); + msg (IE, "%s: %s", prologue_fn, strerror (errno)); + goto error; + } + + sprintf (boundbox, "0 0 %d %d", + x->w / (PSUS / 72) + (x->w % (PSUS / 72) > 0), + x->l / (PSUS / 72) + (x->l % (PSUS / 72) > 0)); + dict[0].value = boundbox; + + dict[1].value = (char *) version; + + curtime = time (NULL); + loctime = localtime (&curtime); + dict[2].value = asctime (loctime); + cp = strchr (dict[2].value, '\n'); + if (cp) + *cp = 0; + + switch (x->data) + { + case ODA_CLEAN7BIT: + dict[3].value = "Clean7Bit"; + break; + case ODA_CLEAN8BIT: + dict[3].value = "Clean8Bit"; + break; + case ODA_BINARY: + dict[3].value = "Binary"; + break; + default: + assert (0); + } + + if (x->orientation == OTN_PORTRAIT) + dict[4].value = "Portrait"; + else + dict[4].value = "Landscape"; + + /* PORTME: Determine username, net address. */ +#if HAVE_UNISTD_H + dict[5].value = getenv ("LOGNAME"); + if (!dict[5].value) + dict[5].value = getlogin (); + if (!dict[5].value) + dict[5].value = _("nobody"); + + if (gethostname (host, 128) == -1) + { + if (errno == ENAMETOOLONG) + host[127] = 0; + else + strcpy (host, _("nowhere")); + } + dict[6].value = host; +#else /* !HAVE_UNISTD_H */ + dict[5].value = _("nobody"); + dict[6].value = _("nowhere"); +#endif /* !HAVE_UNISTD_H */ + + cp = stpcpy (p = local_alloc (288), "font "); + quote_ps_string (cp, x->prop->font->internal_name); + dict[7].value = p; + + cp = stpcpy (p = local_alloc (288), "font "); + quote_ps_string (cp, x->fixed->font->internal_name); + dict[8].value = p; + + sprintf (scaling, "%.3f", PSUS / 72.0); + dict[9].value = scaling; + + sprintf (paper_width, "%g", x->w / (PSUS / 72.0)); + dict[10].value = paper_width; + + sprintf (paper_length, "%g", x->l / (PSUS / 72.0)); + dict[11].value = paper_length; + + sprintf (left_margin, "%d", x->left_margin); + dict[12].value = left_margin; + + sprintf (top_margin, "%d", x->top_margin); + dict[13].value = top_margin; + + sprintf (line_width, "%d", x->line_width); + dict[14].value = line_width; + + sprintf (line_width, "%d", x->line_width_thick); + dict[15].value = line_width_thick; + + getl_location (&dict[17].value, NULL); + if (dict[17].value == NULL) + dict[17].value = ""; + + if (!outp_title) + { + dict[16].value = cp = local_alloc (strlen (dict[17].value) + 30); + sprintf (cp, "PSPP (%s)", dict[17].value); + } + else + { + dict[16].value = local_alloc (strlen (outp_title) + 1); + strcpy ((char *) (dict[16].value), outp_title); + } + + ps_var_tab = dict; + while (-1 != getline (&buf, &buf_size, prologue_file)) + { + char *cp; + char *buf2; + int len; + + cp = strstr (buf, "!eps"); + if (cp) + { + if (this->class->magic == MAGIC_PS) + continue; + else + *cp = '\0'; + } + else + { + cp = strstr (buf, "!ps"); + if (cp) + { + if (this->class->magic == MAGIC_EPSF) + continue; + else + *cp = '\0'; + } else { + if (strstr (buf, "!!!")) + continue; + } + } + + if (!strncmp (buf, "!encodings", 10)) + output_encodings (this); + else + { + char *beg; + beg = buf2 = fn_interp_vars (buf, ps_get_var); + len = strlen (buf2); + while (isspace (*beg)) + beg++, len--; + if (beg[len - 1] == '\n') + len--; + if (beg[len - 1] == '\r') + len--; + fwrite (beg, len, 1, f->file); + fputs (x->eol, f->file); + free (buf2); + } + } + if (ferror (f->file)) + msg (IE, _("Reading `%s': %s."), prologue_fn, strerror (errno)); + fclose (prologue_file); + + free (prologue_fn); + free (buf); + + local_free (dict[7].value); + local_free (dict[8].value); + local_free (dict[16].value); + + if (ferror (f->file)) + goto error; + + msg (VM (2), _("%s: PostScript prologue read successfully."), this->name); + return 1; + +error: + msg (VM (1), _("%s: Error reading PostScript prologue."), this->name); + return 0; +} + +/* Writes the string STRING to buffer DEST (of at least 288 + characters) as a PostScript name object. Returns a pointer + to the null terminator of the resultant string. */ +static char * +quote_ps_name (char *dest, const char *string) +{ + const char *sp; + + for (sp = string; *sp; sp++) + switch (*(unsigned char *) sp) + { + case 'a': + case 'f': + case 'k': + case 'p': + case 'u': + case 'b': + case 'g': + case 'l': + case 'q': + case 'v': + case 'c': + case 'h': + case 'm': + case 'r': + case 'w': + case 'd': + case 'i': + case 'n': + case 's': + case 'x': + case 'e': + case 'j': + case 'o': + case 't': + case 'y': + case 'z': + case 'A': + case 'F': + case 'K': + case 'P': + case 'U': + case 'B': + case 'G': + case 'L': + case 'Q': + case 'V': + case 'C': + case 'H': + case 'M': + case 'R': + case 'W': + case 'D': + case 'I': + case 'N': + case 'S': + case 'X': + case 'E': + case 'J': + case 'O': + case 'T': + case 'Y': + case 'Z': + case '@': + case '^': + case '_': + case '|': + case '!': + case '$': + case '&': + case ':': + case ';': + case '.': + case ',': + case '-': + case '+': + break; + default: + { + char *dp = dest; + + *dp++ = '<'; + for (sp = string; *sp && dp < &dest[256]; sp++) + { + sprintf (dp, "%02x", *(unsigned char *) sp); + dp += 2; + } + return stpcpy (dp, ">cvn"); + } + } + dest[0] = '/'; + return stpcpy (&dest[1], string); +} + +/* Adds the string STRING to buffer DEST as a PostScript quoted + string; returns a pointer to the null terminator added. Will not + add more than 235 characters. */ +static char * +quote_ps_string (char *dest, const char *string) +{ + const char *sp = string; + char *dp = dest; + + *dp++ = '('; + for (; *sp && dp < &dest[235]; sp++) + if (*sp == '(') + dp = stpcpy (dp, "\\("); + else if (*sp == ')') + dp = stpcpy (dp, "\\)"); + else if (*sp < 32 || *((unsigned char *) sp) > 127) + dp = spprintf (dp, "\\%3o", *sp); + else + *dp++ = *sp; + return stpcpy (dp, ")"); +} + +/* Writes the PostScript epilogue to file F. */ +static int +preclose (struct file_ext *f) +{ + struct outp_driver *this = f->param; + struct ps_driver_ext *x = this->ext; + struct hsh_iterator iter; + struct font_entry *fe; + + fprintf (f->file, + ("%%%%Trailer%s" + "%%%%Pages: %d%s" + "%%%%DocumentNeededResources:%s"), + x->eol, x->file_page_number, x->eol, x->eol); + + hsh_iterator_init (iter); + while ((fe = hsh_foreach (x->loaded, &iter)) != NULL) + { + char buf[256], *cp; + + cp = stpcpy (buf, "%%+ font "); + cp = quote_ps_string (cp, fe->font->internal_name); + strcpy (cp, x->eol); + fputs (buf, f->file); + } + + hsh_destroy (x->loaded); + x->loaded = NULL; + hsh_destroy (x->combos); + x->combos = NULL; + x->last_font = NULL; + x->next_combo = 0; + + fprintf (f->file, "%%EOF%s", x->eol); + if (ferror (f->file)) + return 0; + return 1; +} + +int +ps_open_page (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && !this->page_open); + + x->page_number++; + if (!fn_open_ext (&x->file)) + { + if (errno) + msg (ME, _("PostScript output driver: %s: %s"), x->file.filename, + strerror (errno)); + return 0; + } + x->file_page_number++; + + hsh_destroy (x->combos); + x->combos = hsh_create (31, compare_ps_combo, hash_ps_combo, + free_ps_combo, NULL); + x->last_font = NULL; + x->next_combo = 0; + + fprintf (x->file.file, + "%%%%Page: %d %d%s" + "%%%%BeginPageSetup%s" + "/pg save def 0.001 dup scale%s", + x->page_number, x->file_page_number, x->eol, + x->eol, + x->eol); + + if (x->orientation == OTN_LANDSCAPE) + fprintf (x->file.file, + "%d 0 translate 90 rotate%s", + x->w, x->eol); + + if (x->bottom_margin != 0 || x->left_margin != 0) + fprintf (x->file.file, + "%d %d translate%s", + x->left_margin, x->bottom_margin, x->eol); + + fprintf (x->file.file, + "/LW %d def/TW %d def %d setlinewidth%s" + "%%%%EndPageSetup%s", + x->line_width, x->line_width_thick, x->line_width, x->eol, + x->eol); + + if (!ferror (x->file.file)) + { + this->page_open = 1; + if (x->output_options & OPO_HEADERS) + draw_headers (this); + } + + return !ferror (x->file.file); +} + +int +ps_close_page (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + + if (x->line_opt) + dump_lines (this); + + fprintf (x->file.file, + "%%PageTrailer%s" + "EP%s", + x->eol, x->eol); + + this->page_open = 0; + return !ferror (x->file.file); +} + +/* Lines. */ + +/* qsort() comparison function for int tuples. */ +static int +int_2_compare (const void *a, const void *b) +{ + return *((const int *) a) - *((const int *) b); +} + +/* Hash table comparison function for cached lines. */ +static int +compare_line (const void *a, const void *b, void *foo unused) +{ + return ((struct line_form *) a)->ind - ((struct line_form *) b)->ind; +} + +/* Hash table hash function for cached lines. */ +static unsigned +hash_line (const void *pa, void *foo unused) +{ + const struct line_form *a = pa; + + return a->ind; +} + +/* Hash table free function for cached lines. */ +static void +free_line (void *pa, void *foo unused) +{ + free (pa); +} + +/* Writes PostScript code to draw a line from (x1,y1) to (x2,y2) to + the output file. */ +#define dump_line(x1, y1, x2, y2) \ + fprintf (ext->file.file, "%d %d %d %d L%s", \ + x1, YT (y1), x2, YT (y2), ext->eol) + +/* Write PostScript code to draw a thick line from (x1,y1) to (x2,y2) + to the output file. */ +#define dump_thick_line(x1, y1, x2, y2) \ + fprintf (ext->file.file, "%d %d %d %d TL%s", \ + x1, YT (y1), x2, YT (y2), ext->eol) + +/* Writes a line of type TYPE to THIS driver's output file. The line + (or its center, in the case of double lines) has its independent + axis coordinate at IND; it extends from DEP1 to DEP2 on the + dependent axis. */ +static void +dump_fancy_line (struct outp_driver *this, int type, int ind, int dep1, int dep2) +{ + struct ps_driver_ext *ext = this->ext; + int ofs = ext->line_space / 2 + ext->line_width / 2; + + switch (type) + { + case horz: + dump_line (dep1, ind, dep2, ind); + break; + case dbl_horz: + if (ext->output_options & OPO_DOUBLE_LINE) + { + dump_line (dep1, ind - ofs, dep2, ind - ofs); + dump_line (dep1, ind + ofs, dep2, ind + ofs); + } + else + dump_thick_line (dep1, ind, dep2, ind); + break; + case spl_horz: + assert (0); + case vert: + dump_line (ind, dep1, ind, dep2); + break; + case dbl_vert: + if (ext->output_options & OPO_DOUBLE_LINE) + { + dump_line (ind - ofs, dep1, ind - ofs, dep2); + dump_line (ind + ofs, dep1, ind + ofs, dep2); + } + else + dump_thick_line (ind, dep1, ind, dep2); + break; + case spl_vert: + assert (0); + default: + assert (0); + } +} + +#undef dump_line + +/* Writes all the cached lines to the output file, then clears the + cache. */ +static void +dump_lines (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + struct hsh_iterator iter; + struct line_form *line; + int type; + + hsh_iterator_init (iter); + for (type = 0; type < n_line_types; type++) + { + while (NULL != (line = hsh_foreach (x->lines[type], &iter))) + { + int i; + int lo = INT_MIN, hi; + + qsort (line->dep, line->ndep, sizeof *line->dep, int_2_compare); + lo = line->dep[0][0]; + hi = line->dep[0][1]; + for (i = 1; i < line->ndep; i++) + if (line->dep[i][0] <= hi + 1) + { + int min_hi = line->dep[i][1]; + if (min_hi > hi) + hi = min_hi; + } + else + { + dump_fancy_line (this, type, line->ind, lo, hi); + lo = line->dep[i][0]; + hi = line->dep[i][1]; + } + dump_fancy_line (this, type, line->ind, lo, hi); + } + + hsh_destroy (x->lines[type]); + x->lines[type] = NULL; + } +} + +/* (Same args as dump_fancy_line()). Either dumps the line directly + to the output file, or adds it to the cache, depending on the + user-selected line optimization mode. */ +static void +line (struct outp_driver *this, int type, int ind, int dep1, int dep2) +{ + struct ps_driver_ext *ext = this->ext; + struct line_form **f; + + assert (dep2 >= dep1); + if (ext->line_opt == 0) + { + dump_fancy_line (this, type, ind, dep1, dep2); + return; + } + + if (ext->lines[type] == NULL) + ext->lines[type] = hsh_create (31, compare_line, hash_line, + free_line, NULL); + f = (struct line_form **) hsh_probe (ext->lines[type], + (struct line_form *) & ind); + if (*f == NULL) + { + *f = xmalloc (sizeof **f + sizeof (int[15][2])); + (*f)->ind = ind; + (*f)->mdep = 16; + (*f)->ndep = 1; + (*f)->dep[0][0] = dep1; + (*f)->dep[0][1] = dep2; + return; + } + if ((*f)->ndep >= (*f)->mdep) + { + (*f)->mdep += 16; + *f = xrealloc (*f, (sizeof **f + sizeof (int[2]) * ((*f)->mdep - 1))); + } + (*f)->dep[(*f)->ndep][0] = dep1; + (*f)->dep[(*f)->ndep][1] = dep2; + (*f)->ndep++; +} + +void +ps_line_horz (struct outp_driver *this, const struct rect *r, + const struct color *c unused, int style) +{ + /* Must match output.h:OUTP_L_*. */ + static const int types[OUTP_L_COUNT] = + {-1, horz, dbl_horz, spl_horz}; + + int y = (r->y1 + r->y2) / 2; + + assert (this->driver_open && this->page_open); + assert (style >= 0 && style < OUTP_L_COUNT); + style = types[style]; + if (style != -1) + line (this, style, y, r->x1, r->x2); +} + +void +ps_line_vert (struct outp_driver *this, const struct rect *r, + const struct color *c unused, int style) +{ + /* Must match output.h:OUTP_L_*. */ + static const int types[OUTP_L_COUNT] = + {-1, vert, dbl_vert, spl_vert}; + + int x = (r->x1 + r->x2) / 2; + + assert (this->driver_open && this->page_open); + assert (style >= 0 && style < OUTP_L_COUNT); + style = types[style]; + if (style != -1) + line (this, style, x, r->y1, r->y2); +} + +#define L (style->l != OUTP_L_NONE) +#define R (style->r != OUTP_L_NONE) +#define T (style->t != OUTP_L_NONE) +#define B (style->b != OUTP_L_NONE) + +void +ps_line_intersection (struct outp_driver *this, const struct rect *r, + const struct color *c unused, + const struct outp_styles *style) +{ + struct ps_driver_ext *ext = this->ext; + + int x = (r->x1 + r->x2) / 2; + int y = (r->y1 + r->y2) / 2; + int ofs = (ext->line_space + ext->line_width) / 2; + int x1 = x - ofs, x2 = x + ofs; + int y1 = y - ofs, y2 = y + ofs; + + assert (this->driver_open && this->page_open); + assert (!((style->l != style->r && style->l != OUTP_L_NONE + && style->r != OUTP_L_NONE) + || (style->t != style->b && style->t != OUTP_L_NONE + && style->b != OUTP_L_NONE))); + + switch ((style->l | style->r) | ((style->t | style->b) << 8)) + { + case (OUTP_L_SINGLE) | (OUTP_L_SINGLE << 8): + case (OUTP_L_SINGLE) | (OUTP_L_NONE << 8): + case (OUTP_L_NONE) | (OUTP_L_SINGLE << 8): + if (L) + line (this, horz, y, r->x1, x); + if (R) + line (this, horz, y, x, r->x2); + if (T) + line (this, vert, x, r->y1, y); + if (B) + line (this, vert, x, y, r->y2); + break; + case (OUTP_L_SINGLE) | (OUTP_L_DOUBLE << 8): + case (OUTP_L_NONE) | (OUTP_L_DOUBLE << 8): + if (L) + line (this, horz, y, r->x1, x1); + if (R) + line (this, horz, y, x2, r->x2); + if (T) + line (this, dbl_vert, x, r->y1, y); + if (B) + line (this, dbl_vert, x, y, r->y2); + if ((L && R) && !(T && B)) + line (this, horz, y, x1, x2); + break; + case (OUTP_L_DOUBLE) | (OUTP_L_SINGLE << 8): + case (OUTP_L_DOUBLE) | (OUTP_L_NONE << 8): + if (L) + line (this, dbl_horz, y, r->x1, x); + if (R) + line (this, dbl_horz, y, x, r->x2); + if (T) + line (this, vert, x, r->y1, y); + if (B) + line (this, vert, x, y, r->y2); + if ((T && B) && !(L && R)) + line (this, vert, x, y1, y2); + break; + case (OUTP_L_DOUBLE) | (OUTP_L_DOUBLE << 8): + if (L) + line (this, dbl_horz, y, r->x1, x); + if (R) + line (this, dbl_horz, y, x, r->x2); + if (T) + line (this, dbl_vert, x, r->y1, y); + if (B) + line (this, dbl_vert, x, y, r->y2); + if (T && B && !L) + line (this, vert, x1, y1, y2); + if (T && B && !R) + line (this, vert, x2, y1, y2); + if (L && R && !T) + line (this, horz, y1, x1, x2); + if (L && R && !B) + line (this, horz, y2, x1, x2); + break; + default: + assert (0); + } +} + +void +ps_line_width (struct outp_driver *this, int *width, int *height) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + width[0] = height[0] = 0; + width[1] = height[1] = 2 * x->line_gutter + x->line_width; + width[2] = height[2] = (2 * x->line_gutter + 2 * x->line_width + + x->line_space); + width[3] = height[3] = 2 * x->line_gutter + x->line_width; +} + +void +ps_box (struct outp_driver *this unused, const struct rect *r unused, + const struct color *bord unused, const struct color *fill unused) +{ + assert (this->driver_open && this->page_open); +} + +void +ps_polyline_begin (struct outp_driver *this unused, + const struct color *c unused) +{ + assert (this->driver_open && this->page_open); +} +void +ps_polyline_point (struct outp_driver *this unused, int x unused, int y unused) +{ + assert (this->driver_open && this->page_open); +} +void +ps_polyline_end (struct outp_driver *this unused) +{ + assert (this->driver_open && this->page_open); +} + +/* Returns the width of string S for THIS driver. */ +static int +text_width (struct outp_driver *this, char *s) +{ + struct outp_text text; + + text.options = OUTP_T_JUST_LEFT; + ls_init (&text.s, s, strlen (s)); + this->class->text_metrics (this, &text); + return text.h; +} + +/* Write string S at location (X,Y) with width W for THIS driver. */ +static void +out_text_plain (struct outp_driver *this, char *s, int x, int y, int w) +{ + struct outp_text text; + + text.options = OUTP_T_JUST_LEFT | OUTP_T_HORZ | OUTP_T_VERT; + ls_init (&text.s, s, strlen (s)); + text.h = w; + text.v = this->font_height; + text.x = x; + text.y = y; + this->class->text_draw (this, &text); +} + +/* Draw top of page headers for THIS driver. */ +static void +draw_headers (struct outp_driver *this) +{ + struct ps_driver_ext *ext = this->ext; + + struct font_entry *old_current = ext->current; + char *old_family = xstrdup (ext->family); /* FIXME */ + int old_size = ext->size; + + int fh = this->font_height; + int y = -3 * fh; + + fprintf (ext->file.file, "%d %d %d %d GB%s", + 0, YT (y), this->width, YT (y + 2 * fh + ext->line_gutter), + ext->eol); + this->class->text_set_font_family (this, "T"); + + y += ext->line_width + ext->line_gutter; + + { + int rh_width; + char buf[128]; + + sprintf (buf, _("%s - Page %d"), curdate, ext->page_number); + rh_width = text_width (this, buf); + + out_text_plain (this, buf, this->width - this->prop_em_width - rh_width, + y, rh_width); + + if (outp_title && outp_subtitle) + out_text_plain (this, outp_title, this->prop_em_width, y, + this->width - 3 * this->prop_em_width - rh_width); + + y += fh; + } + + { + int rh_width; + char buf[128]; + char *string = outp_subtitle ? outp_subtitle : outp_title; + + sprintf (buf, "%s - %s", version, host_system); + rh_width = text_width (this, buf); + + out_text_plain (this, buf, this->width - this->prop_em_width - rh_width, + y, rh_width); + + if (string) + out_text_plain (this, string, this->prop_em_width, y, + this->width - 3 * this->prop_em_width - rh_width); + + y += fh; + } + + ext->current = old_current; + free (ext->family); + ext->family = old_family; + ext->size = old_size; +} + + +/* Text. */ + +void +ps_text_set_font_by_name (struct outp_driver *this, const char *dit) +{ + struct ps_driver_ext *x = this->ext; + struct font_entry *fe; + + assert (this->driver_open && this->page_open); + + /* Short-circuit common fonts. */ + if (!strcmp (dit, "PROP")) + { + x->current = x->prop; + x->size = x->font_size; + return; + } + else if (!strcmp (dit, "FIXED")) + { + x->current = x->fixed; + x->size = x->font_size; + return; + } + + /* Find font_desc corresponding to Groff name dit. */ + fe = hsh_find (x->loaded, &dit); + if (fe == NULL) + fe = load_font (this, dit); + x->current = fe; +} + +void +ps_text_set_font_by_position (struct outp_driver *this, int pos) +{ + struct ps_driver_ext *x = this->ext; + char *dit; + + assert (this->driver_open && this->page_open); + + /* Determine font name by suffixing position string to font family + name. */ + { + char *cp; + + dit = local_alloc (strlen (x->family) + 3); + cp = stpcpy (dit, x->family); + switch (pos) + { + case OUTP_F_R: + *cp++ = 'R'; + break; + case OUTP_F_I: + *cp++ = 'I'; + break; + case OUTP_F_B: + *cp++ = 'B'; + break; + case OUTP_F_BI: + *cp++ = 'B'; + *cp++ = 'I'; + break; + default: + assert(0); + } + *cp++ = 0; + } + + /* Find font_desc corresponding to Groff name dit. */ + { + struct font_entry *fe = hsh_find (x->loaded, &dit); + if (fe == NULL) + fe = load_font (this, dit); + x->current = fe; + } + + local_free (dit); +} + +void +ps_text_set_font_family (struct outp_driver *this, const char *s) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + + free(x->family); + x->family = xstrdup (s); +} + +const char * +ps_text_get_font_name (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + return x->current->font->name; +} + +const char * +ps_text_get_font_family (struct outp_driver *this) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + return x->family; +} + +int +ps_text_set_size (struct outp_driver *this, int size) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + x->size = PSUS / 72000 * size; + return 1; +} + +int +ps_text_get_size (struct outp_driver *this, int *em_width) +{ + struct ps_driver_ext *x = this->ext; + + assert (this->driver_open && this->page_open); + if (em_width) + *em_width = (x->current->font->space_width * x->size) / 1000; + return x->size / (PSUS / 72000); +} + +/* An output character. */ +struct output_char + { + struct font_entry *font; /* Font of character. */ + int size; /* Size of character. */ + int x, y; /* Location of character. */ + unsigned char ch; /* Character. */ + char separate; /* Must be separate from previous char. */ + }; + +/* Hash table comparison function for ps_combo structs. */ +static int +compare_ps_combo (const void *pa, const void *pb, void *foo unused) +{ + const struct ps_font_combo *a = pa; + const struct ps_font_combo *b = pb; + + return !((a->font == b->font) && (a->size == b->size)); +} + +/* Hash table hash function for ps_combo structs. */ +static unsigned +hash_ps_combo (const void *pa, void *foo unused) +{ + const struct ps_font_combo *a = pa; + + return hashpjw (a->font->font->internal_name) ^ a->size; +} + +/* Hash table free function for ps_combo structs. */ +static void +free_ps_combo (void *a, void *foo unused) +{ + free (a); +} + +/* Causes PostScript code to be output that switches to the font + CP->FONT and font size CP->SIZE. The first time a particular + font/size combination is used on a particular page, this involves + outputting PostScript code to load the font. */ +static void +switch_font (struct outp_driver *this, const struct output_char *cp) +{ + struct ps_driver_ext *ext = this->ext; + struct ps_font_combo srch, **fc; + + srch.font = cp->font; + srch.size = cp->size; + + fc = (struct ps_font_combo **) hsh_probe (ext->combos, &srch); + if (*fc) + { + fprintf (ext->file.file, "F%x%s", (*fc)->index, ext->eol); + } + else + { + char *filename; + struct ps_encoding *encoding; + char buf[512], *bp; + + *fc = xmalloc (sizeof **fc); + (*fc)->font = cp->font; + (*fc)->size = cp->size; + (*fc)->index = ext->next_combo++; + + filename = find_encoding_file (this, cp->font->font->encoding); + if (filename) + { + encoding = get_encoding (this, filename); + free (filename); + } + else + { + msg (IE, _("PostScript driver: Cannot find encoding `%s' for " + "PostScript font `%s'."), cp->font->font->encoding, + cp->font->font->internal_name); + encoding = default_encoding (this); + } + + if (cp->font != ext->fixed && cp->font != ext->prop) + { + bp = stpcpy (buf, "%%IncludeResource: font "); + bp = quote_ps_string (bp, cp->font->font->internal_name); + bp = stpcpy (bp, ext->eol); + } + else + bp = buf; + + bp = spprintf (bp, "/F%x E%x %d", (*fc)->index, encoding->index, + cp->size); + bp = quote_ps_name (bp, cp->font->font->internal_name); + sprintf (bp, " SF%s", ext->eol); + fputs (buf, ext->file.file); + } + ext->last_font = *fc; +} + +/* (write_text) Writes the accumulated line buffer to the output + file. */ +#define output_line() \ + do \ + { \ + lp = stpcpy (lp, ext->eol); \ + *lp = 0; \ + fputs (line, ext->file.file); \ + lp = line; \ + } \ + while (0) + +/* (write_text) Adds the string representing number X to the line + buffer, flushing the buffer to disk beforehand if necessary. */ +#define put_number(X) \ + do \ + { \ + int n = nsprintf (number, "%d", X); \ + if (n + lp > &line[75]) \ + output_line (); \ + lp = stpcpy (lp, number); \ + } \ + while (0) + +/* Outputs PostScript code to THIS driver's output file to display the + characters represented by the output_char's between CP and END, + using the associated outp_text T to determine formatting. WIDTH is + the width of the output region; WIDTH_LEFT is the amount of the + WIDTH that is not taken up by text (so it can be used to determine + justification). */ +static void +write_text (struct outp_driver *this, + const struct output_char *cp, const struct output_char *end, + struct outp_text *t, int width unused, int width_left) +{ + struct ps_driver_ext *ext = this->ext; + int ofs; + + int last_y; + + char number[INT_DIGITS + 1]; + char line[80]; + char *lp; + + switch (t->options & OUTP_T_JUST_MASK) + { + case OUTP_T_JUST_LEFT: + ofs = 0; + break; + case OUTP_T_JUST_RIGHT: + ofs = width_left; + break; + case OUTP_T_JUST_CENTER: + ofs = width_left / 2; + break; + } + + lp = line; + last_y = INT_MIN; + while (cp < end) + { + int x = cp->x + ofs; + int y = cp->y + (cp->font->font->ascent * cp->size / 1000); + + if (ext->last_font == NULL + || cp->font != ext->last_font->font + || cp->size != ext->last_font->size) + switch_font (this, cp); + + *lp++ = '('; + do + { + /* PORTME! */ + static unsigned char literal_chars[ODA_COUNT][32] = + { + {0x00, 0x00, 0x00, 0xf8, 0xff, 0xfc, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0x7f, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, + }, + {0x00, 0x00, 0x00, 0xf8, 0xff, 0xfc, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + }, + {0x7e, 0xd6, 0xff, 0xfb, 0xff, 0xfc, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, + } + }; + + if (TEST_BIT (literal_chars[ext->data], cp->ch)) + *lp++ = cp->ch; + else + switch (cp->ch) + { + case '(': + lp = stpcpy (lp, "\\("); + break; + case ')': + lp = stpcpy (lp, "\\)"); + break; + default: + lp = spprintf (lp, "\\%03o", cp->ch); + break; + } + cp++; + } + while (cp < end && lp < &line[70] && cp->separate == 0); + *lp++ = ')'; + + put_number (x); + + if (y != last_y) + { + *lp++ = ' '; + put_number (YT (y)); + *lp++ = ' '; + *lp++ = 'S'; + last_y = y; + } + else + { + *lp++ = ' '; + *lp++ = 'T'; + } + + if (lp >= &line[70]) + output_line (); + } + if (lp != line) + output_line (); +} + +#undef output_line +#undef put_number + +/* Displays the text in outp_text T, if DRAW is nonzero; or, merely + determine the text metrics, if DRAW is zero. */ +static void +text (struct outp_driver *this, struct outp_text *t, int draw) +{ + struct ps_driver_ext *ext = this->ext; + + /* Output. */ + struct output_char *buf; /* Output buffer. */ + struct output_char *buf_end; /* End of output buffer. */ + struct output_char *buf_loc; /* Current location in output buffer. */ + + /* Saved state. */ + struct font_entry *old_current = ext->current; + char *old_family = xstrdup (ext->family); /* FIXME */ + int old_size = ext->size; + + /* Input string. */ + char *cp, *end; + + /* Current location. */ + int x, y; + + /* Keeping track of what's left over. */ + int width; /* Width available for characters. */ + int width_left, height_left; /* Width, height left over. */ + int max_height; /* Tallest character on this line so far. */ + + /* Previous character. */ + int prev_char; + + /* Information about location of previous space. */ + char *space_char; /* Character after space. */ + struct output_char *space_buf_loc; /* Buffer location after space. */ + int space_width_left; /* Width of characters before space. */ + + /* Name of the current character. */ + const char *char_name; + char local_char_name[2] = {0, 0}; + + local_char_name[0] = local_char_name[1] = 0; + + buf = local_alloc (sizeof *buf * 128); + buf_end = &buf[128]; + buf_loc = buf; + + assert (!ls_null_p (&t->s)); + cp = ls_value (&t->s); + end = ls_end (&t->s); + if (draw) + { + x = t->x; + y = t->y; + } + width = width_left = (t->options & OUTP_T_HORZ) ? t->h : INT_MAX; + height_left = (t->options & OUTP_T_VERT) ? t->v : INT_MAX; + max_height = 0; + prev_char = -1; + space_char = NULL; + + if (!width || !height_left) + goto exit; + + while (cp < end) + { + struct char_metrics *metric; + int cur_char; + int kern_amt; + int char_width; + int separate = 0; + + /* Set char_name to the name of the character or ligature at + *cp. */ + if (ext->current->font->ligatures && *cp == 'f') + { + int lig = 0; + + if (cp < end - 1) + switch (cp[1]) + { + case 'i': + lig = LIG_fi, char_name = "fi"; + break; + case 'l': + lig = LIG_fl, char_name = "fl"; + break; + case 'f': + if (cp < end - 2) + switch (cp[2]) + { + case 'i': + lig = LIG_ffi, char_name = "ffi"; + goto got_ligature; + case 'l': + lig = LIG_ffl, char_name = "ffl"; + goto got_ligature; + } + lig = LIG_ff, char_name = "ff"; + got_ligature: + break; + } + if ((lig & ext->current->font->ligatures) == 0) + { + local_char_name[0] = *cp++; /* 'f' */ + char_name = local_char_name; + } + else + cp += strlen (char_name); + } + else if (*cp == '\n') + { + if (draw) + { + write_text (this, buf, buf_loc, t, width, width_left); + buf_loc = buf; + x = t->x; + y += max_height; + } + + width_left = width; + height_left -= max_height; + max_height = 0; + kern_amt = 0; + separate = 1; + cp++; + + /* FIXME: when we're page buffering it will be necessary to + set separate to 1. */ + continue; + } + else + { + local_char_name[0] = *cp++; + char_name = local_char_name; + } + + /* Figure out what size this character is, and what kern + adjustment we need. */ + cur_char = font_char_name_to_index (char_name); + metric = font_get_char_metrics (ext->current->font, cur_char); + if (!metric) + { + static struct char_metrics m; + metric = &m; + m.width = ext->current->font->space_width; + m.code = *char_name; + } + kern_amt = font_get_kern_adjust (ext->current->font, prev_char, + cur_char); + if (kern_amt) + { + kern_amt = (kern_amt * ext->size / 1000); + separate = 1; + } + char_width = metric->width * ext->size / 1000; + + /* Record the current status if this is a space character. */ + if (cur_char == space_index && buf_loc > buf) + { + space_char = cp; + space_buf_loc = buf_loc; + space_width_left = width_left; + } + + /* Drop down to a new line if there's no room left on this + line. */ + if (char_width + kern_amt > width_left) + { + /* Regress to previous space, if any. */ + if (space_char) + { + cp = space_char; + width_left = space_width_left; + buf_loc = space_buf_loc; + } + + if (draw) + { + write_text (this, buf, buf_loc, t, width, width_left); + buf_loc = buf; + x = t->x; + y += max_height; + } + + width_left = width; + height_left -= max_height; + max_height = 0; + kern_amt = 0; + + if (space_char) + { + space_char = NULL; + prev_char = -1; + /* FIXME: when we're page buffering it will be + necessary to set separate to 1. */ + continue; + } + separate = 1; + } + if (ext->size > max_height) + max_height = ext->size; + if (max_height > height_left) + goto exit; + + /* Actually draw the character. */ + if (draw) + { + if (buf_loc >= buf_end) + { + int buf_len = buf_end - buf; + + if (buf_len == 128) + { + struct output_char *new_buf; + + new_buf = xmalloc (sizeof *new_buf * 256); + memcpy (new_buf, buf, sizeof *new_buf * 128); + buf_loc = new_buf + 128; + buf_end = new_buf + 256; + local_free (buf); + buf = new_buf; + } + else + { + buf = xrealloc (buf, sizeof *buf * buf_len * 2); + buf_loc = buf + buf_len; + buf_end = buf + buf_len * 2; + } + } + + x += kern_amt; +#if __CHECKER__ + memset (buf_loc, 0, sizeof *buf_loc); +#endif + buf_loc->font = ext->current; + buf_loc->size = ext->size; + buf_loc->x = x; + buf_loc->y = y; + buf_loc->ch = metric->code; + buf_loc->separate = separate; + buf_loc++; + x += char_width; + } + + /* Prepare for next iteration. */ + width_left -= char_width + kern_amt; + prev_char = cur_char; + } + height_left -= max_height; + if (buf_loc > buf && draw) + write_text (this, buf, buf_loc, t, width, width_left); + +exit: + if (!(t->options & OUTP_T_HORZ)) + t->h = INT_MAX - width_left; + if (!(t->options & OUTP_T_VERT)) + t->v = INT_MAX - height_left; + else + t->v -= height_left; + if (buf_end - buf == 128) + local_free (buf); + else + free (buf); + ext->current = old_current; + free (ext->family); + ext->family = old_family; + ext->size = old_size; +} + +void +ps_text_metrics (struct outp_driver *this, struct outp_text *t) +{ + assert (this->driver_open && this->page_open); + text (this, t, 0); +} + +void +ps_text_draw (struct outp_driver *this, struct outp_text *t) +{ + assert (this->driver_open && this->page_open); + text (this, t, 1); +} + +/* Font loader. */ + +/* Translate a filename to a font. */ +struct filename2font + { + char *filename; /* Normalized filename. */ + struct font_desc *font; + }; + +/* Table of `filename2font's. */ +static struct hsh_table *ps_fonts; + +/* Hash table comparison function for filename2font structs. */ +static int +compare_filename2font (const void *a, const void *b, void *param unused) +{ + return strcmp (((struct filename2font *) a)->filename, + ((struct filename2font *) b)->filename); +} + +/* Hash table hash function for filename2font structs. */ +static unsigned +hash_filename2font (const void *a, void *param unused) +{ + /* I sure hope this works with long filenames. */ + return hashpjw (((struct filename2font *) a)->filename); +} + +/* Initializes the global font list by creating the hash table for + translation of filenames to font_desc structs. */ +static void +init_fonts (void) +{ + ps_fonts = hsh_create (31, compare_filename2font, hash_filename2font, + NULL, NULL); +} + +/* Loads the font having Groff name DIT into THIS driver instance. + Specifically, adds it into the THIS driver's `loaded' hash + table. */ +static struct font_entry * +load_font (struct outp_driver *this, const char *dit) +{ + struct ps_driver_ext *x = this->ext; + char *filename1, *filename2; + void **entry; + struct font_entry *fe; + + filename1 = find_ps_file (this, dit); + if (!filename1) + filename1 = xstrdup (dit); + filename2 = fn_normalize (filename1); + free (filename1); + + entry = hsh_probe (ps_fonts, &filename2); + if (*entry == NULL) + { + struct filename2font *f2f; + struct font_desc *f = groff_read_font (filename2); + + if (f == NULL) + { + if (x->fixed) + f = x->fixed->font; + else + f = default_font (); + } + + f2f = xmalloc (sizeof *f2f); + f2f->filename = filename2; + f2f->font = f; + *entry = f2f; + } + else + free (filename2); + + fe = xmalloc (sizeof *fe); + fe->dit = xstrdup (dit); + fe->font = ((struct filename2font *) * entry)->font; + *hsh_probe (x->loaded, &dit) = fe; + + return fe; +} + +/* PostScript driver class. */ +struct outp_class postscript_class = +{ + "postscript", + MAGIC_PS, + 0, + + ps_open_global, + ps_close_global, + ps_font_sizes, + + ps_preopen_driver, + ps_option, + ps_postopen_driver, + ps_close_driver, + + ps_open_page, + ps_close_page, + + NULL, + + ps_line_horz, + ps_line_vert, + ps_line_intersection, + + ps_box, + ps_polyline_begin, + ps_polyline_point, + ps_polyline_end, + + ps_text_set_font_by_name, + ps_text_set_font_by_position, + ps_text_set_font_family, + ps_text_get_font_name, + ps_text_get_font_family, + ps_text_set_size, + ps_text_get_size, + ps_text_metrics, + ps_text_draw, +}; + +/* EPSF driver class. FIXME: Probably doesn't work right. */ +struct outp_class epsf_class = +{ + "epsf", + MAGIC_EPSF, + 0, + + ps_open_global, + ps_close_global, + ps_font_sizes, + + ps_preopen_driver, + ps_option, + ps_postopen_driver, + ps_close_driver, + + ps_open_page, + ps_close_page, + + NULL, + + ps_line_horz, + ps_line_vert, + ps_line_intersection, + + ps_box, + ps_polyline_begin, + ps_polyline_point, + ps_polyline_end, + + ps_text_set_font_by_name, + ps_text_set_font_by_position, + ps_text_set_font_family, + ps_text_get_font_name, + ps_text_get_font_family, + ps_text_set_size, + ps_text_get_size, + ps_text_metrics, + ps_text_draw, +}; + +#endif /* NO_POSTSCRIPT */ diff --git a/src/print.c b/src/print.c new file mode 100644 index 00000000..70a41763 --- /dev/null +++ b/src/print.c @@ -0,0 +1,1211 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include "alloc.h" +#include "command.h" +#include "dfm.h" +#include "error.h" +#include "expr.h" +#include "file-handle.h" +#include "lexer.h" +#include "misc.h" +#include "som.h" +#include "tab.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Describes what to do when an output field is encountered. */ +enum + { + PRT_ERROR, /* Invalid value. */ + PRT_NEWLINE, /* Newline. */ + PRT_CONST, /* Constant string. */ + PRT_VAR, /* Variable. */ + PRT_SPACE /* A single space. */ + }; + +/* Describes how to output one field. */ +struct prt_out_spec + { + struct prt_out_spec *next; + int type; /* PRT_* constant. */ + int fc; /* 0-based first column. */ + union + { + char *c; /* PRT_CONST: Associated string. */ + struct + { + struct variable *v; /* PRT_VAR: Associated variable. */ + struct fmt_spec f; /* PRT_VAR: Output spec. */ + } + v; + } + u; + }; + +/* Enums for use with print_trns's `options' field. */ +enum + { + PRT_CMD_MASK = 1, /* Command type mask. */ + PRT_PRINT = 0, /* PRINT transformation identifier. */ + PRT_WRITE = 1, /* WRITE transformation identifier. */ + PRT_EJECT = 002 /* Can be combined with CMD_PRINT only. */ + }; + +/* PRINT, PRINT EJECT, WRITE private data structure. */ +struct print_trns + { + struct trns_header h; + struct file_handle *handle; /* Output file, NULL=listing file. */ + int options; /* PRT_* bitmapped field. */ + struct prt_out_spec *spec; /* Output specifications. */ + int max_width; /* Maximum line width including null. */ +#if !PAGED_STACK + char *line; /* Buffer for sticking lines in. */ +#endif + }; + +/* PRT_PRINT or PRT_WRITE. */ +int which_cmd; + +/* Holds information on parsing the data file. */ +static struct print_trns prt; + +/* Last prt_out_spec in the chain. Used for building the linked-list. */ +static struct prt_out_spec *next; + +/* Number of records. */ +static int nrec; + +static int internal_cmd_print (int flags); +static int print_trns_proc (struct trns_header *, struct ccase *); +static void print_trns_free (struct trns_header *); +static int parse_specs (void); +static void dump_table (void); +static void append_var_spec (struct prt_out_spec *spec); +static void alloc_line (void); + +#if DEBUGGING +void debug_print (void); +#endif + +/* Basic parsing. */ + +/* Parses PRINT command. */ +int +cmd_print (void) +{ + lex_match_id ("PRINT"); + return internal_cmd_print (PRT_PRINT); +} + +/* Parses PRINT EJECT command. */ +int +cmd_print_eject (void) +{ + lex_match_id ("EJECT"); + return internal_cmd_print (PRT_PRINT | PRT_EJECT); +} + +/* Parses WRITE command. */ +int +cmd_write (void) +{ + lex_match_id ("WRITE"); + return internal_cmd_print (PRT_WRITE); +} + +/* Parses the output commands. F is PRT_PRINT, PRT_WRITE, or + PRT_PRINT|PRT_EJECT. */ +static int +internal_cmd_print (int f) +{ + /* 0=print no table, 1=print table. (TABLE subcommand.) */ + int table = 0; + + /* malloc()'d transformation. */ + struct print_trns *trns; + + /* Fill in prt to facilitate error-handling. */ + prt.h.proc = print_trns_proc; + prt.h.free = print_trns_free; + prt.handle = NULL; + prt.options = f; + prt.spec = NULL; +#if !PAGED_STACK + prt.line = NULL; +#endif + next = NULL; + nrec = 0; + + which_cmd = f & PRT_CMD_MASK; + + /* Parse the command options. */ + while (!lex_match ('/')) + { + if (lex_match_id ("OUTFILE")) + { + lex_match ('='); + + prt.handle = fh_parse_file_handle (); + if (!prt.handle) + goto lossage; + } + else if (lex_match_id ("RECORDS")) + { + lex_match ('='); + lex_match ('('); + if (!lex_force_int ()) + goto lossage; + nrec = lex_integer (); + lex_get (); + lex_match (')'); + } + else if (lex_match_id ("TABLE")) + table = 1; + else if (lex_match_id ("NOTABLE")) + table = 0; + else + { + lex_error (_("expecting a valid subcommand")); + goto lossage; + } + } + + /* Parse variables and strings. */ + if (!parse_specs ()) + goto lossage; + + /* Output the variable table if requested. */ + if (table) + dump_table (); + + /* Count the maximum line width. Allocate linebuffer if + applicable. */ + alloc_line (); + + /* Put the transformation in the queue. */ + trns = xmalloc (sizeof *trns); + memcpy (trns, &prt, sizeof *trns); + add_transformation ((struct trns_header *) trns); + +#if DEBUGGING + debug_print (); +#endif + + return CMD_SUCCESS; + + lossage: + print_trns_free ((struct trns_header *) & prt); + return CMD_FAILURE; +} + +/* Appends the field output specification SPEC to the list maintained + in prt. */ +static void +append_var_spec (struct prt_out_spec *spec) +{ + if (next == 0) + prt.spec = next = xmalloc (sizeof *spec); + else + next = next->next = xmalloc (sizeof *spec); + + memcpy (next, spec, sizeof *spec); + next->next = NULL; +} + +/* Field parsing. Mostly stolen from data-list.c. */ + +/* Used for chaining together fortran-like format specifiers. */ +struct fmt_list +{ + struct fmt_list *next; + int count; + struct fmt_spec f; + struct fmt_list *down; +}; + +/* Used as "local" variables among the fixed-format parsing funcs. If + it were guaranteed that PSPP were going to be compiled by gcc, + I'd make all these functions a single set of nested functions. */ +static struct + { + struct variable **v; /* variable list */ + int nv; /* number of variables in list */ + int cv; /* number of variables from list used up so far + by the FORTRAN-like format specifiers */ + + int recno; /* current 1-based record number */ + int sc; /* 1-based starting column for next variable */ + + struct prt_out_spec spec; /* next format spec to append to list */ + int fc, lc; /* first, last 1-based column number of current + var */ + + int level; /* recursion level for FORTRAN-like format + specifiers */ + } +fx; + +static int fixed_parse_compatible (void); +static struct fmt_list *fixed_parse_fortran (void); + +static int parse_string_argument (void); +static int parse_variable_argument (void); + +/* Parses all the variable and string specifications on a single + PRINT, PRINT EJECT, or WRITE command into the prt structure. + Returns success. */ +static int +parse_specs (void) +{ + /* Return code from called function. */ + int code; + + fx.recno = 1; + fx.sc = 1; + + while (token != '.') + { + while (lex_match ('/')) + { + int prev_recno = fx.recno; + + fx.recno++; + if (token == T_NUM) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < fx.recno) + { + msg (SE, _("The record number specified, %ld, is " + "before the previous record, %d. Data " + "fields must be listed in order of " + "increasing record number."), + lex_integer (), fx.recno - 1); + return 0; + } + fx.recno = lex_integer (); + lex_get (); + } + + fx.spec.type = PRT_NEWLINE; + while (prev_recno++ < fx.recno) + append_var_spec (&fx.spec); + + fx.sc = 1; + } + + if (token == T_STRING) + code = parse_string_argument (); + else + code = parse_variable_argument (); + if (!code) + return 0; + } + fx.spec.type = PRT_NEWLINE; + append_var_spec (&fx.spec); + + if (!nrec) + nrec = fx.recno; + else if (fx.recno > nrec) + { + msg (SE, _("Variables are specified on records that " + "should not exist according to RECORDS subcommand.")); + return 0; + } + + if (token != '.') + { + lex_error (_("expecting end of command")); + return 0; + } + + return 1; +} + +/* Parses a string argument to the PRINT commands. Returns success. */ +static int +parse_string_argument (void) +{ + fx.spec.type = PRT_CONST; + fx.spec.fc = fx.sc - 1; + fx.spec.u.c = xstrdup (ds_value (&tokstr)); + lex_get (); + + /* Parse the included column range. */ + if (token == T_NUM) + { + /* Width of column range in characters. */ + int c_len; + + /* Width of constant string in characters. */ + int s_len; + + /* 1-based index of last column in range. */ + int lc; + + if (!lex_integer_p () || lex_integer () <= 0) + { + msg (SE, _("%g is not a valid column location."), tokval); + goto fail; + } + fx.spec.fc = lex_integer () - 1; + + lex_get (); + lex_negative_to_dash (); + if (lex_match ('-')) + { + if (!lex_integer_p ()) + { + msg (SE, _("Column location expected following `%d-'."), + fx.spec.fc + 1); + goto fail; + } + if (lex_integer () <= 0) + { + msg (SE, _("%g is not a valid column location."), tokval); + goto fail; + } + if (lex_integer () < fx.spec.fc + 1) + { + msg (SE, _("%d-%ld is not a valid column range. The second " + "column must be greater than or equal to the first."), + fx.spec.fc + 1, lex_integer ()); + goto fail; + } + lc = lex_integer () - 1; + + lex_get (); + } + else + /* If only a starting location is specified then the field is + the width of the provided string. */ + lc = fx.spec.fc + strlen (fx.spec.u.c) - 1; + + /* Apply the range. */ + c_len = lc - fx.spec.fc + 1; + s_len = strlen (fx.spec.u.c); + if (s_len > c_len) + fx.spec.u.c[c_len] = 0; + else if (s_len < c_len) + { + fx.spec.u.c = xrealloc (fx.spec.u.c, c_len + 1); + memset (&fx.spec.u.c[s_len], ' ', c_len - s_len); + fx.spec.u.c[c_len] = 0; + } + + fx.sc = lc + 1; + } + else + /* If nothing is provided then the field is the width of the + provided string. */ + fx.sc += strlen (fx.spec.u.c); + + append_var_spec (&fx.spec); + return 1; + +fail: + free (fx.spec.u.c); + return 0; +} + +/* Parses a variable argument to the PRINT commands by passing it off + to fixed_parse_compatible() or fixed_parse_fortran() as appropriate. + Returns success. */ +static int +parse_variable_argument (void) +{ + if (!parse_variables (NULL, &fx.v, &fx.nv, PV_DUPLICATE)) + return 0; + + if (token == T_NUM) + { + if (!fixed_parse_compatible ()) + goto fail; + } + else if (token == '(') + { + fx.level = 0; + fx.cv = 0; + if (!fixed_parse_fortran ()) + goto fail; + } + else + { + /* User wants dictionary format specifiers. */ + int i; + + lex_match ('*'); + for (i = 0; i < fx.nv; i++) + { + /* Variable. */ + fx.spec.type = PRT_VAR; + fx.spec.fc = fx.sc - 1; + fx.spec.u.v.v = fx.v[i]; + fx.spec.u.v.f = fx.v[i]->print; + append_var_spec (&fx.spec); + fx.sc += fx.v[i]->print.w; + + /* Space. */ + fx.spec.type = PRT_SPACE; + fx.spec.fc = fx.sc - 1; + append_var_spec (&fx.spec); + fx.sc++; + } + } + + free (fx.v); + return 1; + +fail: + free (fx.v); + return 0; +} + +/* Parses a column specification for parse_specs(). */ +static int +fixed_parse_compatible (void) +{ + int dividend; + int type; + int i; + + type = fx.v[0]->type; + for (i = 1; i < fx.nv; i++) + if (type != fx.v[i]->type) + { + msg (SE, _("%s is not of the same type as %s. To specify " + "variables of different types in the same variable " + "list, use a FORTRAN-like format specifier."), + fx.v[i]->name, fx.v[0]->name); + return 0; + } + + if (!lex_force_int ()) + return 0; + fx.fc = lex_integer () - 1; + if (fx.fc < 0) + { + msg (SE, _("Column positions for fields must be positive.")); + return 0; + } + lex_get (); + + lex_negative_to_dash (); + if (lex_match ('-')) + { + if (!lex_force_int ()) + return 0; + fx.lc = lex_integer () - 1; + if (fx.lc < 0) + { + msg (SE, _("Column positions for fields must be positive.")); + return 0; + } + else if (fx.lc < fx.fc) + { + msg (SE, _("The ending column for a field must not " + "be less than the starting column.")); + return 0; + } + lex_get (); + } + else + fx.lc = fx.fc; + + fx.spec.u.v.f.w = fx.lc - fx.fc + 1; + if (lex_match ('(')) + { + struct fmt_desc *fdp; + + if (token == T_ID) + { + const char *cp; + + fx.spec.u.v.f.type = parse_format_specifier_name (&cp, 0); + if (fx.spec.u.v.f.type == -1) + return 0; + if (*cp) + { + msg (SE, _("A format specifier on this line " + "has extra characters on the end.")); + return 0; + } + lex_get (); + lex_match (','); + } + else + fx.spec.u.v.f.type = FMT_F; + + if (token == T_NUM) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 1) + { + msg (SE, _("The value for number of decimal places " + "must be at least 1.")); + return 0; + } + fx.spec.u.v.f.d = lex_integer (); + lex_get (); + } + else + fx.spec.u.v.f.d = 0; + + fdp = &formats[fx.spec.u.v.f.type]; + if (fdp->n_args < 2 && fx.spec.u.v.f.d) + { + msg (SE, _("Input format %s doesn't accept decimal places."), + fdp->name); + return 0; + } + if (fx.spec.u.v.f.d > 16) + fx.spec.u.v.f.d = 16; + + if (!lex_force_match (')')) + return 0; + } + else + { + fx.spec.u.v.f.type = FMT_F; + fx.spec.u.v.f.d = 0; + } + + fx.sc = fx.lc + 1; + + if ((fx.lc - fx.fc + 1) % fx.nv) + { + msg (SE, _("The %d columns %d-%d can't be evenly divided into %d " + "fields."), fx.lc - fx.fc + 1, fx.fc + 1, fx.lc + 1, fx.nv); + return 0; + } + + dividend = (fx.lc - fx.fc + 1) / fx.nv; + fx.spec.u.v.f.w = dividend; + if (!check_output_specifier (&fx.spec.u.v.f)) + return 0; + if ((type == ALPHA) ^ (formats[fx.spec.u.v.f.type].cat & FCAT_STRING)) + { + msg (SE, _("%s variables cannot be displayed with format %s."), + type == ALPHA ? _("String") : _("Numeric"), + fmt_to_string (&fx.spec.u.v.f)); + return 0; + } + + /* Check that, for string variables, the user didn't specify a width + longer than an actual string width. */ + if (type == ALPHA) + { + /* Minimum width of all the string variables specified. */ + int min_len = fx.v[0]->width; + + for (i = 1; i < fx.nv; i++) + min_len = min (min_len, fx.v[i]->width); + if (!check_string_specifier (&fx.spec.u.v.f, min_len)) + return 0; + } + + fx.spec.type = PRT_VAR; + for (i = 0; i < fx.nv; i++) + { + fx.spec.fc = fx.fc + dividend * i; + fx.spec.u.v.v = fx.v[i]; + append_var_spec (&fx.spec); + } + return 1; +} + +/* Destroy a format list and, optionally, all its sublists. */ +static void +destroy_fmt_list (struct fmt_list * f, int recurse) +{ + struct fmt_list *next; + + for (; f; f = next) + { + next = f->next; + if (recurse && f->f.type == FMT_DESCEND) + destroy_fmt_list (f->down, 1); + free (f); + } +} + +/* Recursively puts the format list F (which represents a set of + FORTRAN-like format specifications, like 4(F10,2X)) into the + structure prt. */ +static int +dump_fmt_list (struct fmt_list * f) +{ + int i; + + for (; f; f = f->next) + if (f->f.type == FMT_X) + fx.sc += f->count; + else if (f->f.type == FMT_T) + fx.sc = f->f.w; + else if (f->f.type == FMT_NEWREC) + { + fx.recno += f->count; + fx.sc = 1; + fx.spec.type = PRT_NEWLINE; + for (i = 0; i < f->count; i++) + append_var_spec (&fx.spec); + } + else + for (i = 0; i < f->count; i++) + if (f->f.type == FMT_DESCEND) + { + if (!dump_fmt_list (f->down)) + return 0; + } + else + { + struct variable *v; + + if (fx.cv >= fx.nv) + { + msg (SE, _("The number of format " + "specifications exceeds the number of variable " + "names given.")); + return 0; + } + + v = fx.v[fx.cv++]; + if ((v->type == ALPHA) ^ (formats[f->f.type].cat & FCAT_STRING)) + { + msg (SE, _("Display format %s may not be used with a " + "%s variable."), fmt_to_string (&f->f), + v->type == ALPHA ? _("string") : _("numeric")); + return 0; + } + if (!check_string_specifier (&f->f, v->width)) + return 0; + + fx.spec.type = PRT_VAR; + fx.spec.u.v.v = v; + fx.spec.u.v.f = f->f; + fx.spec.fc = fx.sc - 1; + append_var_spec (&fx.spec); + + fx.sc += f->f.w; + } + return 1; +} + +/* Recursively parses a list of FORTRAN-like format specifiers. Calls + itself to parse nested levels of parentheses. Returns to its + original caller NULL, to indicate error, non-NULL, but nothing + useful, to indicate success (it returns a free()'d block). */ +static struct fmt_list * +fixed_parse_fortran (void) +{ + struct fmt_list *head; + struct fmt_list *fl = NULL; + + lex_get (); /* skip opening parenthesis */ + while (token != ')') + { + if (fl) + fl = fl->next = xmalloc (sizeof *fl); + else + head = fl = xmalloc (sizeof *fl); + + if (token == T_NUM) + { + if (!lex_integer_p ()) + goto fail; + fl->count = lex_integer (); + lex_get (); + } + else + fl->count = 1; + + if (token == '(') + { + fl->f.type = FMT_DESCEND; + fx.level++; + fl->down = fixed_parse_fortran (); + fx.level--; + if (!fl->down) + goto fail; + } + else if (lex_match ('/')) + fl->f.type = FMT_NEWREC; + else if (!parse_format_specifier (&fl->f, 1) + || !check_output_specifier (&fl->f)) + goto fail; + + lex_match (','); + } + fl->next = NULL; + lex_get (); + + if (fx.level) + return head; + + fl->next = NULL; + dump_fmt_list (head); + destroy_fmt_list (head, 1); + if (fx.cv < fx.nv) + { + msg (SE, _("There aren't enough format specifications " + "to match the number of variable names given.")); + goto fail; + } + return head; + +fail: + fl->next = NULL; + destroy_fmt_list (head, 0); + + return NULL; +} + +/* Prints the table produced by the TABLE subcommand to the listing + file. */ +static void +dump_table (void) +{ + struct prt_out_spec *spec; + const char *filename; + struct tab_table *t; + int recno; + int nspec; + + for (nspec = 0, spec = prt.spec; spec; spec = spec->next) + if (spec->type == PRT_CONST || spec->type == PRT_VAR) + nspec++; + t = tab_create (4, nspec + 1, 0); + tab_columns (t, TAB_COL_DOWN, 1); + tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, nspec); + tab_hline (t, TAL_2, 0, 3, 1); + tab_headers (t, 0, 0, 1, 0); + tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable")); + tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record")); + tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns")); + tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format")); + tab_dim (t, tab_natural_dimensions); + for (nspec = recno = 0, spec = prt.spec; spec; spec = spec->next) + switch (spec->type) + { + case PRT_NEWLINE: + recno++; + break; + case PRT_CONST: + { + int len = strlen (spec->u.c); + nspec++; + tab_text (t, 0, nspec, TAB_LEFT | TAT_FIX | TAT_PRINTF, + "\"%s\"", spec->u.c); + tab_text (t, 1, nspec, TAT_PRINTF, "%d", recno + 1); + tab_text (t, 2, nspec, TAT_PRINTF, "%3d-%3d", + spec->fc + 1, spec->fc + len); + tab_text (t, 3, nspec, TAB_LEFT | TAT_FIX | TAT_PRINTF, + "A%d", len); + break; + } + case PRT_VAR: + { + nspec++; + tab_text (t, 0, nspec, TAB_LEFT, spec->u.v.v->name); + tab_text (t, 1, nspec, TAT_PRINTF, "%d", recno + 1); + tab_text (t, 2, nspec, TAT_PRINTF, "%3d-%3d", + spec->fc + 1, spec->fc + spec->u.v.f.w); + tab_text (t, 3, nspec, TAB_LEFT | TAT_FIX, + fmt_to_string (&spec->u.v.f)); + break; + } + case PRT_SPACE: + break; + case PRT_ERROR: + assert (0); + } + + filename = fh_handle_name (prt.handle); + tab_title (t, 1, (prt.handle != NULL + ? _("Writing %3d records to file %s.") + : _("Writing %3d records to the listing file.")), + recno, filename); + tab_submit (t); + fh_handle_name (NULL); +} + +/* PORTME: The number of characters in a line terminator. */ +#if __MSDOS__ +#define LINE_END_WIDTH 2 /* \r\n */ +#else +#define LINE_END_WIDTH 1 /* \n */ +#endif + +/* Calculates the maximum possible line width and allocates a buffer + big enough to contain it, if necessary (otherwise sets max_width). + (The action taken depends on compiler & OS as detected by pref.h.) */ +static void +alloc_line (void) +{ + /* Cumulative maximum line width (excluding null terminator) so far. */ + int w = 0; + + /* Width required by current this prt_out_spec. */ + int pot_w; /* Potential w. */ + + /* Iterator. */ + struct prt_out_spec *i; + + for (i = prt.spec; i; i = i->next) + { + switch (i->type) + { + case PRT_NEWLINE: + pot_w = 0; + break; + case PRT_CONST: + pot_w = i->fc + strlen (i->u.c); + break; + case PRT_VAR: + pot_w = i->fc + i->u.v.f.w; + break; + case PRT_SPACE: + pot_w = i->fc + 1; + break; + case PRT_ERROR: + assert (0); + break; + } + if (pot_w > w) + w = pot_w; + } + prt.max_width = w + LINE_END_WIDTH + 1; +#if !PAGED_STACK + prt.line = xmalloc (prt.max_width); +#endif +} + +/* Transformation. */ + +/* Performs the transformation inside print_trns T on case C. */ +static int +print_trns_proc (struct trns_header * trns, struct ccase * c) +{ + /* Transformation. */ + struct print_trns *t = (struct print_trns *) trns; + + /* Iterator. */ + struct prt_out_spec *i; + + /* Line buffer. */ +#if PAGED_STACK +#if __GNUC__ && !__STRICT_ANSI__ + char buf[t->max_width]; +#else /* !__GNUC__ */ + char *buf = alloca (t->max_width); +#endif /* !__GNUC__ */ +#else /* !PAGED_STACK */ + char *buf = t->line; +#endif /* !PAGED_STACK */ + + /* Length of the line in buf. */ + int len = 0; + memset (buf, ' ', t->max_width); + + if (t->options & PRT_EJECT) + som_eject_page (); + + /* Note that a field written to a place where a field has already + been written truncates the record. `PRINT /A B (T10,F8,T1,F8).' + only outputs B. This is an example of bug-for-bug compatibility, + in the author's opinion. */ + for (i = t->spec; i; i = i->next) + switch (i->type) + { + case PRT_NEWLINE: + if (t->handle == NULL) + { + buf[len] = 0; + tab_output_text (TAT_FIX | TAT_NOWRAP, buf); + } + else + { + if ((t->options & PRT_CMD_MASK) == PRT_PRINT + || t->handle->mode != FH_MD_BINARY) + { + /* PORTME: Line ends. */ +#if __MSDOS__ + buf[len++] = '\r'; +#endif + buf[len++] = '\n'; + } + + dfm_put_record (t->handle, buf, len); + } + + memset (buf, ' ', t->max_width); + len = 0; + break; + + case PRT_CONST: + /* FIXME: Should be revised to keep track of the string's + length outside the loop, probably in i->u.c[0]. */ + memcpy (&buf[i->fc], i->u.c, strlen (i->u.c)); + len = i->fc + strlen (i->u.c); + break; + + case PRT_VAR: + if (i->u.v.v->type == NUMERIC) + data_out (&buf[i->fc], &i->u.v.f, &c->data[i->u.v.v->fv]); + else + { + union value t; + t.c = c->data[i->u.v.v->fv].s; + data_out (&buf[i->fc], &i->u.v.f, &t); + } + len = i->fc + i->u.v.f.w; + break; + + case PRT_SPACE: + /* PRT_SPACE always immediately follows PRT_VAR. */ + buf[len++] = ' '; + break; + + case PRT_ERROR: + assert (0); + break; + } + + return -1; +} + +/* Frees all the data inside print_trns T. Does not free T. */ +static void +print_trns_free (struct trns_header * t) +{ + struct prt_out_spec *i, *n; + + for (i = ((struct print_trns *) t)->spec; i; i = n) + { + switch (i->type) + { + case PRT_CONST: + free (i->u.c); + /* fall through */ + case PRT_NEWLINE: + case PRT_VAR: + case PRT_SPACE: + /* nothing to do */ + break; + case PRT_ERROR: + assert (0); + break; + } + n = i->next; + free (i); + } +#if !PAGED_STACK + free (((struct print_trns *) t)->line); +#endif +} + +/* PRINT SPACE. */ + +/* PRINT SPACE transformation. */ +struct print_space_trns +{ + struct trns_header h; + + struct file_handle *handle; /* Output file, NULL=listing file. */ + struct expression *e; /* Number of lines; NULL=1. */ +} +print_space_trns; + +static int print_space_trns_proc (struct trns_header *, struct ccase *); +static void print_space_trns_free (struct trns_header *); + +int +cmd_print_space (void) +{ + struct print_space_trns *t; + struct file_handle *handle; + struct expression *e; + + lex_match_id ("SPACE"); + if (lex_match_id ("OUTFILE")) + { + lex_match ('='); + + if (token == T_ID) + handle = fh_get_handle_by_name (tokid); + else if (token == T_STRING) + handle = fh_get_handle_by_filename (tokid); + else + { + msg (SE, _("A file name or handle was expected in the " + "OUTFILE subcommand.")); + return CMD_FAILURE; + } + + if (!handle) + return CMD_FAILURE; + lex_get (); + } + else + handle = NULL; + + if (token != '.') + { + e = expr_parse (PXP_NUMERIC); + if (token != '.') + { + expr_free (e); + lex_error (_("expecting end of command")); + return CMD_FAILURE; + } + } + else + e = NULL; + + t = xmalloc (sizeof *t); + t->h.proc = print_space_trns_proc; + if (e) + t->h.free = print_space_trns_free; + else + t->h.free = NULL; + t->handle = handle; + t->e = e; + + add_transformation ((struct trns_header *) t); + return CMD_SUCCESS; +} + +static int +print_space_trns_proc (struct trns_header * trns, struct ccase * c) +{ + struct print_space_trns *t = (struct print_space_trns *) trns; + int n; + + if (t->e) + { + union value v; + + expr_evaluate (t->e, c, &v); + n = v.f; + if (n < 0) + { + msg (SW, _("The expression on PRINT SPACE evaluated to %d. It's " + "not possible to PRINT SPACE a negative number of " + "lines."), + n); + n = 1; + } + } + else + n = 1; + + if (t->handle == NULL) + while (n--) + som_blank_line (); + else + { + char buf[LINE_END_WIDTH]; + + /* PORTME: Line ends. */ +#if __MSDOS__ + buf[0] = '\r'; + buf[1] = '\n'; +#else + buf[0] = '\n'; +#endif + while (n--) + dfm_put_record (t->handle, buf, LINE_END_WIDTH); + } + + return -1; +} + +static void +print_space_trns_free (struct trns_header * trns) +{ + expr_free (((struct print_space_trns *) trns)->e); +} + +/* Debugging code. */ + +#if DEBUGGING +void +debug_print (void) +{ + struct prt_out_spec *p; + + if (prt.handle == NULL) + { + printf ("PRINT"); + if (prt.eject) + printf (" EJECT"); + } + else + printf ("WRITE OUTFILE=%s", handle_name (prt.handle)); + printf (" MAX_WIDTH=%d", prt.max_width); + printf (" /"); + for (p = prt.spec; p; p = p->next) + switch (p->type) + { + case PRT_ERROR: + printf (_("")); + break; + case PRT_NEWLINE: + printf ("\n /"); + break; + case PRT_CONST: + printf (" \"%s\" %d-%d", p->u.c, p->fc + 1, p->fc + strlen (p->u.c)); + break; + case PRT_VAR: + printf (" %s %d %d-%d (%s)", p->u.v.v->name, p->u.v.v->fv, p->fc + 1, + p->fc + p->u.v.v->print.w, fmt_to_string (&p->u.v.v->print)); + break; + case PRT_SPACE: + printf (" \" \" %d", p->fc + 1); + break; + } + printf (".\n"); +} +#endif /* DEBUGGING */ diff --git a/src/q2c.c b/src/q2c.c new file mode 100644 index 00000000..839d4a77 --- /dev/null +++ b/src/q2c.c @@ -0,0 +1,1871 @@ +/* q2c - parser generator for PSPP procedures. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include +#include +#if HAVE_UNISTD_H +#include +#endif +#include "str.h" + +/* Brokenness. */ +#ifndef EXIT_SUCCESS +#define EXIT_SUCCESS 0 +#endif + +#ifndef EXIT_FAILURE +#define EXIT_FAILURE 1 +#endif + +#if !HAVE_STRERROR +#include "misc/strerror.c" +#endif + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Max length of an input line. */ +#define MAX_LINE_LEN 1024 + +/* Max token length. */ +#define MAX_TOK_LEN 1024 + +/* argv[0]. */ +char *pgmname; + +/* Have the input and output files been opened yet? */ +int is_open; + +/* Input, output files. */ +FILE *in, *out; + +/* Input, output file names. */ +char *ifn, *ofn; + +/* Input, output file line number. */ +int ln, oln = 1; + +/* Input line buffer, current position. */ +char *buf, *cp; + +/* Token types. */ +enum + { + T_STRING = 256, /* String literal. */ + T_ID = 257 /* Identifier. */ + }; + +/* Current token: either one of the above, or a single character. */ +int token; + +/* Token string value. */ +char *tokstr; + +/* Utility functions. */ + +#if !(__GNUC__ >= 2) +#define nullstr "" +#else +const char nullstr[] = ""; +#endif + +/* Close all open files and delete the output file, on failure. */ +void +finish_up (void) +{ + if (!is_open) + return; + is_open = 0; + fclose (in); + fclose (out); + if (remove (ofn) == -1) + fprintf (stderr, "%s: %s: remove: %s\n", pgmname, ofn, strerror (errno)); +} + +#if __GNUC__ >= 2 +void hcf (void) __attribute__ ((noreturn)); +#endif + +/* Terminate unsuccessfully. */ +void +hcf (void) +{ + finish_up (); + exit (EXIT_FAILURE); +} + +#if __GNUC__ >= 2 +int fail (const char *, ...) __attribute__ ((format (printf, 1, 2))); +int error (const char *, ...) __attribute__ ((format (printf, 1, 2))); +#endif + +/* Output an error message and terminate unsuccessfully. */ +int +fail (const char *format, ...) +{ + va_list args; + + va_start (args, format); + fprintf (stderr, "%s: ", pgmname); + vfprintf (stderr, format, args); + fprintf (stderr, "\n"); + va_end (args); + + hcf (); +} + +/* Output a context-dependent error message and terminate + unsuccessfully. */ +int +error (const char *format,...) +{ + va_list args; + + va_start (args, format); + fprintf (stderr, "%s:%d: (column %d) ", ifn, ln, (int) (cp - buf)); + vfprintf (stderr, format, args); + fprintf (stderr, "\n"); + va_end (args); + + hcf (); +} + +#define VME "virtual memory exhausted" + +/* Allocate a block of SIZE bytes and return a pointer to its + beginning. */ +void * +xmalloc (size_t size) +{ + void *vp; + + if (size == 0) + return NULL; + + vp = malloc (size); + if (!vp) + { +#if DEBUGGING && __CHECKER__ + error ("xmalloc(%lu): Inducing segfault.", (unsigned long) size); + *((int *) 0) = 0; +#endif + fail ("xmalloc(%lu): %s", (unsigned long) size, VME); + } + + return vp; +} + +/* Resize the block at PTR to size SIZE and return a pointer to the + beginning of the new block. */ +void * +xrealloc (void *ptr, size_t size) +{ + void *vp; + + if (!size) + { + if (ptr) + free (ptr); + return NULL; + } + + if (ptr) + vp = realloc (ptr, size); + else + vp = malloc (size); + + if (!vp) + fail ("xrealloc(%lu): %s", (unsigned long) size, VME); + + return vp; +} + +/* Make a dynamically allocated copy of string S and return a pointer + to the first character. */ +char * +xstrdup (const char *s) +{ + size_t size; + char *t; + + assert (s != NULL); + size = strlen (s) + 1; + + t = malloc (size); + if (!t) + fail ("xstrdup(%lu): %s", (unsigned long) strlen (s), VME); + + memcpy (t, s, size); + return t; +} + +/* Returns a pointer to one of 8 static buffers. The buffers are used + in rotation. */ +char * +get_buffer (void) +{ + static char b[8][256]; + static int cb; + + if (++cb >= 8) + cb = 0; + + return b[cb]; +} + +/* Copies a string to a static buffer, converting it to lowercase in + the process, and returns a pointer to the static buffer. */ +char * +st_lower (const char *s) +{ + char *p, *cp; + + p = cp = get_buffer (); + while (*s) + *cp++ = tolower ((unsigned char) (*s++)); + *cp++ = '\0'; + + return p; +} + +/* Copies a string to a static buffer, converting it to uppercase in + the process, and returns a pointer to the static buffer. */ +char * +st_upper (const char *s) +{ + char *p, *cp; + + p = cp = get_buffer (); + while (*s) + *cp++ = toupper ((unsigned char) (*s++)); + *cp++ = '\0'; + + return p; +} + +/* Returns the address of the first non-whitespace character in S, or + the address of the null terminator if none. */ +char * +skip_ws (const char *s) +{ + while (isspace ((unsigned char) *s)) + s++; + return (char *) s; +} + +/* Read one line from the input file into buf. Lines having special + formats are handled specially. */ +int +get_line (void) +{ + ln++; + if (0 == fgets (buf, MAX_LINE_LEN, in)) + { + if (ferror (in)) + fail ("%s: fgets: %s", ifn, strerror (errno)); + return 0; + } + + cp = strchr (buf, '\n'); + if (cp != NULL) + *cp = '\0'; + + cp = buf; + return 1; +} + +/* Symbol table manager. */ + +/* Symbol table entry. */ +typedef struct symbol symbol; +struct symbol + { + symbol *next; /* Next symbol in symbol table. */ + char *name; /* Symbol name. */ + int unique; /* 1=Name must be unique in this file. */ + int ln; /* Line number of definition. */ + int value; /* Symbol value. */ + }; + +/* Symbol table. */ +symbol *symtab; + +/* Add a symbol to the symbol table having name NAME, uniqueness + UNIQUE, and value VALUE. If a symbol having the same name is found + in the symbol table, its sequence number is returned and the symbol + table is not modified. Otherwise, the symbol is added and the next + available sequence number is returned. */ +int +add_symbol (const char *name, int unique, int value) +{ + symbol *iter, *sym; + int x; + + sym = xmalloc (sizeof (symbol)); + sym->name = xstrdup (name); + sym->unique = unique; + sym->value = value; + sym->next = NULL; + sym->ln = ln; + if (!symtab) + { + symtab = sym; + return 1; + } + iter = symtab; + x = 1; + for (;;) + { + if (!strcmp (iter->name, name)) + { + if (iter->unique) + { + fprintf (stderr, "%s:%d: `%s' is already defined above\n", ifn, + ln, name); + fprintf (stderr, "%s:%d: location of previous definition\n", ifn, + iter->ln); + hcf (); + } + free (sym->name); + free (sym); + return x; + } + if (!iter->next) + break; + iter = iter->next; + x++; + } + iter->next = sym; + return ++x; +} + +/* Finds the symbol having given sequence number X within the symbol + table, and returns the associated symbol structure. */ +symbol * +find_symbol (int x) +{ + symbol *iter; + + iter = symtab; + while (x > 1 && iter) + { + iter = iter->next; + x--; + } + assert (iter); + return iter; +} + +#if DEBUGGING +/* Writes a printable representation of the current token to + stdout. */ +void +dump_token (void) +{ + switch (token) + { + case T_STRING: + printf ("STRING\t\"%s\"\n", tokstr); + break; + case T_ID: + printf ("ID\t%s\n", tokstr); + break; + default: + printf ("PUNCT\t%c\n", token); + } +} +#endif /* DEBUGGING */ + +/* Reads a token from the input file. */ +int +lex_get (void) +{ + /* Skip whitespace and check for end of file. */ + for (;;) + { + cp = skip_ws (cp); + if (*cp != '\0') + break; + + if (!get_line ()) + fail ("%s: Unexpected end of file.", ifn); + } + + if (*cp == '_' || isalnum ((unsigned char) *cp)) + { + char *dest = tokstr; + token = T_ID; + while (*cp == '_' || isalnum ((unsigned char) *cp)) + *dest++ = toupper ((unsigned char) (*cp++)); + *dest++ = '\0'; + } + else if (*cp == '"') + { + char *dest = tokstr; + token = T_STRING; + cp++; + while (*cp != '"' && *cp) + { + if (*cp == '\\') + { + cp++; + if (!*cp) + error ("Unterminated string literal."); + *dest++ = *cp++; + } + else + *dest++ = *cp++; + } + *dest++ = 0; + if (!*cp) + error ("Unterminated string literal."); + cp++; + } + else + token = *cp++; + +#if DEBUGGING + dump_token (); +#endif + + return token; +} + +/* Force the current token to be an identifier token. */ +void +force_id (void) +{ + if (token != T_ID) + error ("Identifier expected."); +} + +/* Force the current token to be a string token. */ +void +force_string (void) +{ + if (token != T_STRING) + error ("String expected."); +} + +/* Checks whether the current token is the identifier S; if so, skips + the token and returns 1; otherwise, returns 0. */ +int +match_id (const char *s) +{ + if (token == T_ID && !strcmp (tokstr, s)) + { + lex_get (); + return 1; + } + return 0; +} + +/* Checks whether the current token is T. If so, skips the token and + returns 1; otherwise, returns 0. */ +int +match_token (int t) +{ + if (token == t) + { + lex_get (); + return 1; + } + return 0; +} + +/* Force the current token to be T, and skip it. */ +void +skip_token (int t) +{ + if (token != t) + error ("`%c' expected.", t); + lex_get (); +} + +/* Structures. */ + +/* Some specifiers have associated values. */ +enum + { + VAL_NONE, /* No value. */ + VAL_INT, /* Integer value. */ + VAL_DBL /* Floating point value. */ + }; + +/* For those specifiers with values, the syntax of those values. */ +enum + { + VT_PLAIN, /* Unadorned value. */ + VT_PAREN /* Value must be enclosed in parentheses. */ + }; + +/* Forward definition. */ +typedef struct specifier specifier; + +/* A single setting. */ +typedef struct setting setting; +struct setting + { + specifier *parent; /* Owning specifier. */ + setting *next; /* Next in the chain. */ + char *specname; /* Name of the setting. */ + int con; /* Sequence number. */ + + /* Values. */ + int valtype; /* One of VT_*. */ + int value; /* One of VAL_*. */ + int optvalue; /* 1=value is optional, 0=value is required. */ + char *valname; /* Variable name for the value. */ + char *restriction; /* !=NULL: expression specifying valid values. */ + }; + +/* A single specifier. */ +struct specifier + { + specifier *next; /* Next in the chain. */ + char *varname; /* Variable name. */ + setting *s; /* Associated settings. */ + + setting *def; /* Default setting. */ + setting *omit_kw; /* Setting for which the keyword can be omitted. */ + + int index; /* Next array index. */ + }; + +/* Subcommand types. */ +typedef enum + { + SBC_PLAIN, /* The usual case. */ + SBC_VARLIST, /* Variable list. */ + SBC_INT, /* Integer value. */ + SBC_PINT, /* Integer inside parentheses. */ + SBC_DBL, /* Floating point value. */ + SBC_INT_LIST, /* List of integers (?). */ + SBC_DBL_LIST, /* List of floating points (?). */ + SBC_CUSTOM, /* Custom. */ + SBC_ARRAY, /* Array of boolean values. */ + SBC_STRING, /* String value. */ + SBC_VAR /* Single variable name. */ + } +subcommand_type; + +/* A single subcommand. */ +typedef struct subcommand subcommand; +struct subcommand + { + subcommand *next; /* Next in the chain. */ + char *name; /* Subcommand name. */ + subcommand_type type; /* One of SBC_*. */ + int once; /* 1=Subcommand may appear only once. */ + int narray; /* Index of next array element. */ + const char *prefix; /* Prefix for variable and constant names. */ + specifier *spec; /* Array of specifiers. */ + + /* SBC_STRING only. */ + char *restriction; /* Expression restricting string length. */ + char *message; /* Error message. */ + }; + +/* Name of the command; i.e., DESCRIPTIVES. */ +char *cmdname; + +/* Short prefix for the command; i.e., `dsc_'. */ +char *prefix; + +/* List of subcommands. */ +subcommand *subcommands; + +/* Default subcommand if any, or NULL. */ +subcommand *def; + +/* Parsing. */ + +void parse_subcommands (void); + +/* Parse an entire specification. */ +void +parse (void) +{ + /* Get the command name and prefix. */ + if (token != T_STRING && token != T_ID) + error ("Command name expected."); + cmdname = xstrdup (tokstr); + lex_get (); + skip_token ('('); + force_id (); + prefix = xstrdup (tokstr); + lex_get (); + skip_token (')'); + skip_token (':'); + + /* Read all the subcommands. */ + subcommands = NULL; + def = NULL; + parse_subcommands (); +} + +/* Parses a single setting into S, given subcommand information SBC + and specifier information SPEC. */ +void +parse_setting (setting *s, specifier *spec) +{ + s->parent = spec; + + if (match_token ('*')) + { + if (spec->omit_kw) + error ("Cannot have two settings with omittable keywords."); + else + spec->omit_kw = s; + } + + if (match_token ('!')) + { + if (spec->def) + error ("Cannot have two default settings."); + else + spec->def = s; + } + + force_id (); + s->specname = xstrdup (tokstr); + s->con = add_symbol (s->specname, 0, 0); + s->value = VAL_NONE; + + lex_get (); + + /* Parse setting value info if necessary. */ + if (token != '/' && token != ';' && token != '.' && token != ',') + { + if (token == '(') + { + s->valtype = VT_PAREN; + lex_get (); + } + else + s->valtype = VT_PLAIN; + + s->optvalue = match_token ('*'); + + if (match_id ("N")) + s->value = VAL_INT; + else if (match_id ("D")) + s->value = VAL_DBL; + else + error ("`n' or `d' expected."); + + skip_token (':'); + + force_id (); + s->valname = xstrdup (tokstr); + lex_get (); + + if (token == ',') + { + lex_get (); + force_string (); + s->restriction = xstrdup (tokstr); + lex_get (); + } + else + s->restriction = NULL; + + if (s->valtype == VT_PAREN) + skip_token (')'); + } +} + +/* Parse a single specifier into SPEC, given subcommand information + SBC. */ +void +parse_specifier (specifier *spec, subcommand *sbc) +{ + spec->index = 0; + spec->s = NULL; + spec->def = NULL; + spec->omit_kw = NULL; + spec->varname = NULL; + + if (token == T_ID) + { + spec->varname = xstrdup (st_lower (tokstr)); + lex_get (); + } + + /* Handle array elements. */ + if (token != ':') + { + spec->index = sbc->narray; + if (sbc->type == SBC_ARRAY) + { + if (token == '|') + token = ','; + else + sbc->narray++; + } + spec->s = NULL; + return; + } + skip_token (':'); + + /* Parse all the settings. */ + { + setting **s = &spec->s; + + for (;;) + { + *s = xmalloc (sizeof (setting)); + parse_setting (*s, spec); + if (token == ',' || token == ';' || token == '.') + break; + skip_token ('/'); + s = &(*s)->next; + } + (*s)->next = NULL; + } +} + +/* Parse a list of specifiers for subcommand SBC. */ +void +parse_specifiers (subcommand *sbc) +{ + specifier **spec = &sbc->spec; + + if (token == ';' || token == '.') + { + *spec = NULL; + return; + } + + for (;;) + { + *spec = xmalloc (sizeof (specifier)); + parse_specifier (*spec, sbc); + if (token == ';' || token == '.') + break; + skip_token (','); + spec = &(*spec)->next; + } + (*spec)->next = NULL; +} + +/* Parse a subcommand into SBC. */ +void +parse_subcommand (subcommand *sbc) +{ + if (match_token ('*')) + { + if (def) + error ("Multiple default subcommands."); + def = sbc; + } + + sbc->once = match_token ('+'); + + force_id (); + sbc->name = xstrdup (tokstr); + lex_get (); + + sbc->narray = 0; + sbc->type = SBC_PLAIN; + sbc->spec = NULL; + + if (match_token ('[')) + { + force_id (); + sbc->prefix = xstrdup (st_lower (tokstr)); + lex_get (); + + skip_token (']'); + skip_token ('='); + + sbc->type = SBC_ARRAY; + parse_specifiers (sbc); + } + else + { + if (match_token ('(')) + { + force_id (); + sbc->prefix = xstrdup (st_lower (tokstr)); + lex_get (); + + skip_token (')'); + } + else + sbc->prefix = ""; + + skip_token ('='); + + if (match_id ("VAR")) + sbc->type = SBC_VAR; + if (match_id ("VARLIST")) + { + if (match_token ('(')) + { + force_string (); + sbc->message = xstrdup (tokstr); + lex_get(); + + skip_token (')'); + } + else sbc->message = NULL; + + sbc->type = SBC_VARLIST; + } + else if (match_id ("INTEGER")) + sbc->type = match_id ("LIST") ? SBC_INT_LIST : SBC_INT; + else if (match_id ("PINT")) + sbc->type = SBC_PINT; + else if (match_id ("DOUBLE")) + sbc->type = match_id ("LIST") ? SBC_DBL_LIST : SBC_DBL; + else if (match_id ("STRING")) + { + sbc->type = SBC_STRING; + if (token == T_STRING) + { + sbc->restriction = xstrdup (tokstr); + lex_get (); + force_string (); + sbc->message = xstrdup (tokstr); + lex_get (); + } + else + sbc->restriction = NULL; + } + else if (match_id ("CUSTOM")) + sbc->type = SBC_CUSTOM; + else + parse_specifiers (sbc); + } +} + +/* Parse all the subcommands. */ +void +parse_subcommands (void) +{ + subcommand **sbc = &subcommands; + + for (;;) + { + *sbc = xmalloc (sizeof (subcommand)); + (*sbc)->next = NULL; + + parse_subcommand (*sbc); + + if (token == '.') + return; + + skip_token (';'); + sbc = &(*sbc)->next; + } +} + +/* Output. */ + +#define BASE_INDENT 2 /* Starting indent. */ +#define INC_INDENT 2 /* Indent increment. */ + +/* Increment the indent. */ +#define indent() indent += INC_INDENT +#define outdent() indent -= INC_INDENT + +/* Size of the indent from the left margin. */ +int indent; + +#if __GNUC__ >= 2 +void dump (int, const char *, ...) __attribute__ ((format (printf, 2, 3))); +#endif + +/* Write line FORMAT to the output file, formatted as with printf, + indented `indent' characters from the left margin. If INDENTION is + greater than 0, indents BASE_INDENT * INDENTION characters after + writing the line; if INDENTION is less than 0, dedents BASE_INDENT + * INDENTION characters _before_ writing the line. */ +void +dump (int indention, const char *format, ...) +{ + va_list args; + int i; + + if (indention < 0) + indent += BASE_INDENT * indention; + + oln++; + va_start (args, format); + for (i = 0; i < indent; i++) + putc (' ', out); + vfprintf (out, format, args); + putc ('\n', out); + va_end (args); + + if (indention > 0) + indent += BASE_INDENT * indention; +} + +/* Write the structure members for specifier SPEC to the output file. + SBC is the including subcommand. */ +void +dump_specifier_vars (const specifier *spec, const subcommand *sbc) +{ + if (spec->varname) + dump (0, "long %s%s;", sbc->prefix, spec->varname); + + { + setting *s; + + for (s = spec->s; s; s = s->next) + { + if (s->value != VAL_NONE) + { + const char *typename; + + assert (s->value == VAL_INT || s->value == VAL_DBL); + typename = s->value == VAL_INT ? "long" : "double"; + + dump (0, "%s %s%s;", typename, sbc->prefix, st_lower (s->valname)); + } + } + } +} + +/* Returns 1 if string T is a PSPP keyword, 0 otherwise. */ +int +is_keyword (const char *t) +{ + static const char *kw[] = + { + "AND", "OR", "NOT", "EQ", "GE", "GT", "LE", "LT", + "NE", "ALL", "BY", "TO", "WITH", 0, + }; + const char **cp; + + for (cp = kw; *cp; cp++) + if (!strcmp (t, *cp)) + return 1; + return 0; +} + +/* Transforms a string NAME into a valid C identifier: makes + everything lowercase and maps nonalphabetic characters to + underscores. Returns a pointer to a static buffer. */ +char * +make_identifier (const char *name) +{ + char *p = get_buffer (); + char *cp; + + for (cp = p; *name; name++) + if (isalpha ((unsigned char) *name)) + *cp++ = tolower ((unsigned char) (*name)); + else + *cp++ = '_'; + *cp = '\0'; + + return p; +} + +/* Writes the struct and enum declarations for the parser. */ +void +dump_declarations (void) +{ + indent = 0; + + /* Write out enums for all the identifiers in the symbol table. */ + { + int f, k; + symbol *sym; + char *buf = NULL; + + /* Note the squirmings necessary to make sure that the last enum + is not followed by a comma, as mandated by ANSI C89. */ + for (sym = symtab, f = k = 0; sym; sym = sym->next) + if (!sym->unique && !is_keyword (sym->name)) + { + if (!f) + { + dump (0, "/* Settings for subcommand specifiers. */"); + dump (1, "enum"); + dump (1, "{"); + f = 1; + } + + if (buf == NULL) + buf = xmalloc (1024); + else + dump (0, buf); + + if (k) + sprintf (buf, "%s%s,", st_upper (prefix), sym->name); + else + { + k = 1; + sprintf (buf, "%s%s = 1000,", st_upper (prefix), sym->name); + } + } + if (buf) + { + buf[strlen (buf) - 1] = 0; + dump (0, buf); + free (buf); + } + if (f) + { + dump (-1, "};"); + dump (-1, nullstr); + } + } + + /* For every array subcommand, write out the associated enumerated + values. */ + { + subcommand *sbc; + + for (sbc = subcommands; sbc; sbc = sbc->next) + if (sbc->type == SBC_ARRAY && sbc->narray) + { + dump (0, "/* Array indices for %s subcommand. */", sbc->name); + + dump (1, "enum"); + dump (1, "{"); + + { + specifier *spec; + + for (spec = sbc->spec; spec; spec = spec->next) + if (!spec->s) + dump (0, "%s%s%s = %d,", + st_upper (prefix), st_upper (sbc->prefix), + st_upper (spec->varname), spec->index); + + dump (0, "%s%scount", st_upper (prefix), st_upper (sbc->prefix)); + + dump (-1, "};"); + dump (-1, nullstr); + } + } + } + + /* Write out structure declaration. */ + { + subcommand *sbc; + + dump (0, "/* %s structure. */", cmdname); + dump (1, "struct cmd_%s", make_identifier (cmdname)); + dump (1, "{"); + for (sbc = subcommands; sbc; sbc = sbc->next) + { + int f = 0; + + if (sbc != subcommands) + dump (0, nullstr); + + dump (0, "/* %s subcommand. */", sbc->name); + dump (0, "int sbc_%s;", st_lower (sbc->name)); + + switch (sbc->type) + { + case SBC_ARRAY: + case SBC_PLAIN: + { + specifier *spec; + + for (spec = sbc->spec; spec; spec = spec->next) + { + if (spec->s == 0) + { + if (sbc->type == SBC_PLAIN) + dump (0, "long int %s%s;", st_lower (sbc->prefix), + spec->varname); + else if (f == 0) + { + dump (0, "int a_%s[%d];", + st_lower (sbc->name), sbc->narray); + f = 1; + } + } + else + dump_specifier_vars (spec, sbc); + } + } + break; + + case SBC_VARLIST: + dump (0, "int %sn_%s;", st_lower (sbc->prefix), + st_lower (sbc->name)); + dump (0, "struct variable **%sv_%s;", st_lower (sbc->prefix), + st_lower (sbc->name)); + break; + + case SBC_VAR: + dump (0, "struct variable *%sv_%s;", st_lower (sbc->prefix), + st_lower (sbc->name)); + break; + + case SBC_STRING: + dump (0, "char *s_%s;", st_lower (sbc->name)); + break; + + case SBC_INT: + case SBC_PINT: + dump (0, "long n_%s;", st_lower (sbc->name)); + break; + + default: + /* nothing */ + } + } + + dump (-1, "};"); + dump (-1, nullstr); + } + + /* Write out prototypes for custom_*() functions as necessary. */ + { + int seen = 0; + subcommand *sbc; + + for (sbc = subcommands; sbc; sbc = sbc->next) + if (sbc->type == SBC_CUSTOM) + { + if (!seen) + { + seen = 1; + dump (0, "/* Prototype for custom subcommands of %s. */", + cmdname); + } + dump (0, "static int %scustom_%s (struct cmd_%s *);", + st_lower (prefix), st_lower (sbc->name), + make_identifier (cmdname)); + } + + if (seen) + dump (0, nullstr); + } + + /* Prototypes for parsing and freeing functions. */ + { + dump (0, "/* Command parsing functions. */"); + dump (0, "static int parse_%s (struct cmd_%s *);", + make_identifier (cmdname), make_identifier (cmdname)); + dump (0, "static void free_%s (struct cmd_%s *);", + make_identifier (cmdname), make_identifier (cmdname)); + dump (0, nullstr); + } +} + +/* Writes out code to initialize all the variables that need + initialization for particular specifier SPEC inside subcommand SBC. */ +void +dump_specifier_init (const specifier *spec, const subcommand *sbc) +{ + if (spec->varname) + { + char s[256]; + + if (spec->def) + sprintf (s, "%s%s", + st_upper (prefix), find_symbol (spec->def->con)->name); + else + strcpy (s, "-1"); + dump (0, "p->%s%s = %s;", sbc->prefix, spec->varname, s); + } + + { + setting *s; + + for (s = spec->s; s; s = s->next) + { + if (s->value != VAL_NONE) + { + const char *init; + + assert (s->value == VAL_INT || s->value == VAL_DBL); + init = s->value == VAL_INT ? "NOT_LONG" : "SYSMIS"; + + dump (0, "p->%s%s = %s;", sbc->prefix, st_lower (s->valname), init); + } + } + } +} + +/* Write code to initialize all variables. */ +void +dump_vars_init (void) +{ + /* Loop through all the subcommands. */ + { + subcommand *sbc; + + for (sbc = subcommands; sbc; sbc = sbc->next) + { + int f = 0; + + dump (0, "p->sbc_%s = 0;", st_lower (sbc->name)); + switch (sbc->type) + { + case SBC_DBL: + case SBC_INT_LIST: + case SBC_DBL_LIST: + case SBC_CUSTOM: + /* nothing */ + break; + + case SBC_PLAIN: + case SBC_ARRAY: + { + specifier *spec; + + for (spec = sbc->spec; spec; spec = spec->next) + if (spec->s == NULL) + { + if (sbc->type == SBC_PLAIN) + dump (0, "p->%s%s = 0;", sbc->prefix, spec->varname); + else if (f == 0) + { + dump (0, "memset (p->a_%s, 0, sizeof p->a_%s);", + st_lower (sbc->name), st_lower (sbc->name)); + f = 1; + } + } + else + dump_specifier_init (spec, sbc); + } + break; + + case SBC_VARLIST: + dump (0, "p->%sn_%s = 0;", + st_lower (sbc->prefix), st_lower (sbc->name)); + dump (0, "p->%sv_%s = NULL;", + st_lower (sbc->prefix), st_lower (sbc->name)); + break; + + case SBC_VAR: + dump (0, "p->%sv_%s = NULL;", + st_lower (sbc->prefix), st_lower (sbc->name)); + break; + + case SBC_STRING: + dump (0, "p->s_%s = NULL;", st_lower (sbc->name)); + break; + + case SBC_INT: + case SBC_PINT: + dump (0, "p->n_%s = NOT_LONG;", st_lower (sbc->name)); + break; + + default: + assert (0); + } + } + } +} + +/* Return a pointer to a static buffer containing an expression that + will match token T. */ +char * +make_match (const char *t) +{ + char *s; + + s = get_buffer (); + + while (*t == '_') + t++; + + if (is_keyword (t)) + sprintf (s, "lex_match (T_%s)", t); + else if (!strcmp (t, "ON") || !strcmp (t, "YES")) + strcpy (s, "(lex_match_id (\"ON\") || lex_match_id (\"YES\") " + "|| lex_match_id (\"TRUE\"))"); + else if (!strcmp (t, "OFF") || !strcmp (t, "NO")) + strcpy (s, "(lex_match_id (\"OFF\") || lex_match_id (\"NO\") " + "|| lex_match_id (\"FALSE\"))"); + else if (isdigit ((unsigned char) t[0])) + sprintf (s, "lex_match_int (%s)", t); + else + sprintf (s, "lex_match_id (\"%s\")", t); + + return s; +} + +/* Write out the parsing code for specifier SPEC within subcommand + SBC. */ +void +dump_specifier_parse (const specifier *spec, const subcommand *sbc) +{ + setting *s; + + if (spec->omit_kw && spec->omit_kw->next) + error ("Omittable setting is not last setting in `%s' specifier.", + spec->varname); + if (spec->omit_kw && spec->omit_kw->parent->next) + error ("Default specifier is not in last specifier in `%s' " + "subcommand.", sbc->name); + + for (s = spec->s; s; s = s->next) + { + int first = spec == sbc->spec && s == spec->s; + + /* Match the setting's keyword. */ + if (spec->omit_kw == s) + { + if (!first) + { + dump (1, "else"); + dump (1, "{"); + } + dump (1, "%s;", make_match (s->specname)); + } + else + dump (1, "%sif (%s)", first ? "" : "else ", + make_match (s->specname)); + + /* Handle values. */ + if (s->value == VAL_NONE) + dump (0, "p->%s%s = %s%s;", sbc->prefix, spec->varname, + st_upper (prefix), find_symbol (s->con)->name); + else + { + if (spec->omit_kw != s) + dump (1, "{"); + + if (spec->varname) + dump (0, "p->%s%s = %s%s;", sbc->prefix, spec->varname, + st_upper (prefix), find_symbol (s->con)->name); + + if (s->valtype == VT_PAREN) + { + if (s->optvalue) + { + dump (1, "if (lex_match ('('))"); + dump (1, "{"); + } + else + { + dump (1, "if (!lex_match ('('))"); + dump (1, "{"); + dump (0, "msg (SE, _(\"`(' expected after %s " + "specifier of %s subcommand.\"));", + s->specname, sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + } + } + + if (s->value == VAL_INT) + { + dump (1, "if (!lex_integer_p ())"); + dump (1, "{"); + dump (0, "msg (SE, _(\"%s specifier of %s subcommand " + "requires an integer argument.\"));", + s->specname, sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + dump (-1, "p->%s%s = lex_integer ();", + sbc->prefix, st_lower (s->valname)); + } + else + { + dump (1, "if (token != T_NUM)"); + dump (1, "{"); + dump (0, "msg (SE, _(\"Number expected after %s " + "specifier of %s subcommand.\"));", + s->specname, sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + dump (-1, "p->%s%s = tokval;", sbc->prefix, + st_lower (s->valname)); + } + + if (s->restriction) + { + { + char *str, *str2; + str = xmalloc (MAX_TOK_LEN); + str2 = xmalloc (MAX_TOK_LEN); + sprintf (str2, "p->%s%s", sbc->prefix, st_lower (s->valname)); + sprintf (str, s->restriction, str2, str2, str2, str2, + str2, str2, str2, str2); + dump (1, "if (!(%s))", str); + free (str); + free (str2); + } + + dump (1, "{"); + dump (0, "msg (SE, _(\"Bad argument for %s " + "specifier of %s subcommand.\"));", + s->specname, sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + } + + dump (0, "lex_get ();"); + + if (s->valtype == VT_PAREN) + { + dump (1, "if (!lex_match (')'))"); + dump (1, "{"); + dump (0, "msg (SE, _(\"`)' expected after argument for " + "%s specifier of %s.\"));", + s->specname, sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + if (s->optvalue) + { + dump (-1, "}"); + outdent (); + } + } + + if (s != spec->omit_kw) + dump (-1, "}"); + } + + if (s == spec->omit_kw) + { + dump (-1, "}"); + outdent (); + } + outdent (); + } +} + +/* Write out the code to parse subcommand SBC. */ +void +dump_subcommand (const subcommand *sbc) +{ + if (sbc->type == SBC_PLAIN || sbc->type == SBC_ARRAY) + { + int count; + + dump (1, "while (token != '/' && token != '.')"); + dump (1, "{"); + + { + specifier *spec; + + for (count = 0, spec = sbc->spec; spec; spec = spec->next) + { + if (spec->s) + dump_specifier_parse (spec, sbc); + else + { + count++; + dump (1, "%sif (%s)", spec != sbc->spec ? "else " : "", + make_match (st_upper (spec->varname))); + if (sbc->type == SBC_PLAIN) + dump (0, "p->%s%s = 1;", st_lower (sbc->prefix), + spec->varname); + else + dump (0, "p->a_%s[%s%s%s] = 1;", + st_lower (sbc->name), + st_upper (prefix), st_upper (sbc->prefix), + st_upper (spec->varname)); + outdent (); + } + } + } + + { + specifier *spec; + setting *s; + + /* This code first finds the last specifier in sbc. Then it + finds the last setting within that last specifier. Either + or both might be NULL. */ + spec = sbc->spec; + s = NULL; + if (spec) + { + while (spec->next) + spec = spec->next; + s = spec->s; + if (s) + while (s->next) + s = s->next; + } + + if (spec && (!spec->s || !spec->omit_kw)) + { + dump (1, "else"); + dump (1, "{"); + dump (0, "lex_error (NULL);"); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + } + } + + dump (0, "lex_match (',');"); + dump (-1, "}"); + outdent (); + } + else if (sbc->type == SBC_VARLIST) + { + dump (1, "if (!parse_variables (NULL, &p->%sv_%s, &p->%sn_%s, " + "PV_APPEND%s%s))", + st_lower (sbc->prefix), st_lower (sbc->name), + st_lower (sbc->prefix), st_lower (sbc->name), + sbc->message ? " |" : "", + sbc->message ? sbc->message : ""); + dump (0, "goto lossage;"); + outdent (); + } + else if (sbc->type == SBC_VAR) + { + dump (0, "p->%sv_%s = parse_variable ();", + st_lower (sbc->prefix), st_lower (sbc->name)); + dump (1, "if (p->%sv_%s)", + st_lower (sbc->prefix), st_lower (sbc->name)); + dump (0, "goto lossage;"); + outdent (); + } + else if (sbc->type == SBC_STRING) + { + if (sbc->restriction) + { + dump (1, "{"); + dump (0, "int x;"); + } + dump (1, "if (!lex_force_string ())"); + dump (0, "return 0;"); + outdent (); + if (sbc->restriction) + { + dump (0, "x = ds_length (&tokstr);"); + dump (1, "if (!(%s))", sbc->restriction); + dump (1, "{"); + dump (0, "msg (SE, _(\"String for %s must be %s.\"));", + sbc->name, sbc->message); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + } + dump (0, "p->s_%s = xstrdup (ds_value (&tokstr));", + st_lower (sbc->name)); + dump (0, "lex_get ();"); + if (sbc->restriction) + dump (-1, "}"); + } + else if (sbc->type == SBC_INT) + { + dump (1, "if (!lex_force_int ())"); + dump (0, "goto lossage;"); + dump (-1, "p->n_%s = lex_integer ();", st_lower (sbc->name)); + } + else if (sbc->type == SBC_PINT) + { + dump (0, "lex_match ('(');"); + dump (1, "if (!lex_force_int ())"); + dump (0, "goto lossage;"); + dump (-1, "p->n_%s = lex_integer ();", st_lower (sbc->name)); + dump (0, "lex_match (')');"); + } + else if (sbc->type == SBC_CUSTOM) + { + dump (1, "switch (%scustom_%s (p))", + st_lower (prefix), st_lower (sbc->name)); + dump (0, "{"); + dump (1, "case 0:"); + dump (0, "goto lossage;"); + dump (-1, "case 1:"); + indent (); + dump (0, "break;"); + dump (-1, "case 2:"); + indent (); + dump (0, "lex_error (NULL);"); + dump (0, "goto lossage;"); + dump (-1, "default:"); + indent (); + dump (0, "assert (0);"); + dump (-1, "}"); + outdent (); + } +} + +/* Write out entire parser. */ +void +dump_parser (void) +{ + int f; + + indent = 0; + + dump (0, "static int"); + dump (0, "parse_%s (struct cmd_%s *p)", make_identifier (cmdname), + make_identifier (cmdname)); + dump (1, "{"); + + dump_vars_init (); + + dump (1, "for (;;)"); + dump (1, "{"); + + f = 0; + if (def && (def->type == SBC_VARLIST)) + { + if (def->type == SBC_VARLIST) + dump (1, "if (token == T_ID && is_varname (tokid) && " + "lex_look_ahead () != '=')"); + else + { + dump (0, "if ((token == T_ID && is_varname (tokid) && " + "lex_look_ahead () != '=')"); + dump (1, " || token == T_ALL)"); + } + dump (1, "{"); + dump (0, "p->sbc_%s++;", st_lower (def->name)); + dump (1, "if (!parse_variables (NULL, &p->%sv_%s, &p->%sn_%s, " + "PV_APPEND))", + st_lower (def->prefix), st_lower (def->name), + st_lower (def->prefix), st_lower (def->name)); + dump (0, "goto lossage;"); + dump (-2, "}"); + outdent (); + f = 1; + } + else if (def && def->type == SBC_CUSTOM) + { + dump (1, "switch (%scustom_%s (p))", + st_lower (prefix), st_lower (def->name)); + dump (0, "{"); + dump (1, "case 0:"); + dump (0, "goto lossage;"); + dump (-1, "case 1:"); + indent (); + dump (0, "p->sbc_%s++;", st_lower (def->name)); + dump (0, "continue;"); + dump (-1, "case 2:"); + indent (); + dump (0, "break;"); + dump (-1, "default:"); + indent (); + dump (0, "assert (0);"); + dump (-1, "}"); + outdent (); + } + + { + subcommand *sbc; + + for (sbc = subcommands; sbc; sbc = sbc->next) + { + dump (1, "%sif (%s)", f ? "else " : "", make_match (sbc->name)); + f = 1; + dump (1, "{"); + + dump (0, "lex_match ('=');"); + dump (0, "p->sbc_%s++;", st_lower (sbc->name)); + if (sbc->once) + { + dump (1, "if (p->sbc_%s > 1)", st_lower (sbc->name)); + dump (1, "{"); + dump (0, "msg (SE, _(\"%s subcommand may be given only once.\"));", + sbc->name); + dump (0, "goto lossage;"); + dump (-1, "}"); + outdent (); + } + dump_subcommand (sbc); + dump (-1, "}"); + outdent (); + } + } + + dump (1, "if (!lex_match ('/'))"); + dump (0, "break;"); + dump (-2, "}"); + outdent (); + dump (0, nullstr); + dump (1, "if (token != '.')"); + dump (1, "{"); + dump (0, "lex_error (_(\"expecting end of command\"));"); + dump (0, "goto lossage;"); + dump (-1, "}"); + dump (0, nullstr); + dump (-1, "return 1;"); + dump (0, nullstr); + dump (-1, "lossage:"); + indent (); + dump (0, "free_%s (p);", make_identifier (cmdname)); + dump (0, "return 0;"); + dump (-1, "}"); + dump (0, nullstr); +} + +/* Write the output file header. */ +void +dump_header (void) +{ + time_t curtime; + struct tm *loctime; + char *timep; + + indent = 0; + curtime = time (NULL); + loctime = localtime (&curtime); + timep = asctime (loctime); + timep[strlen (timep) - 1] = 0; + dump (0, "/* %s", ofn); + dump (0, nullstr); + dump (0, " Generated by q2c from %s on %s.", ifn, timep); + dump (0, " Do not modify!"); + dump (0, " */"); + dump (0, nullstr); +} + +/* Write out commands to free variable state. */ +void +dump_free (void) +{ + subcommand *sbc; + int used; + + indent = 0; + + used = 0; + for (sbc = subcommands; sbc; sbc = sbc->next) + if (sbc->type == SBC_STRING) + used = 1; + + dump (0, "static void"); + dump (0, "free_%s (struct cmd_%s *p%s)", make_identifier (cmdname), + make_identifier (cmdname), used ? "" : " unused"); + dump (1, "{"); + + for (sbc = subcommands; sbc; sbc = sbc->next) + if (sbc->type == SBC_STRING) + dump (0, "free (p->s_%s);", st_lower (sbc->name)); + + dump (-1, "}"); +} + +/* Returns the name of a directive found on the current input line, if + any, or a null pointer if none found. */ +const char * +recognize_directive (void) +{ + static char directive[16]; + char *sp, *ep; + + sp = skip_ws (buf); + if (strncmp (sp, "/*", 2)) + return NULL; + sp = skip_ws (sp + 2); + if (*sp != '(') + return NULL; + sp++; + + ep = strchr (sp, ')'); + if (ep == NULL) + return NULL; + + if (ep - sp > 15) + ep = sp + 15; + memcpy (directive, sp, ep - sp); + directive[ep - sp] = '\0'; + return directive; +} + +int +main (int argc, char *argv[]) +{ + pgmname = argv[0]; + if (argc != 3) + fail ("Syntax: q2c input.q output.c"); + + ifn = argv[1]; + in = fopen (ifn, "r"); + if (!in) + fail ("%s: open: %s.", ifn, strerror (errno)); + + ofn = argv[2]; + out = fopen (ofn, "w"); + if (!out) + fail ("%s: open: %s.", ofn, strerror (errno)); + + is_open = 1; + buf = xmalloc (MAX_LINE_LEN); + tokstr = xmalloc (MAX_TOK_LEN); + + dump_header (); + + indent = 0; + dump (0, "#line %d \"%s\"", ln + 1, ifn); + while (get_line ()) + { + const char *directive = recognize_directive (); + if (directive == NULL) + { + dump (0, "%s", buf); + continue; + } + + dump (0, "#line %d \"%s\"", oln - 1, ofn); + if (!strcmp (directive, "specification")) + { + /* Skip leading slash-star line. */ + get_line (); + lex_get (); + + parse (); + + /* Skip trailing star-slash line. */ + get_line (); + } + else if (!strcmp (directive, "headers")) + { + indent = 0; + + dump (0, "#include "); + dump (0, "#include "); + dump (0, "#include \"alloc.h\""); + dump (0, "#include \"error.h\""); + dump (0, "#include \"lexer.h\""); + dump (0, "#include \"str.h\""); + dump (0, "#include \"var.h\""); + dump (0, nullstr); + } + else if (!strcmp (directive, "declarations")) + dump_declarations (); + else if (!strcmp (directive, "functions")) + { + dump_parser (); + dump_free (); + } + else + error ("unknown directive `%s'", directive); + indent = 0; + dump (0, "#line %d \"%s\"", ln + 1, ifn); + } + + return EXIT_SUCCESS; +} + diff --git a/src/random.c b/src/random.c new file mode 100644 index 00000000..7f63f477 --- /dev/null +++ b/src/random.c @@ -0,0 +1,149 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "magic.h" +#include "random.h" +#include "settings.h" + +/* Deal with broken system random number generator. */ +#if HAVE_GOOD_RANDOM +#define real_rand rand +#define real_srand srand +#define REAL_RAND_MAX RAND_MAX +#else /* !HAVE_GOOD_RANDOM */ +#define REAL_RAND_MAX 32767 + +/* Some systems are so broken that they do not supply a value for + RAND_MAX. There is absolutely no reliable way to determine this + value, either. So we must supply our own. This one is the one + presented in the ANSI C standard as strictly compliant. */ +static unsigned long int next = 1; + +int +real_rand (void) +{ + next = next * 1103515245 + 12345; + return (unsigned int)(next / 65536) % 32768; +} + +void +real_srand (unsigned int seed) +{ + next = seed; +} +#endif /* !HAVE_GOOD_RANDOM */ + +/* The random number generator here is an implementation in C of + Knuth's Algorithm 3.2.2B (Randomizing by Shuffling) in _The Art of + Computer Programming_, Vol. 2. */ + +#define k 13 +static int V[k]; +static int Y; + +static double X2; + +/* Initializes the random number generator. Should be called once by + every cmd_*() that uses random numbers. Note that this includes + all procedures that use expressions since they may generate random + numbers. */ +void +setup_randomize (void) +{ + static time_t curtime; + int i; + + if (set_seed == NOT_LONG) + { + if (!curtime) + time (&curtime); + real_srand (curtime++); + } + else + real_srand (set_seed); + + set_seed_used = 1; + + for (i = 0; i < k; i++) + V[i] = real_rand (); + Y = real_rand (); + X2 = NOT_DOUBLE; +} + +/* Standard shuffling procedure for increasing randomness of the ANSI + C random number generator. Returns a random number R where 0 <= R + <= RAND_MAX. */ +inline int +shuffle (void) +{ + int j = k * Y / RAND_MAX; + Y = V[j]; + V[j] = real_rand (); + return Y; +} + +/* Returns a random number R where 0 <= R <= X. */ +double +rand_uniform (double x) +{ + return ((double) shuffle ()) / (((double) RAND_MAX) / x); +} + +/* Returns a random number from the distribution with mean 0 and + standard deviation X. This uses algorithm P in section 3.4.1C of + Knuth's _Art of Computer Programming_, Vol 2. */ +double +rand_normal (double x) +{ + double U1, U2; + double V1, V2; + double S; + double X1; + + if (X2 != NOT_DOUBLE) + { + double t = X2; + X2 = NOT_DOUBLE; + return t * x; + } + do + { + U1 = ((double) shuffle ()) / RAND_MAX; + U2 = ((double) shuffle ()) / RAND_MAX; + V1 = 2 * U1 - 1; + V2 = 2 * U2 - 1; + S = V1 * V1 + V2 * V2; + } + while (S >= 1); + X1 = V1 * sqrt (-2. * log (S) / S); + X2 = V2 * sqrt (-2. * log (S) / S); + return X1 * x; +} + +/* Returns a random integer R, where 0 <= R < X. */ +int +rand_simple (int x) +{ + return shuffle () % x; +} + diff --git a/src/random.h b/src/random.h new file mode 100644 index 00000000..b76f2e45 --- /dev/null +++ b/src/random.h @@ -0,0 +1,28 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !random_h +#define random_h 1 + +void setup_randomize (void); +double rand_uniform (double x); +double rand_normal (double x); +int rand_simple (int x); + +#endif /* random.h */ diff --git a/src/recode.c b/src/recode.c new file mode 100644 index 00000000..d799a38b --- /dev/null +++ b/src/recode.c @@ -0,0 +1,1121 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "cases.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "magic.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* Definitions. */ + +enum + { + RCD_END, /* sentinel value */ + RCD_USER, /* user-missing => one */ + RCD_SINGLE, /* one => one */ + RCD_HIGH, /* x > a => one */ + RCD_LOW, /* x < b => one */ + RCD_RANGE, /* b < x < a => one */ + RCD_ELSE, /* any but SYSMIS => one */ + RCD_CONVERT /* "123" => 123 */ + }; + +/* Describes how to recode a single value or range of values into a + single value. */ +struct coding + { + int type; /* RCD_* */ + union value f1, f2; /* Describe value or range as src. Long + strings are stored in `c'. */ + union value t; /* Describes value as dest. Long strings in `c'. */ + }; + +/* Describes how to recode a single variable. */ +struct rcd_var + { + struct rcd_var *next; + + unsigned flags; /* RCD_SRC_* | RCD_DEST_* | RCD_MISC_* */ + + struct variable *src; /* Source variable. */ + struct variable *dest; /* Destination variable. */ + char dest_name[9]; /* Name of dest variable if we're creating it. */ + + int has_sysmis; /* Do we recode for SYSMIS? */ + union value sysmis; /* Coding for SYSMIS (if src is numeric). */ + + struct coding *map; /* Coding for other values. */ + int nmap, mmap; /* Length of map, max capacity of map. */ + }; + +/* RECODE transformation. */ +struct recode_trns + { + struct trns_header h; + struct rcd_var *codings; + }; + +/* What we're recoding from (`src'==`source'). */ +#define RCD_SRC_ERROR 0000u /* Bad value for src. */ +#define RCD_SRC_NUMERIC 0001u /* Src is numeric. */ +#define RCD_SRC_STRING 0002u /* Src is short string. */ +#define RCD_SRC_MASK 0003u /* AND mask to isolate src bits. */ + +/* What we're recoding to (`dest'==`destination'). */ +#define RCD_DEST_ERROR 0000u /* Bad value for dest. */ +#define RCD_DEST_NUMERIC 0004u /* Dest is numeric. */ +#define RCD_DEST_STRING 0010u /* Dest is short string. */ +#define RCD_DEST_MASK 0014u /* AND mask to isolate dest bits. */ + +/* Miscellaneous bits. */ +#define RCD_MISC_CREATE 0020u /* We create dest var (numeric only) */ +#define RCD_MISC_DUPLICATE 0040u /* This var_info has the same MAP + value as the previous var_info. + Prevents redundant free()ing. */ +#define RCD_MISC_MISSING 0100u /* Encountered MISSING or SYSMIS in + this input spec. */ + +static int parse_dest_spec (struct rcd_var * rcd, union value *v, + size_t *max_dst_width); +static int parse_src_spec (struct rcd_var * rcd, int type, size_t max_src_width); +static int recode_trns_proc (struct trns_header *, struct ccase *); +static void recode_trns_free (struct trns_header *); +static double convert_to_double (char *, int); + +#if DEBUGGING +static void debug_print (rcd_var * head); +#endif + +/* Parser. */ + +/* First transformation in the list. rcd is in this list. */ +static struct rcd_var *head; + +/* Variables in the current part of the recoding. */ +struct variable **v; +int nv; + +/* Parses the RECODE transformation. */ +int +cmd_recode (void) +{ + int i; + + /* Transformation that we're constructing. */ + struct rcd_var *rcd; + + /* Type of the src variables. */ + int type; + + /* Length of longest src string. */ + size_t max_src_width; + + /* Length of longest dest string. */ + size_t max_dst_width; + + /* For stepping through, constructing the linked list of + recodings. */ + struct rcd_var *iter; + + /* The real transformation, just a wrapper for a list of + rcd_var's. */ + struct recode_trns *trns; + + lex_match_id ("RECODE"); + + /* Parses each specification between slashes. */ + head = rcd = xmalloc (sizeof *rcd); + for (;;) + { + /* Whether we've already encountered a specification for SYSMIS. */ + int had_sysmis = 0; + + /* Initialize this rcd_var to ensure proper cleanup. */ + rcd->next = NULL; + rcd->map = NULL; + rcd->nmap = rcd->mmap = 0; + rcd->has_sysmis = 0; + rcd->sysmis.f = 0; + + /* Parse variable names. */ + if (!parse_variables (NULL, &v, &nv, PV_SAME_TYPE)) + goto lossage; + + /* Ensure all variables are same type; find length of longest + source variable. */ + type = v[0]->type; + max_src_width = v[0]->width; + + if (type == ALPHA) + for (i = 0; i < nv; i++) + if (v[i]->width > (int) max_src_width) + max_src_width = v[i]->width; + + /* Set up flags. */ + rcd->flags = 0; + if (type == NUMERIC) + rcd->flags |= RCD_SRC_NUMERIC; + else + rcd->flags |= RCD_SRC_STRING; + + /* Parse each coding in parentheses. */ + max_dst_width = 0; + if (!lex_force_match ('(')) + goto lossage; + for (;;) + { + /* Get the input value (before the `='). */ + int mark = rcd->nmap; + int code = parse_src_spec (rcd, type, max_src_width); + if (!code) + goto lossage; + + /* ELSE is the same as any other input spec except that it + precludes later sysmis specifications. */ + if (code == 3) + { + had_sysmis = 1; + code = 1; + } + + /* If keyword CONVERT was specified, there is no output + specification. */ + if (code == 1) + { + union value output; + + /* Get the output value (after the `='). */ + lex_get (); /* Skip `='. */ + if (!parse_dest_spec (rcd, &output, &max_dst_width)) + goto lossage; + + /* Set the value for SYSMIS if requested and if we don't + already have one. */ + if ((rcd->flags & RCD_MISC_MISSING) && !had_sysmis) + { + rcd->has_sysmis = 1; + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + rcd->sysmis.f = output.f; + else + rcd->sysmis.c = xstrdup (output.c); + had_sysmis = 1; + + rcd->flags &= ~RCD_MISC_MISSING; + } + + /* Since there may be multiple input values for a single + output, the output value need to propagated among all + of them. */ + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + for (i = mark; i < rcd->nmap; i++) + rcd->map[i].t.f = output.f; + else + { + for (i = mark; i < rcd->nmap; i++) + rcd->map[i].t.c = xstrdup (output.c); + free (output.c); + } + } + lex_get (); /* Skip `)'. */ + if (!lex_match ('(')) + break; + } + + /* Append sentinel value. */ + rcd->map[rcd->nmap++].type = RCD_END; + + /* Since multiple variables may use the same recodings, it is + necessary to propogate the codings to all of them. */ + rcd->src = v[0]; + rcd->dest = v[0]; + rcd->dest_name[0] = 0; + iter = rcd; + for (i = 1; i < nv; i++) + { + iter = iter->next = xmalloc (sizeof *iter); + iter->next = NULL; + iter->flags = rcd->flags | RCD_MISC_DUPLICATE; + iter->src = v[i]; + iter->dest = v[i]; + iter->dest_name[0] = 0; + iter->has_sysmis = rcd->has_sysmis; + iter->sysmis = rcd->sysmis; + iter->map = rcd->map; + } + + if (lex_match_id ("INTO")) + { + char **names; + int nnames; + + int success = 0; + + if (!parse_mixed_vars (&names, &nnames, PV_NONE)) + goto lossage; + + if (nnames != nv) + { + for (i = 0; i < nnames; i++) + free (names[i]); + free (names); + msg (SE, _("%d variable(s) cannot be recoded into " + "%d variable(s). Specify the same number " + "of variables as input and output variables."), + nv, nnames); + goto lossage; + } + + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING) + for (i = 0, iter = rcd; i < nv; i++, iter = iter->next) + { + struct variable *v = find_variable (names[i]); + + if (!v) + { + msg (SE, _("There is no string variable named " + "%s. (All string variables specified " + "on INTO must already exist. Use the " + "STRING command to create a string " + "variable.)"), names[i]); + goto INTO_fail; + } + if (v->type != ALPHA) + { + msg (SE, _("Type mismatch between input and output " + "variables. Output variable %s is not " + "a string variable, but all the input " + "variables are string variables."), v->name); + goto INTO_fail; + } + if (v->width > (int) max_dst_width) + max_dst_width = v->width; + iter->dest = v; + } + else + for (i = 0, iter = rcd; i < nv; i++, iter = iter->next) + { + struct variable *v = find_variable (names[i]); + + if (v) + { + if (v->type != NUMERIC) + { + msg (SE, _("Type mismatch after INTO: %s " + "is not a numeric variable."), v->name); + goto INTO_fail; + } + else + iter->dest = v; + } + else + strcpy (iter->dest_name, names[i]); + } + success = 1; + + /* Note that regardless of whether we succeed or fail, + flow-of-control comes here. `success' is the important + factor. Ah, if C had garbage collection... */ + INTO_fail: + for (i = 0; i < nnames; i++) + free (names[i]); + free (names); + if (!success) + goto lossage; + } + else + { + if (max_src_width > max_dst_width) + max_dst_width = max_src_width; + + if ((rcd->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC + && (rcd->flags & RCD_DEST_MASK) != RCD_DEST_NUMERIC) + { + msg (SE, _("INTO must be used when the input values are " + "numeric and output values are string.")); + goto lossage; + } + + if ((rcd->flags & RCD_SRC_MASK) != RCD_SRC_NUMERIC + && (rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + { + msg (SE, _("INTO must be used when the input values are " + "string and output values are numeric.")); + goto lossage; + } + } + + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING) + { + struct coding *cp; + + for (cp = rcd->map; cp->type != RCD_END; cp++) + if (cp->t.c) + { + if (strlen (cp->t.c) < max_dst_width) + { + /* The NULL is only really necessary for the + debugging code. */ + char *repl = xmalloc (max_dst_width + 1); + st_pad_copy (repl, cp->t.c, max_dst_width + 1); + free (cp->t.c); + cp->t.c = repl; + } + else + /* The strings are guaranteed to be in order of + nondecreasing length. */ + break; + } + + } + + if (!lex_match ('/')) + break; + while (rcd->next) + rcd = rcd->next; + rcd = rcd->next = xmalloc (sizeof *rcd); + + free (v); + } + + if (token != '.') + { + lex_error (_("expecting end of command")); + goto lossage; + } + + for (rcd = head; rcd; rcd = rcd->next) + if (rcd->dest_name[0]) + { + rcd->dest = create_variable (&default_dict, rcd->dest_name, + NUMERIC, 0); + if (!rcd->dest) + { + /* This can occur if a destname is duplicated. We could + give an error at parse time but I don't care enough. */ + rcd->dest = find_variable (rcd->dest_name); + assert (rcd->dest != NULL); + } + else + envector (rcd->dest); + } + + trns = xmalloc (sizeof *trns); + trns->h.proc = recode_trns_proc; + trns->h.free = recode_trns_free; + trns->codings = head; + add_transformation ((struct trns_header *) trns); + +#if DEBUGGING + debug_print (head); +#endif + + return CMD_SUCCESS; + + lossage: + { + struct recode_trns t; + + t.codings = head; + recode_trns_free ((struct trns_header *) &t); + return CMD_FAILURE; + } +} + +static int +parse_dest_spec (struct rcd_var * rcd, union value * v, size_t *max_dst_width) +{ + int flags; + + v->c = NULL; + + if (token == T_NUM) + { + v->f = tokval; + lex_get (); + flags = RCD_DEST_NUMERIC; + } + else if (lex_match_id ("SYSMIS")) + { + v->f = SYSMIS; + flags = RCD_DEST_NUMERIC; + } + else if (token == T_STRING) + { + size_t max = *max_dst_width; + size_t toklen = ds_length (&tokstr); + if (toklen > max) + max = toklen; + v->c = xmalloc (max + 1); + st_pad_copy (v->c, ds_value (&tokstr), max + 1); + flags = RCD_DEST_STRING; + *max_dst_width = max; + lex_get (); + } + else if (lex_match_id ("COPY")) + { + if ((rcd->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC) + { + flags = RCD_DEST_NUMERIC; + v->f = -SYSMIS; + } + else + { + flags = RCD_DEST_STRING; + v->c = NULL; + } + } + + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_ERROR) + rcd->flags |= flags; +#if 0 + else if (((rcd->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC + && flags != RCD_DEST_NUMERIC) + || ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_STRING + && flags != RCD_DEST_STRING)) +#endif + else if ((rcd->flags & RCD_DEST_MASK) ^ flags) + { + msg (SE, _("Inconsistent output types. The output values " + "must be all numeric or all string.")); + return 0; + } + + return 1; +} + +/* Reads a set of source specifications and returns one of the + following values: 0 on failure; 1 for normal success; 2 for success + but with CONVERT as the keyword; 3 for success but with ELSE as the + keyword. */ +static int +parse_src_spec (struct rcd_var * rcd, int type, size_t max_src_width) +{ + struct coding *c; + + for (;;) + { + if (rcd->nmap >= rcd->mmap - 1) + { + rcd->mmap += 16; + rcd->map = xrealloc (rcd->map, rcd->mmap * sizeof *rcd->map); + } + + c = &rcd->map[rcd->nmap]; + c->f1.c = c->f2.c = NULL; + if (lex_match_id ("ELSE")) + { + c->type = RCD_ELSE; + rcd->nmap++; + return 3; + } + else if (type == NUMERIC) + { + if (token == T_ID) + { + if (lex_match_id ("LO") || lex_match_id ("LOWEST")) + { + if (!lex_force_match_id ("THRU")) + return 0; + if (lex_match_id ("HI") || lex_match_id ("HIGHEST")) + c->type = RCD_ELSE; + else if (token == T_NUM) + { + c->type = RCD_LOW; + c->f1.f = tokval; + lex_get (); + } + else + { + lex_error (_("following LO THRU")); + return 0; + } + } + else if (lex_match_id ("MISSING")) + { + c->type = RCD_USER; + rcd->flags |= RCD_MISC_MISSING; + } + else if (lex_match_id ("SYSMIS")) + { + c->type = RCD_END; + rcd->flags |= RCD_MISC_MISSING; + } + else + { + lex_error (_("in source value")); + return 0; + } + } + else if (token == T_NUM) + { + c->f1.f = tokval; + lex_get (); + if (lex_match_id ("THRU")) + { + if (lex_match_id ("HI") || lex_match_id ("HIGHEST")) + c->type = RCD_HIGH; + else if (token == T_NUM) + { + c->type = RCD_RANGE; + c->f2.f = tokval; + lex_get (); + } + else + { + lex_error (NULL); + return 0; + } + } + else + c->type = RCD_SINGLE; + } + else + { + lex_error (_("in source value")); + return 0; + } + } + else + { + assert (type == ALPHA); + if (lex_match_id ("CONVERT")) + { + if ((rcd->flags & RCD_DEST_MASK) == RCD_DEST_ERROR) + rcd->flags |= RCD_DEST_NUMERIC; + else if ((rcd->flags & RCD_DEST_MASK) != RCD_DEST_NUMERIC) + { + msg (SE, _("Keyword CONVERT may only be used with " + "string input values and numeric output " + "values.")); + return 0; + } + + c->type = RCD_CONVERT; + rcd->nmap++; + return 2; + } + else + { + /* Only the debugging code needs the NULLs at the ends + of the strings. However, changing code behavior more + than necessary based on the DEBUGGING `#define' is just + *inviting* bugs. */ + c->type = RCD_SINGLE; + if (!lex_force_string ()) + return 0; + c->f1.c = xmalloc (max_src_width + 1); + st_pad_copy (c->f1.c, ds_value (&tokstr), max_src_width + 1); + lex_get (); + } + } + + if (c->type != RCD_END) + rcd->nmap++; + + lex_match (','); + if (token == '=') + break; + } + return 1; +} + +/* Data transformation. */ + +static void +recode_trns_free (struct trns_header * t) +{ + int i; + struct rcd_var *head, *next; + + head = ((struct recode_trns *) t)->codings; + while (head) + { + if (head->map && !(head->flags & RCD_MISC_DUPLICATE)) + { + if (head->flags & RCD_SRC_STRING) + for (i = 0; i < head->nmap; i++) + switch (head->map[i].type) + { + case RCD_RANGE: + free (head->map[i].f2.c); + /* fall through */ + case RCD_USER: + case RCD_SINGLE: + case RCD_HIGH: + case RCD_LOW: + free (head->map[i].f1.c); + break; + case RCD_END: + case RCD_ELSE: + case RCD_CONVERT: + break; + default: + assert (0); + } + if (head->flags & RCD_DEST_STRING) + for (i = 0; i < head->nmap; i++) + if (head->map[i].type != RCD_CONVERT && head->map[i].type != RCD_END) + free (head->map[i].t.c); + free (head->map); + } + next = head->next; + free (head); + head = next; + } +} + +static inline struct coding * +find_src_numeric (struct rcd_var * v, struct ccase * c) +{ + double cmp = c->data[v->src->fv].f; + struct coding *cp; + + if (cmp == SYSMIS) + { + if (v->sysmis.f != -SYSMIS) + { + if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + c->data[v->dest->fv].f = v->sysmis.f; + else + memcpy (c->data[v->dest->fv].s, v->sysmis.c, + v->dest->width); + } + return NULL; + } + + for (cp = v->map;; cp++) + switch (cp->type) + { + case RCD_END: + return NULL; + case RCD_USER: + if (is_num_user_missing (cmp, v->src)) + return cp; + break; + case RCD_SINGLE: + if (approx_eq (cmp, cp->f1.f)) + return cp; + break; + case RCD_HIGH: + if (approx_ge (cmp, cp->f1.f)) + return cp; + break; + case RCD_LOW: + if (approx_le (cmp, cp->f1.f)) + return cp; + break; + case RCD_RANGE: + if (approx_in_range (cmp, cp->f1.f, cp->f2.f)) + return cp; + break; + case RCD_ELSE: + return cp; + default: + assert (0); + } +} + +static inline struct coding * +find_src_string (struct rcd_var * v, struct ccase * c) +{ + char *cmp = c->data[v->src->fv].s; + int w = v->src->width; + struct coding *cp; + + for (cp = v->map;; cp++) + switch (cp->type) + { + case RCD_END: + return NULL; + case RCD_SINGLE: + if (!memcmp (cp->f1.c, cmp, w)) + return cp; + break; + case RCD_ELSE: + return cp; + case RCD_CONVERT: + { + double f = convert_to_double (cmp, w); + if (f != -SYSMIS) + { + c->data[v->dest->fv].f = f; + return NULL; + } + break; + } + default: + assert (0); + } +} + +static int +recode_trns_proc (struct trns_header * t, struct ccase * c) +{ + struct rcd_var *v; + struct coding *cp; + + for (v = ((struct recode_trns *) t)->codings; v; v = v->next) + { + switch (v->flags & RCD_SRC_MASK) + { + case RCD_SRC_NUMERIC: + cp = find_src_numeric (v, c); + break; + case RCD_SRC_STRING: + cp = find_src_string (v, c); + break; + } + if (!cp) + continue; + + /* A matching input value was found. */ + if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + { + double val = cp->t.f; + if (val == -SYSMIS) + c->data[v->dest->fv].f = c->data[v->src->fv].f; + else + c->data[v->dest->fv].f = val; + } + else + { + char *val = cp->t.c; + if (val == NULL) + st_bare_pad_len_copy (c->data[v->dest->fv].s, + c->data[v->src->fv].c, + v->dest->width, v->src->width); + else + memcpy (c->data[v->dest->fv].s, cp->t.c, v->dest->width); + } + } + + return -1; +} + +/* Debug output. */ + +#if DEBUGGING +static void +dump_dest (struct rcd_var * v, union value * c) +{ + if ((v->flags & RCD_DEST_MASK) == RCD_DEST_NUMERIC) + if (c->f == SYSMIS) + printf ("=SYSMIS"); + else if (c->f == -SYSMIS) + printf ("=COPY"); + else + printf ("=%g", c->f); + else if (c->c) + printf ("=\"%s\"", c->c); + else + printf ("=COPY"); +} + +static void +debug_print (struct rcd_var * head) +{ + struct rcd_var *iter, *start; + struct coding *c; + + printf ("RECODE\n"); + for (iter = head; iter; iter = iter->next) + { + start = iter; + printf (" %s%s", iter == head ? "" : "/", iter->src->name); + while (iter->next && (iter->next->flags & RCD_MISC_DUPLICATE)) + { + iter = iter->next; + printf (" %s", iter->src->name); + } + if (iter->has_sysmis) + { + printf ("(SYSMIS"); + dump_dest (iter, &iter->sysmis); + printf (")"); + } + for (c = iter->map; c->type != RCD_END; c++) + { + printf ("("); + if ((iter->flags & RCD_SRC_MASK) == RCD_SRC_NUMERIC) + switch (c->type) + { + case RCD_END: + printf (_("!!END!!")); + break; + case RCD_USER: + printf ("MISSING"); + break; + case RCD_SINGLE: + printf ("%g", c->f1.f); + break; + case RCD_HIGH: + printf ("%g THRU HIGH", c->f1.f); + break; + case RCD_LOW: + printf ("LOW THRU %g", c->f1.f); + break; + case RCD_RANGE: + printf ("%g THRU %g", c->f1.f, c->f2.f); + break; + case RCD_ELSE: + printf ("ELSE"); + break; + default: + printf (_("!!ERROR!!")); + break; + } + else + switch (c->type) + { + case RCD_SINGLE: + printf ("\"%s\"", c->f1.c); + break; + case RCD_ELSE: + printf ("ELSE"); + break; + case RCD_CONVERT: + printf ("CONVERT"); + break; + default: + printf (_("!!ERROR!!")); + break; + } + if (c->type != RCD_CONVERT) + dump_dest (iter, &c->t); + printf (")"); + } + printf ("\n INTO"); + for (;;) + { + printf (" %s", + start->dest_name[0] ? start->dest_name : start->dest->name); + if (start == iter) + break; + start = start->next; + } + printf ("\n"); + } +} +#endif + +/* Convert NPTR to a `long int' in base 10. Returns the long int on + success, NOT_LONG on failure. On success stores a pointer to the + first character after the number into *ENDPTR. From the GNU C + library. */ +long int +string_to_long (char *nptr, int width, char **endptr) +{ + int negative; + register unsigned long int cutoff; + register unsigned int cutlim; + register unsigned long int i; + register char *s; + register unsigned char c; + const char *save; + + s = nptr; + + /* Check for a sign. */ + if (*s == '-') + { + negative = 1; + ++s; + } + else if (*s == '+') + { + negative = 0; + ++s; + } + else + negative = 0; + if (s >= nptr + width) + return NOT_LONG; + + /* Save the pointer so we can check later if anything happened. */ + save = s; + + cutoff = ULONG_MAX / 10ul; + cutlim = ULONG_MAX % 10ul; + + i = 0; + for (c = *s;;) + { + if (isdigit ((unsigned char) c)) + c -= '0'; + else + break; + /* Check for overflow. */ + if (i > cutoff || (i == cutoff && c > cutlim)) + return NOT_LONG; + else + i = i * 10ul + c; + + s++; + if (s >= nptr + width) + break; + c = *s; + } + + /* Check if anything actually happened. */ + if (s == save) + return NOT_LONG; + + /* Check for a value that is within the range of `unsigned long + int', but outside the range of `long int'. We limit LONG_MIN and + LONG_MAX by one point because we know that NOT_LONG is out there + somewhere. */ + if (i > (negative + ? -((unsigned long int) LONG_MIN) - 1 + : ((unsigned long int) LONG_MAX) - 1)) + return NOT_LONG; + + *endptr = s; + + /* Return the result of the appropriate sign. */ + return (negative ? -i : i); +} + +/* Converts S to a double according to format Fx.0. Returns the value + found, or -SYSMIS if there was no valid number in s. WIDTH is the + length of string S. From the GNU C library. */ +static double +convert_to_double (char *s, int width) +{ + register const char *end = &s[width]; + + short int sign; + + /* The number so far. */ + double num; + + int got_dot; /* Found a decimal point. */ + int got_digit; /* Count of digits. */ + + /* The exponent of the number. */ + long int exponent; + + /* Eat whitespace. */ + while (s < end && isspace ((unsigned char) *s)) + ++s; + if (s >= end) + return SYSMIS; + + /* Get the sign. */ + sign = *s == '-' ? -1 : 1; + if (*s == '-' || *s == '+') + { + ++s; + if (s >= end) + return -SYSMIS; + } + + num = 0.0; + got_dot = 0; + got_digit = 0; + exponent = 0; + for (; s < end; ++s) + { + if (isdigit ((unsigned char) *s)) + { + got_digit++; + + /* Make sure that multiplication by 10 will not overflow. */ + if (num > DBL_MAX * 0.1) + /* The value of the digit doesn't matter, since we have already + gotten as many digits as can be represented in a `double'. + This doesn't necessarily mean the result will overflow. + The exponent may reduce it to within range. + + We just need to record that there was another + digit so that we can multiply by 10 later. */ + ++exponent; + else + num = (num * 10.0) + (*s - '0'); + + /* Keep track of the number of digits after the decimal point. + If we just divided by 10 here, we would lose precision. */ + if (got_dot) + --exponent; + } + else if (!got_dot && *s == '.') + /* Record that we have found the decimal point. */ + got_dot = 1; + else + break; + } + + if (!got_digit) + return -SYSMIS; + + if (s < end && (tolower ((unsigned char) (*s)) == 'e' + || tolower ((unsigned char) (*s)) == 'd')) + { + /* Get the exponent specified after the `e' or `E'. */ + long int exp; + + s++; + if (s >= end) + return -SYSMIS; + + exp = string_to_long (s, end - s, &s); + if (exp == NOT_LONG || end == s) + return -SYSMIS; + exponent += exp; + } + + while (s < end && isspace ((unsigned char) *s)) + s++; + if (s < end) + return -SYSMIS; + + if (num == 0.0) + return 0.0; + + /* Multiply NUM by 10 to the EXPONENT power, + checking for overflow and underflow. */ + + if (exponent < 0) + { + if (-exponent + got_digit > -(DBL_MIN_10_EXP) + 5 + || num < DBL_MIN * pow (10.0, (double) -exponent)) + return -SYSMIS; + num *= pow (10.0, (double) exponent); + } + else if (exponent > 0) + { + if (num > DBL_MAX * pow (10.0, (double) -exponent)) + return -SYSMIS; + num *= pow (10.0, (double) exponent); + } + + return sign > 0 ? num : -num; +} diff --git a/src/rename-vars.c b/src/rename-vars.c new file mode 100644 index 00000000..fb214785 --- /dev/null +++ b/src/rename-vars.c @@ -0,0 +1,154 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +/* FIXME: should change weighting variable, etc. */ +static int compare_name (const void *, const void *); + +/* The code for this function is very similar to the code for the + RENAME subcommand of MODIFY VARS. */ +int +cmd_rename_variables (void) +{ + char (*names)[8] = NULL; + + struct variable **old_names = NULL; + char **new_names = NULL; + int n_rename = 0; + + struct variable *head, *tail, *iter; + + int i; + + lex_match_id ("RENAME"); + lex_match_id ("VARIABLES"); + + do + { + int prev_nv_1 = n_rename; + int prev_nv_2 = n_rename; + + if (!lex_match ('(')) + { + msg (SE, _("`(' expected.")); + goto lossage; + } + if (!parse_variables (&default_dict, &old_names, &n_rename, + PV_APPEND | PV_NO_DUPLICATE)) + goto lossage; + if (!lex_match ('=')) + { + msg (SE, _("`=' expected between lists of new and old variable names.")); + goto lossage; + } + if (!parse_DATA_LIST_vars (&new_names, &prev_nv_1, PV_APPEND)) + goto lossage; + if (prev_nv_1 != n_rename) + { + msg (SE, _("Differing number of variables in old name list " + "(%d) and in new name list (%d)."), + n_rename - prev_nv_2, prev_nv_1 - prev_nv_2); + for (i = 0; i < prev_nv_1; i++) + free (new_names[i]); + free (new_names); + new_names = NULL; + goto lossage; + } + if (!lex_match (')')) + { + msg (SE, _("`)' expected after variable names.")); + goto lossage; + } + } + while (token != '.'); + + /* Form a linked list of the variables to be renamed; also, set + their p.mfv.new_name members. */ + head = NULL; + for (i = 0; i < n_rename; i++) + { + strcpy (old_names[i]->p.mfv.new_name, new_names[i]); + free (new_names[i]); + if (head != NULL) + tail = tail->p.mfv.next = old_names[i]; + else + head = tail = old_names[i]; + } + tail->p.mfv.next = NULL; + free (new_names); + free (old_names); + new_names = NULL; + old_names = NULL; + + /* Construct a vector of all variables' new names. */ + names = xmalloc (8 * default_dict.nvar); + for (i = 0; i < default_dict.nvar; i++) + strncpy (names[i], default_dict.var[i]->name, 8); + for (iter = head; iter; iter = iter->p.mfv.next) + strncpy (names[iter->index], iter->p.mfv.new_name, 8); + + /* Sort the vector, then check for duplicates. */ + qsort (names, default_dict.nvar, 8, compare_name); + for (i = 1; i < default_dict.nvar; i++) + if (memcmp (names[i], names[i - 1], 8) == 0) + { + char name[9]; + strncpy (name, names[i], 8); + name[8] = 0; + msg (SE, _("Duplicate variable name `%s' after renaming."), name); + goto lossage; + } + free (names); + + /* Finally, do the renaming. */ + for (iter = head; iter; iter = iter->p.mfv.next) + avl_force_delete (default_dict.var_by_name, iter); + for (iter = head; iter; iter = iter->p.mfv.next) + { + strcpy (iter->name, iter->p.mfv.new_name); + avl_force_insert (default_dict.var_by_name, iter); + } + + return CMD_SUCCESS; + +lossage: + if (new_names) + for (i = 0; i < n_rename; i++) + free (new_names[i]); + free (new_names); + free (old_names); + free (names); + return CMD_FAILURE; +} + +static int +compare_name (const void *a, const void *b) +{ + return memcmp (a, b, 8); +} diff --git a/src/repeat.c b/src/repeat.c new file mode 100644 index 00000000..8b66a712 --- /dev/null +++ b/src/repeat.c @@ -0,0 +1,650 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "cases.h" +#include "command.h" +#include "error.h" +#include "getline.h" +#include "lexer.h" +#include "misc.h" +#include "settings.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Describes one DO REPEAT macro. */ +struct repeat_entry + { + int type; /* 1=variable names, 0=any other. */ + char id[9]; /* Macro identifier. */ + char **replacement; /* Macro replacement. */ + struct repeat_entry *next; + }; + +/* List of macro identifiers. */ +static struct repeat_entry *repeat_tab; + +/* Number of substitutions for each macro. */ +static int count; + +/* List of lines before it's actually assigned to a file. */ +static struct getl_line_list *line_buf_head; +static struct getl_line_list *line_buf_tail; + +static int parse_ids (struct repeat_entry *); +static int parse_numbers (struct repeat_entry *); +static int parse_strings (struct repeat_entry *); +static void clean_up (void); +static int internal_cmd_do_repeat (void); + +#if DEBUGGING +static void debug_print (void); +static void debug_print_lines (void); +#endif + +int +cmd_do_repeat (void) +{ + if (internal_cmd_do_repeat ()) + return CMD_SUCCESS; + + clean_up (); + return CMD_FAILURE; +} + +/* Garbage collects all the allocated memory that's no longer + needed. */ +static void +clean_up (void) +{ + struct repeat_entry *iter, *next; + int i; + + iter = repeat_tab; + repeat_tab = NULL; + + while (iter) + { + if (iter->replacement) + { + for (i = 0; i < count; i++) + free (iter->replacement[i]); + free (iter->replacement); + } + next = iter->next; + free (iter); + iter = next; + } +} + +/* Allocates & appends another record at the end of the line_buf_tail + chain. */ +static inline void +append_record (void) +{ + struct getl_line_list *new = xmalloc (sizeof *new); + + if (line_buf_head == NULL) + line_buf_head = line_buf_tail = new; + else + line_buf_tail = line_buf_tail->next = new; +} + +/* Returns nonzero if KEYWORD appears beginning at CONTEXT. */ +static int +recognize_keyword (const char *context, const char *keyword) +{ + const char *end = context; + while (isalpha ((unsigned char) *end)) + end++; + return lex_id_match_len (keyword, strlen (keyword), context, end - context); +} + +/* Does the real work of parsing the DO REPEAT command and its nested + commands. */ +static int +internal_cmd_do_repeat (void) +{ + /* Name of first DO REPEAT macro. */ + char first_name[9]; + + /* Current filename. */ + const char *current_filename = NULL; + + /* 1=Print lines after preprocessing. */ + int print; + + /* The first step is parsing the DO REPEAT command itself. */ + lex_match_id ("DO"); + lex_match_id ("REPEAT"); + + count = 0; + line_buf_head = NULL; + do + { + struct repeat_entry *e; + struct repeat_entry *iter; + int result; + + /* Get a stand-in variable name and make sure it's unique. */ + if (!lex_force_id ()) + return 0; + for (iter = repeat_tab; iter; iter = iter->next) + if (!strcmp (iter->id, tokid)) + { + msg (SE, _("Identifier %s is given twice."), tokid); + return 0; + } + + /* Make a new stand-in variable entry and link it into the + list. */ + e = xmalloc (sizeof *e); + e->type = 0; + e->next = repeat_tab; + strcpy (e->id, tokid); + repeat_tab = e; + + /* Skip equals sign. */ + lex_get (); + if (!lex_force_match ('=')) + return 0; + + /* Get the details of the variable's possible values. */ + + if (token == T_ID) + result = parse_ids (e); + else if (token == T_NUM) + result = parse_numbers (e); + else if (token == T_STRING) + result = parse_strings (e); + else + { + lex_error (NULL); + return 0; + } + if (!result) + return 0; + + /* If this is the first variable then it defines how many + replacements there must be; otherwise enforce this number of + replacements. */ + if (!count) + { + count = result; + strcpy (first_name, e->id); + } + else if (count != result) + { + msg (SE, _("There must be the same number of substitutions " + "for each dummy variable specified. Since there " + "were %d substitutions for %s, there must be %d " + "for %s as well, but %d were specified."), + count, first_name, count, e->id, result); + return 0; + } + + /* Next! */ + lex_match ('/'); + } + while (token != '.'); + +#if DEBUGGING + debug_print (); +#endif + + /* Read all the lines inside the DO REPEAT ... END REPEAT. */ + { + int nest = 1; + + for (;;) + { + if (!getl_read_line ()) + msg (FE, _("Unexpected end of file.")); + + /* If the current file has changed then record the fact. */ + { + const char *curfn; + int curln; + + getl_location (&curfn, &curln); + if (current_filename != curfn) + { + assert (curln > 0 && curfn != NULL); + + append_record (); + line_buf_tail->len = -curln; + line_buf_tail->line = xstrdup (curfn); + current_filename = curfn; + } + } + + /* FIXME? This code is not strictly correct, however if you + have begun a line with DO REPEAT or END REPEAT and it's + *not* a command name, then you are obviously *trying* to + break this mechanism. And you will. Also, the entire + command names must appear on a single line--they can't be + spread out. */ + { + char *cp = ds_value (&getl_buf); + + /* Skip leading indentors and any whitespace. */ + if (*cp == '+' || *cp == '-' || *cp == '.') + cp++; + while (isspace ((unsigned char) *cp)) + cp++; + + /* Find END REPEAT. */ + if (recognize_keyword (cp, "end")) + { + while (isalpha ((unsigned char) *cp)) + cp++; + while (isspace ((unsigned char) *cp)) + cp++; + if (recognize_keyword (cp, "repeat")) + { + nest--; + + if (!nest) + { + while (isalpha ((unsigned char) *cp)) + cp++; + while (isspace ((unsigned char) *cp)) + cp++; + + print = recognize_keyword (cp, "print"); + break; + } + } + } + else /* Find DO REPEAT. */ + if (!strncasecmp (cp, "do", 2)) + { + cp += 2; + while (isspace ((unsigned char) *cp)) + cp++; + if (!strncasecmp (cp, "rep", 3)) + nest++; + } + } + + append_record (); + line_buf_tail->len = ds_length (&getl_buf); + line_buf_tail->line = xmalloc (ds_length (&getl_buf) + 1); + memcpy (line_buf_tail->line, + ds_value (&getl_buf), ds_length (&getl_buf) + 1); + } + } + + /* FIXME: For the moment we simply discard the contents of the END + REPEAT line. We should actually check for the PRINT specifier. + This can be done easier when we buffer entire commands instead of + doing it token by token; see TODO. */ + lex_entire_line (); + + /* Tie up the loose end of the chain. */ + if (line_buf_head == NULL) + { + msg (SW, _("No commands in scope.")); + return 1; + } + line_buf_tail->next = NULL; + + /* Show the line list. */ +#if DEBUGGING + debug_print_lines (); +#endif + + /* Make new variables. */ + { + struct repeat_entry *iter; + for (iter = repeat_tab; iter; iter = iter->next) + if (iter->type == 1) + { + int i; + for (i = 0; i < count; i++) + { + /* Note that if the variable already exists there is no + harm done. */ + struct variable *v = create_variable (&default_dict, + iter->replacement[i], + NUMERIC, 0); + + /* If we created the variable then we need to initialize + its observations to SYSMIS. */ + if (v) + envector (v); + } + } + } + + /* Create the DO REPEAT virtual input file. */ + { + struct getl_script *script = xmalloc (sizeof *script); + + script->first_line = line_buf_head; + script->cur_line = NULL; + script->remaining_loops = count; + script->loop_index = -1; + script->macros = repeat_tab; + script->print = print; + + getl_add_DO_REPEAT_file (script); + } + + return 1; +} + +/* Parses a set of ids for DO REPEAT. */ +static int +parse_ids (struct repeat_entry * e) +{ + int i; + int n = 0; + + e->type = 1; + e->replacement = NULL; + + do + { + char **names; + int nnames; + + if (!parse_mixed_vars (&names, &nnames, PV_NONE)) + return 0; + + e->replacement = xrealloc (e->replacement, + (nnames + n) * sizeof *e->replacement); + for (i = 0; i < nnames; i++) + { + e->replacement[n + i] = xstrdup (names[i]); + free (names[i]); + } + free (names); + n += nnames; + } + while (token != '/' && token != '.'); + + return n; +} + +/* Stores VALUE into *REPL. */ +static inline void +store_numeric (char **repl, long value) +{ + *repl = xmalloc (INT_DIGITS + 1); + sprintf (*repl, "%ld", value); +} + +/* Parses a list of numbers for DO REPEAT. */ +static int +parse_numbers (struct repeat_entry *e) +{ + /* First and last numbers for TO, plus the step factor. */ + long a, b; + + /* Alias to e->replacement. */ + char **array; + + /* Number of entries in array; maximum number for this allocation + size. */ + int n, m; + + n = m = 0; + e->type = 0; + e->replacement = array = NULL; + + do + { + /* Parse A TO B into a, b. */ + if (!lex_force_int ()) + return 0; + a = lex_integer (); + + lex_get (); + if (token == T_TO) + { + lex_get (); + if (!lex_force_int ()) + return 0; + b = lex_integer (); + + lex_get (); + } + else b = a; + + if (n + (abs (b - a) + 1) > m) + { + m = n + (abs (b - a) + 1) + 16; + e->replacement = array = xrealloc (array, + m * sizeof *e->replacement); + } + + if (a == b) + store_numeric (&array[n++], a); + else + { + long iter; + + if (a < b) + for (iter = a; iter <= b; iter++) + store_numeric (&array[n++], iter); + else + for (iter = a; iter >= b; iter--) + store_numeric (&array[n++], iter); + } + + lex_match (','); + } + while (token != '/' && token != '.'); + e->replacement = xrealloc (array, n * sizeof *e->replacement); + + return n; +} + +/* Parses a list of strings for DO REPEAT. */ +int +parse_strings (struct repeat_entry * e) +{ + char **string; + int n, m; + + e->type = 0; + string = e->replacement = NULL; + n = m = 0; + + do + { + if (token != T_STRING) + { + int i; + msg (SE, _("String expected.")); + for (i = 0; i < n; i++) + free (string[i]); + free (string); + return 0; + } + + if (n + 1 > m) + { + m += 16; + e->replacement = string = xrealloc (string, + m * sizeof *e->replacement); + } + string[n++] = lex_token_representation (); + lex_get (); + + lex_match (','); + } + while (token != '/' && token != '.'); + e->replacement = xrealloc (string, n * sizeof *e->replacement); + + return n; +} + +int +cmd_end_repeat (void) +{ + msg (SE, _("No matching DO REPEAT.")); + return CMD_FAILURE; +} + +/* Finds a DO REPEAT macro with name MACRO_NAME and returns the + appropriate subsitution if found, or NULL if not. */ +char * +find_DO_REPEAT_substitution (char *macro_name) +{ + struct getl_script *s; + + for (s = getl_head; s; s = s->included_from) + { + struct repeat_entry *e; + + if (s->first_line == NULL) + continue; + + for (e = s->macros; e; e = e->next) + if (!strcasecmp (e->id, macro_name)) + return e->replacement[s->loop_index]; + } + + return NULL; +} + +/* Makes appropriate DO REPEAT macro substitutions within getl_buf. */ +void +perform_DO_REPEAT_substitutions (void) +{ + /* Are we in an apostrophized string or a quoted string? */ + int in_apos = 0, in_quote = 0; + + /* Source pointer. */ + char *cp; + + /* Output buffer, size, pointer. */ + struct string output; + + /* Terminal dot. */ + int dot = 0; + + ds_init (NULL, &output, ds_size (&getl_buf)); + + /* Strip trailing whitespace, check for & remove terminal dot. */ + while (ds_length (&getl_buf) > 0 + && isspace ((unsigned char) ds_end (&getl_buf)[-1])) + ds_truncate (&getl_buf, ds_length (&getl_buf) - 1); + if (ds_length (&getl_buf) > 0 && ds_end (&getl_buf)[-1] == set_endcmd) + { + dot = 1; + ds_truncate (&getl_buf, ds_length (&getl_buf) - 1); + } + + for (cp = ds_value (&getl_buf); cp < ds_end (&getl_buf); ) + { + if (*cp == '\'' && !in_quote) + in_apos ^= 1; + else if (*cp == '"' && !in_apos) + in_quote ^= 1; + + if (in_quote || in_apos || !CHAR_IS_ID1 (*cp)) + { + ds_putchar (&output, *cp++); + continue; + } + + /* Collect an identifier. */ + { + char name[9]; + char *start = cp; + char *np = name; + char *substitution; + + while (CHAR_IS_IDN (*cp) && np < &name[8]) + *np++ = *cp++; + while (CHAR_IS_IDN (*cp)) + cp++; + *np = 0; + + substitution = find_DO_REPEAT_substitution (name); + if (!substitution) + { + ds_concat_buffer (&output, start, cp - start); + continue; + } + + /* Force output buffer size, copy substitution. */ + ds_concat (&output, substitution); + } + } + if (dot) + ds_putchar (&output, (unsigned char) set_endcmd); + + ds_destroy (&getl_buf); + getl_buf = output; +} + +/* Debugging code. */ + +#if DEBUGGING +static void +debug_print (void) +{ + struct repeat_entry *iter; + int j; + + printf ("DO REPEAT\n"); + for (iter = repeat_tab; iter; iter = iter->next) + { + printf (" %s%s=", iter->id, iter->type ? "(ids)" : ""); + for (j = 0; j < count; j++) + printf ("%s ", iter->replacement[j]); + putc (iter->next ? '/' : '.', stdout); + printf ("\n"); + } +} + +static void +debug_print_lines (void) +{ + struct getl_line_list *iter; + const char *fn = "(none)"; + int ln = 65536; + + printf ("---begin DO REPEAT lines---\n"); + for (iter = line_buf_head; iter; iter = iter->next) + { + if (iter->len < 0) + { + ln = -iter->len; + fn = iter->line; + } else { + printf ("%s:%d: %s", fn, ln++, iter->line); + } + } + printf ("---end DO REPEAT lines---\n"); +} +#endif /* DEBUGGING */ diff --git a/src/sample.c b/src/sample.c new file mode 100644 index 00000000..84f2e899 --- /dev/null +++ b/src/sample.c @@ -0,0 +1,146 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "random.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* The two different types of samples. */ +enum + { + TYPE_A_FROM_B, /* 5 FROM 10 */ + TYPE_FRACTION /* 0.5 */ + }; + +/* SAMPLE transformation. */ +struct sample_trns + { + struct trns_header h; + int type; /* One of TYPE_*. */ + int n, N; /* TYPE_A_FROM_B: n from N. */ + int m, t; /* TYPE_A_FROM_B: # selected so far; # so far. */ + int frac; /* TYPE_FRACTION: a fraction out of 65536. */ + }; + +int sample_trns_proc (struct trns_header *, struct ccase *); + +int +cmd_sample (void) +{ + struct sample_trns *trns; + + int type; + int a, b; + int frac; + + lex_match_id ("SAMPLE"); + + if (!lex_force_num ()) + return CMD_FAILURE; + if (!lex_integer_p ()) + { + type = TYPE_FRACTION; + if (tokval <= 0 || tokval >= 1) + { + msg (SE, _("The sampling factor must be between 0 and 1 " + "exclusive.")); + return CMD_FAILURE; + } + + frac = tokval * 65536; + a = b = 0; + } + else + { + type = TYPE_A_FROM_B; + a = lex_integer (); + lex_get (); + if (!lex_force_match_id ("FROM")) + return CMD_FAILURE; + if (!lex_force_int ()) + return CMD_FAILURE; + b = lex_integer (); + if (a >= b) + { + msg (SE, _("Cannot sample %d observations from a population of " + "%d."), + a, b); + return CMD_FAILURE; + } + + frac = 0; + } + lex_get (); + +#if DEBUGGING + if (type == TYPE_FRACTION) + printf ("SAMPLE %g.\n", frac / 65536.); + else + printf ("SAMPLE %d FROM %d.\n", a, b); +#endif + + trns = xmalloc (sizeof *trns); + trns->h.proc = sample_trns_proc; + trns->h.free = NULL; + trns->type = type; + trns->n = a; + trns->N = b; + trns->m = trns->t = 0; + trns->frac = frac; + add_transformation ((struct trns_header *) trns); + + return lex_end_of_command (); +} + +int +sample_trns_proc (struct trns_header * trns, struct ccase *c unused) +{ + struct sample_trns *t = (struct sample_trns *) trns; + double U; + + if (t->type == TYPE_FRACTION) + return (rand_simple (0x10000) <= t->frac) - 2; + + if (t->m >= t->n) + return -2; + + U = rand_uniform (1); + if ((t->N - t->t) * U >= t->n - t->m) + { + t->t++; + return -2; + } + else + { + t->m++; + t->t++; + return -1; + } +} diff --git a/src/sel-if.c b/src/sel-if.c new file mode 100644 index 00000000..f4afd9c6 --- /dev/null +++ b/src/sel-if.c @@ -0,0 +1,148 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "expr.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +/* SELECT IF transformation. */ +struct select_if_trns + { + struct trns_header h; + struct expression *e; /* Test expression. */ + }; + +static int select_if_proc (struct trns_header *, struct ccase *); +static void select_if_free (struct trns_header *); + +/* Parses the SELECT IF transformation. */ +int +cmd_select_if (void) +{ + struct expression *e; + struct select_if_trns *t; + + lex_match_id ("SELECT"); + lex_match_id ("IF"); + + e = expr_parse (PXP_BOOLEAN); + if (!e) + return CMD_FAILURE; + + if (token != '.') + { + expr_free (e); + lex_error (_("expecting end of command")); + return CMD_FAILURE; + } + + t = xmalloc (sizeof *t); + t->h.proc = select_if_proc; + t->h.free = select_if_free; + t->e = e; + add_transformation ((struct trns_header *) t); + + return CMD_SUCCESS; +} + +/* Performs the SELECT IF transformation T on case C. */ +static int +select_if_proc (struct trns_header * t, struct ccase * c) +{ + return (expr_evaluate (((struct select_if_trns *) t)->e, c, NULL) == 1.0) - 2; +} + +/* Frees SELECT IF transformation T. */ +static void +select_if_free (struct trns_header * t) +{ + expr_free (((struct select_if_trns *) t)->e); +} + +/* Parses the FILTER command. */ +int +cmd_filter (void) +{ + lex_match_id ("FILTER"); + + if (lex_match_id ("OFF")) + default_dict.filter_var[0] = 0; + else + { + struct variable *v; + + lex_match (T_BY); + v = parse_variable (); + if (!v) + return CMD_FAILURE; + + if (v->type == ALPHA) + { + msg (SE, _("The filter variable must be numeric.")); + return CMD_FAILURE; + } + + if (v->name[0] == '#') + { + msg (SE, _("The filter variable may not be scratch.")); + return CMD_FAILURE; + } + + strcpy (default_dict.filter_var, v->name); + + FILTER_before_TEMPORARY = !temporary; + } + + return CMD_SUCCESS; +} + +/* Parses the PROCESS IF command. */ +int +cmd_process_if (void) +{ + struct expression *e; + + lex_match_id ("PROCESS"); + lex_match_id ("IF"); + + e = expr_parse (PXP_BOOLEAN); + if (!e) + return CMD_FAILURE; + + if (token != '.') + { + expr_free (e); + lex_error (_("expecting end of command")); + return CMD_FAILURE; + } + + if (process_if_expr) + { + msg (MW, _("Only last instance of this command is in effect.")); + expr_free (process_if_expr); + } + process_if_expr = e; + + return CMD_SUCCESS; +} diff --git a/src/set.q b/src/set.q new file mode 100644 index 00000000..8683bff7 --- /dev/null +++ b/src/set.q @@ -0,0 +1,882 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* + Categories of SET subcommands: + + data input: BLANKS, DECIMAL, FORMAT. + + program input: ENDCMD, NULLINE. + + interaction: CPROMPT, DPROMPT, ERRORBREAK, MXERRS, MXWARNS, PROMPT. + + program execution: MEXPAND, MITERATE, MNEST, MPRINT, + MXLOOPS, SEED, UNDEFINED. + + data output: CCA...CCE, DECIMAL, FORMAT, RESULTS-p. + + output routing: ECHO, ERRORS, INCLUDE, MESSAGES, PRINTBACK, ERRORS, + RESULTS-rw. + + output activation: LISTING (on/off), SCREEN, PRINTER. + + output driver options: HEADERS, MORE, PAGER, VIEWLENGTH, VIEWWIDTH, + LISTING (filename). + + logging: LOG, JOURNAL. + + system files: COMP/COMPRESSION, SCOMP/SCOMPRESSION. + + security: SAFER. +*/ + +/* + FIXME + + These subcommands remain to be implemented: + ECHO, PRINTBACK, INCLUDE + MORE, PAGER, VIEWLENGTH, VIEWWIDTH, HEADERS + + These subcommands are not complete: + MESSAGES, ERRORS, RESULTS + LISTING/DISK, LOG/JOURNAL +*/ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "magic.h" +#include "log.h" +#include "output.h" +#include "var.h" +#include "format.h" +#include "settings.h" + +double set_blanks; +int set_compression; +struct set_cust_currency set_cc[5]; +int set_cpi; +char *set_cprompt; +int set_decimal; +int set_grouping; +char *set_dprompt; +int set_echo; +int set_endcmd; +int set_errorbreak; +int set_errors, set_messages, set_results; +struct fmt_spec set_format; +int set_headers; +int set_include; +char *set_journal; +int set_journaling; +int set_lpi; +int set_messages; +int set_mexpand; +int set_miterate; +int set_mnest; +int set_more; +int set_mprint; +int set_mxerrs; +int set_mxloops; +int set_mxwarns; +int set_nullline; +int set_printback; +int set_output = 1; +#if !USE_INTERNAL_PAGER +char *set_pager; +#endif /* !USE_INTERNAL_PAGER */ +int set_printer; +char *set_prompt; +char *set_results_file; +int set_safer; +int set_scompression; +int set_screen; +long set_seed; +int set_seed_used; +int set_testing_mode; +int set_undefined; +int set_viewlength; +int set_viewwidth; + +static void set_routing (int q, int *setting); +static int set_ccx (const char *cc_string, struct set_cust_currency * cc, + int cc_name); + +/* (specification) + "SET" (stc_): + automenu=automenu:on/off; + beep=beep:on/off; + blanks=custom; + block=string "x==1" "one character long"; + boxstring=string "x==3 || x==11" "3 or 11 characters long"; + case=size:upper/uplow; + cca=string; + ccb=string; + ccc=string; + ccd=string; + cce=string; + color=custom; + compression=compress:on/off; + cpi=integer; + cprompt=string; + decimal=dec:dot/_comma; + disk=custom; + dprompt=string; + echo=echo:on/off; + eject=eject:on/off; + endcmd=string "x==1" "one character long"; + errorbreak=errbrk:on/off; + errors=errors:on/off/terminal/listing/both/none; + format=custom; + headers=headers:no/yes/blank; + helpwindows=helpwin:on/off; + highres=hires:on/off; + histogram=string "x==1" "one character long"; + include=inc:on/off; + journal=custom; + length=custom; + listing=custom; + log=custom; + lowres=lores:auto/on/off; + lpi=integer; + menus=menus:standard/extended; + messages=messages:on/off/terminal/listing/both/none; + mexpand=mexp:on/off; + miterate=integer; + mnest=integer; + more=more:on/off; + mprint=mprint:on/off; + mxerrs=integer; + mxloops=integer; + mxmemory=integer; + mxwarns=integer; + nulline=null:on/off; + pager=custom; + printback=prtbck:on/off; + printer=prtr:on/off; + prompt=string; + ptranslate=ptrans:on/off; + rcolor=custom; + results=custom; + runreview=runrev:auto/manual; + safer=safe:on; + scompression=scompress:on/off; + screen=scrn:on/off; + scripttab=string "x==1" "one character long"; + seed=custom; + tb1=string "x==3 || x==11" "3 or 11 characters long"; + tbfonts=string; + undefined=undef:warn/nowarn; + viewlength=custom; + viewwidth=integer; + width=custom; + workdev=custom; + workspace=integer; + xsort=xsort:yes/no. +*/ + +/* (declarations) */ +/* (functions) */ + +int internal_cmd_set (void); + +int +cmd_set (void) +{ + struct cmd_set cmd; + + lex_match_id ("SET"); + + if (!parse_set (&cmd)) + return CMD_FAILURE; + + if (cmd.sbc_block) + msg (SW, _("BLOCK is obsolete.")); + + if (cmd.sbc_boxstring) + msg (SW, _("BOXSTRING is obsolete.")); + + if (cmd.compress != -1) + { + msg (MW, _("Active file compression is not yet implemented " + "(and probably won't be).")); + set_compression = cmd.compress == STC_OFF ? 0 : 1; + } + if (cmd.scompress != -1) + set_scompression = cmd.scompress == STC_OFF ? 0 : 1; + if (cmd.n_cpi != NOT_LONG) + { + if (cmd.n_cpi <= 0) + msg (SE, _("CPI must be greater than 0.")); + else + set_cpi = cmd.n_cpi; + } + if (cmd.sbc_histogram) + msg (MW, _("HISTOGRAM is obsolete.")); + if (cmd.n_lpi != NOT_LONG) + { + if (cmd.n_lpi <= 0) + msg (SE, _("LPI must be greater than 0.")); + else + set_lpi = cmd.n_lpi; + } + + /* Windows compatible syntax. */ + if (cmd.sbc_case) + msg (SW, _("CASE is not implemented and probably won't be. If you care, " + "complain about it.")); + if (cmd.sbc_cca) + set_ccx (cmd.s_cca, &set_cc[0], 'A'); + if (cmd.sbc_ccb) + set_ccx (cmd.s_ccb, &set_cc[1], 'B'); + if (cmd.sbc_ccc) + set_ccx (cmd.s_ccc, &set_cc[2], 'C'); + if (cmd.sbc_ccd) + set_ccx (cmd.s_ccd, &set_cc[3], 'D'); + if (cmd.sbc_cce) + set_ccx (cmd.s_cce, &set_cc[4], 'E'); + if (cmd.dec != -1) + { + set_decimal = cmd.dec == STC_DOT ? '.' : ','; + set_grouping = cmd.dec == STC_DOT ? ',' : '.'; + } + if (cmd.errors != -1) + set_routing (cmd.errors, &set_errors); + if (cmd.headers != -1) + set_headers = cmd.headers == STC_NO ? 0 : (cmd.headers == STC_YES ? 1 : 2); + if (cmd.messages != -1) + set_routing (cmd.messages, &set_messages); + if (cmd.mexp != -1) + set_mexpand = cmd.mexp == STC_OFF ? 0 : 1; + if (cmd.n_miterate != NOT_LONG) + { + if (cmd.n_miterate > 0) + set_miterate = cmd.n_miterate; + else + msg (SE, _("Value for MITERATE (%ld) must be greater than 0."), + cmd.n_miterate); + } + if (cmd.n_mnest != NOT_LONG) + { + if (cmd.n_mnest > 0) + set_mnest = cmd.n_mnest; + else + msg (SE, _("Value for MNEST (%ld) must be greater than 0."), + cmd.n_mnest); + } + if (cmd.mprint != -1) + set_mprint = cmd.mprint == STC_OFF ? 0 : 1; + if (cmd.n_mxerrs != NOT_LONG) + { + if (set_mxerrs < 1) + msg (SE, _("MXERRS must be at least 1.")); + else + set_mxerrs = cmd.n_mxerrs; + } + if (cmd.n_mxloops != NOT_LONG) + { + if (set_mxloops < 1) + msg (SE, _("MXLOOPS must be at least 1.")); + else + set_mxloops = cmd.n_mxloops; + } + if (cmd.n_mxmemory != NOT_LONG) + msg (SE, _("MXMEMORY is obsolete.")); + if (cmd.n_mxwarns != NOT_LONG) + set_mxwarns = cmd.n_mxwarns; + if (cmd.prtbck != -1) + set_printback = cmd.prtbck == STC_OFF ? 0 : 1; + if (cmd.s_scripttab) + msg (SE, _("SCRIPTTAB is obsolete.")); + if (cmd.s_tbfonts) + msg (SW, _("TBFONTS not implemented.")); + if (cmd.s_tb1) + msg (SW, _("TB1 not implemented.")); + if (cmd.undef != -1) + set_undefined = cmd.undef == STC_NOWARN ? 0 : 1; + if (cmd.n_workspace != NOT_LONG) + msg (SE, _("WORKSPACE is obsolete.")); + + /* PC+ compatible syntax. */ + if (cmd.scrn != -1) + outp_enable_device (cmd.scrn == STC_OFF ? 0 : 1, OUTP_DEV_SCREEN); + + if (cmd.automenu != -1) + msg (SW, _("AUTOMENU is obsolete.")); + if (cmd.beep != -1) + msg (SW, _("BEEP is obsolete.")); + + if (cmd.s_cprompt) + { + free (set_cprompt); + set_cprompt = cmd.s_cprompt; + cmd.s_cprompt = NULL; + } + if (cmd.s_dprompt) + { + free (set_dprompt); + set_dprompt = cmd.s_dprompt; + cmd.s_dprompt = NULL; + } + if (cmd.echo != -1) + set_echo = cmd.echo == STC_OFF ? 0 : 1; + if (cmd.s_endcmd) + set_endcmd = cmd.s_endcmd[0]; + if (cmd.eject != -1) + msg (SW, _("EJECT is obsolete.")); + if (cmd.errbrk != -1) + set_errorbreak = cmd.errbrk == STC_OFF ? 0 : 1; + if (cmd.helpwin != -1) + msg (SW, _("HELPWINDOWS is obsolete.")); + if (cmd.inc != -1) + set_include = cmd.inc == STC_OFF ? 0 : 1; + if (cmd.menus != -1) + msg (MW, _("MENUS is obsolete.")); + if (cmd.null != -1) + set_nullline = cmd.null == STC_OFF ? 0 : 1; + if (cmd.more != -1) + set_more = cmd.more == STC_OFF ? 0 : 1; + if (cmd.prtr != -1) + outp_enable_device (cmd.prtr == STC_OFF ? 0 : 1, OUTP_DEV_PRINTER); + if (cmd.s_prompt) + { + free (set_prompt); + set_prompt = cmd.s_prompt; + cmd.s_prompt = NULL; + } + if (cmd.ptrans != -1) + msg (SW, _("PTRANSLATE is obsolete.")); + if (cmd.runrev != -1) + msg (SW, "RUNREVIEW is obsolete."); + if (cmd.safe == STC_ON) + set_safer = 1; + if (cmd.xsort != -1) + msg (SW, _("XSORT is obsolete.")); + + free_set (&cmd); + + return CMD_SUCCESS; +} + +/* Sets custom currency specifier CC having name CC_NAME ('A' through + 'E') to correspond to the settings in CC_STRING. */ +static int +set_ccx (const char *cc_string, struct set_cust_currency * cc, int cc_name) +{ + if (strlen (cc_string) > 16) + { + msg (SE, _("CC%c: Length of custom currency string `%s' (%d) " + "exceeds maximum length of 16."), + cc_name, cc_string, strlen (cc_string)); + return 0; + } + + /* Determine separators. */ + { + const char *sp; + int n_commas, n_periods; + + /* Count the number of commas and periods. There must be exactly + three of one or the other. */ + n_commas = n_periods = 0; + for (sp = cc_string; *sp; sp++) + if (*sp == ',') + n_commas++; + else if (*sp == '.') + n_periods++; + + if (!((n_commas == 3) ^ (n_periods == 3))) + { + msg (SE, _("CC%c: Custom currency string `%s' does not contain " + "exactly three periods or commas (not both)."), + cc_name, cc_string); + return 0; + } + else if (n_commas == 3) + { + cc->decimal = '.'; + cc->grouping = ','; + } + else + { + cc->decimal = ','; + cc->grouping = '.'; + } + } + + /* Copy cc_string to cc, changing separators to nulls. */ + { + char *cp; + + strcpy (cc->buf, cc_string); + cp = cc->neg_prefix = cc->buf; + + while (*cp++ != cc->grouping) + ; + cp[-1] = '\0'; + cc->prefix = cp; + + while (*cp++ != cc->grouping) + ; + cp[-1] = '\0'; + cc->suffix = cp; + + while (*cp++ != cc->grouping) + ; + cp[-1] = '\0'; + cc->neg_suffix = cp; + } + + return 1; +} + +/* Sets *SETTING, which is a combination of SET_ROUTE_* bits that + indicates what to do with some sort of output, to the value + indicated by Q, which is a value provided by the input parser. */ +static void +set_routing (int q, int *setting) +{ + switch (q) + { + case STC_ON: + *setting |= SET_ROUTE_DISABLE; + break; + case STC_OFF: + *setting &= ~SET_ROUTE_DISABLE; + break; + case STC_TERMINAL: + *setting &= ~(SET_ROUTE_LISTING | SET_ROUTE_OTHER); + *setting |= SET_ROUTE_SCREEN; + break; + case STC_LISTING: + *setting &= ~SET_ROUTE_SCREEN; + *setting |= SET_ROUTE_LISTING | SET_ROUTE_OTHER; + break; + case STC_BOTH: + *setting |= SET_ROUTE_SCREEN | SET_ROUTE_LISTING | SET_ROUTE_OTHER; + break; + case STC_NONE: + *setting &= ~(SET_ROUTE_SCREEN | SET_ROUTE_LISTING | SET_ROUTE_OTHER); + break; + default: + assert (0); + } +} + +static int +stc_custom_pager (struct cmd_set *cmd unused) +{ + lex_match ('='); +#if !USE_INTERNAL_PAGER + if (lex_match_id ("OFF")) + { + if (set_pager) + free (set_pager); + set_pager = NULL; + } + else + { + if (!lex_force_string ()) + return 0; + if (set_pager) + free (set_pager); + set_pager = xstrdup (ds_value (&tokstr)); + lex_get (); + } + return 1; +#else /* USE_INTERNAL_PAGER */ + if (match_id (OFF)) + return 1; + msg (SW, "External pagers not supported."); + return 0; +#endif /* USE_INTERNAL_PAGER */ +} + +/* Parses the BLANKS subcommand, which controls the value that + completely blank fields in numeric data imply. X, Wnd: Syntax is + SYSMIS or a numeric value; PC+: Syntax is '.', which is equivalent + to SYSMIS, or a numeric value. */ +static int +stc_custom_blanks (struct cmd_set *cmd unused) +{ + lex_match ('='); + if ((token == T_ID && lex_id_match ("SYSMIS", tokid)) + || (token == T_STRING && !strcmp (tokid, "."))) + { + lex_get (); + set_blanks = SYSMIS; + } + else + { + if (!lex_force_num ()) + return 0; + set_blanks = tokval; + lex_get (); + } + return 1; +} + +static int +stc_custom_length (struct cmd_set *cmd unused) +{ + int page_length; + + lex_match ('='); + if (lex_match_id ("NONE")) + page_length = -1; + else + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 1) + { + msg (SE, _("LENGTH must be at least 1.")); + return 0; + } + page_length = lex_integer (); + lex_get (); + } + + /* FIXME: Set page length. */ + return 1; +} + +static int +stc_custom_results (struct cmd_set *cmd unused) +{ + struct tuple + { + const char *s; + int v; + }; + + static struct tuple tab[] = + { + {"ON", STC_ON}, + {"OFF", STC_OFF}, + {"TERMINAL", STC_TERMINAL}, + {"LISTING", STC_LISTING}, + {"BOTH", STC_BOTH}, + {"NONE", STC_NONE}, + {NULL, 0}, + }; + + struct tuple *t; + + lex_match ('='); + + if (token != T_ID) + { + msg (SE, _("Missing identifier in RESULTS subcommand.")); + return 0; + } + + for (t = tab; t->s; t++) + if (lex_id_match (t->s, tokid)) + { + lex_get (); + set_routing (t->v, &set_results); + return 1; + } + msg (SE, _("Unrecognized identifier in RESULTS subcommand.")); + return 0; +} + +static int +stc_custom_seed (struct cmd_set *cmd unused) +{ + lex_match ('='); + if (lex_match_id ("RANDOM")) + set_seed = NOT_LONG; + else + { + if (!lex_force_num ()) + return 0; + set_seed = tokval; + lex_get (); + } + return 1; +} + +static int +stc_custom_width (struct cmd_set *cmd unused) +{ + int page_width; + + lex_match ('='); + if (lex_match_id ("NARROW")) + page_width = 79; + else if (lex_match_id ("WIDE")) + page_width = 131; + else + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 1) + { + msg (SE, _("WIDTH must be at least 1.")); + return 0; + } + page_width = lex_integer (); + lex_get (); + } + + /* FIXME: Set page width. */ + return 1; +} + +/* Parses FORMAT subcommand, which consists of a numeric format + specifier. */ +static int +stc_custom_format (struct cmd_set *cmd unused) +{ + struct fmt_spec fmt; + + lex_match ('='); + if (!parse_format_specifier (&fmt, 0)) + return 0; + if ((formats[fmt.type].cat & FCAT_STRING) != 0) + { + msg (SE, _("FORMAT requires numeric output format as an argument. " + "Specified format %s is of type string."), + fmt_to_string (&fmt)); + return 0; + } + + set_format = fmt; + return 1; +} + +static int +stc_custom_journal (struct cmd_set *cmd unused) +{ + lex_match ('='); + if (lex_match_id ("ON")) + set_journaling = 1; + else if (lex_match_id ("OFF")) + set_journaling = 0; + if (token == T_STRING) + { + set_journal = xstrdup (ds_value (&tokstr)); + lex_get (); + } + return 1; +} + +/* Parses COLOR subcommand. PC+: either ON or OFF or two or three + comma-delimited numbers inside parentheses. */ +static int +stc_custom_color (struct cmd_set *cmd unused) +{ + msg (MW, "COLOR is obsolete."); + + lex_match ('='); + if (!lex_match_id ("ON") && !lex_match_id ("YES") && !lex_match_id ("OFF") && !lex_match_id ("NO")) + { + if (!lex_force_match ('(')) + return 0; + if (!lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 15) + { + msg (SE, _("Text color must be in range 0-15.")); + return 0; + } + lex_get (); + } + if (!lex_force_match (',')) + return 0; + if (!lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 7) + { + msg (SE, _("Background color must be in range 0-7.")); + return 0; + } + lex_get (); + } + if (lex_match (',') && !lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 7) + { + msg (SE, _("Border color must be in range 0-7.")); + return 0; + } + lex_get (); + } + if (!lex_force_match (')')) + return 0; + } + return 1; +} + +static int +stc_custom_listing (struct cmd_set *cmd unused) +{ + lex_match ('='); + if (lex_match_id ("ON") || lex_match_id ("YES")) + outp_enable_device (1, OUTP_DEV_LISTING); + else if (lex_match_id ("OFF") || lex_match_id ("NO")) + outp_enable_device (0, OUTP_DEV_LISTING); + else + { + /* FIXME */ + } + + return 0; +} + +static int +stc_custom_disk (struct cmd_set *cmd unused) +{ + stc_custom_listing (cmd); + return 0; +} + +static int +stc_custom_log (struct cmd_set *cmd unused) +{ + stc_custom_journal (cmd); + return 0; +} + +static int +stc_custom_rcolor (struct cmd_set *cmd unused) +{ + msg (SW, _("RCOLOR is obsolete.")); + + lex_match ('='); + if (!lex_force_match ('(')) + return 0; + + if (!lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 6) + { + msg (SE, _("Lower window color must be between 0 and 6.")); + return 0; + } + lex_get (); + } + if (!lex_force_match (',')) + return 0; + + if (!lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 6) + { + msg (SE, _("Upper window color must be between 0 and 6.")); + return 0; + } + lex_get (); + } + + if (lex_match (',') && !lex_match ('*')) + { + if (!lex_force_int ()) + return 0; + if (lex_integer () < 0 || lex_integer () > 6) + { + msg (SE, _("Frame color must be between 0 and 6.")); + return 0; + } + lex_get (); + } + return 1; +} + +static int +stc_custom_viewlength (struct cmd_set *cmd unused) +{ + if (lex_match_id ("MINIMUM")) + set_viewlength = 25; + else if (lex_match_id ("MEDIAN")) + set_viewlength = 43; /* This is not correct for VGA displays. */ + else if (lex_match_id ("MAXIMUM")) + set_viewlength = 43; + else + { + if (!lex_force_int ()) + return 0; +#if __MSDOS__ + if (lex_integer () >= (43 + 25) / 2) + set_viewlength = 43; + else + set_viewlength = 25; +#else /* not dos */ + set_viewlength = lex_integer (); +#endif /* not dos */ + lex_get (); + } + +#if __MSDOS__ + msg (SW, _("VIEWLENGTH not implemented.")); +#endif /* dos */ + return 1; +} + +static int +stc_custom_workdev (struct cmd_set *cmd unused) +{ + char c[2]; + + msg (SW, _("WORKDEV is obsolete.")); + + c[1] = 0; + for (*c = 'A'; *c <= 'Z'; (*c)++) + if (token == T_ID && lex_id_match (c, tokid)) + { + lex_get (); + return 1; + } + msg (SE, _("Drive letter expected in WORKDEV subcommand.")); + return 0; +} + + +/* GSET. */ + +int +cmd_gset (void) +{ + /* FIXME */ + return CMD_FAILURE; +} + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/settings.h b/src/settings.h new file mode 100644 index 00000000..3a8eaede --- /dev/null +++ b/src/settings.h @@ -0,0 +1,253 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !settings_h +#define settings_h 1 + +/* Table of mode settings (x=X, w=Windows, p=PC+, f=has relevance for + PSPP): + + AUTOMENU: p + BEEP: p + BLANKS: xwpf + BLKSIZE: x (only on SHOW, not on SET) + BLOCK: xwp + BOX/BOXSTRING: xwp + BUFNO: x (only on SHOW, not on SET) + CASE: xw + CCA...CCE: xwf + COLOR: p + COMP/COMPRESSION: xwpf (meaning varies between p and xw) + CPI: xwp + CPROMPT: pf + DECIMAL: wf + DPROMPT: f + ECHO: pf + EJECT: p + EMULATION: f + ENDCMD: xpf + ERRORBREAK: pf + ERRORS: wf + FORMAT: xwf + HEADERS: xwf + HELPWINDOWS: p + HIGHRES: w + HISTOGRAM: xp + INCLUDE: pf + JOURNAL: wf (equivalent to LOG) + LENGTH: xwp + LISTING: xpf + LOG: pf (equivalent to JOURNAL) + LOWRES: w + LPI: xwp + MENUS: p + MESSAGES: wf + MEXPAND: xwf + MITERATE: xwf + MNEST: xwf + MORE: pf + MPRINT: xwf + MXERRS: xf + MXLOOPS: xwf + MXMEMORY: w + MXWARNS: xwf + N: xw (only on SHOW, not on SET) + NULLINE: xpf + NUMBERED: x (only on SHOW, not on SET) + PAGER: f + PRINTBACK: xwf + PRINTER: pf + PROMPT: pf + PTRANSLATE: p + RCOLOR: p + RESULTS: wpf (semantics differ) + RUNREVIEW: p + SCOMP/SCOMPRESSION: xwf + SCREEN: pf + SCRIPTTAB: xw + SEED: xwpf (semantics differ) + SYSMIS: xwf (only on SHOW, not on SET) + TBFONTS: xw + TB1: xw + TB2: x + UNDEFINED: xwf + VIEWLENGTH: pf + VIEWWIDTH: f + WEIGHT: xwf (only on SHOW, not on SET) + WIDTH: xwp + WORKDEV: p + WORKSPACE: w + XSORT: x + $VARS: wf (only on SHOW, not on SET) + + */ + +#include + +/* The value that blank numeric fields are set to when read in; + normally SYSMIS. */ +extern double set_blanks; + +/* Describes one custom currency specification. */ +struct set_cust_currency + { + char buf[32]; /* Buffer for strings. */ + char *neg_prefix; /* Negative prefix. */ + char *prefix; /* Prefix. */ + char *suffix; /* Suffix. */ + char *neg_suffix; /* Negative suffix. */ + int decimal; /* Decimal point. */ + int grouping; /* Grouping character. */ + }; + +/* CCA through CCE. */ +extern struct set_cust_currency set_cc[5]; + +/* Whether the active file should be compressed. */ +extern int set_compression; + +/* Characters per inch (horizontal). */ +extern int set_cpi; + +/* Continuation prompt. */ +extern char *set_cprompt; + +/* The character used for a decimal point: ',' or '.'. Only respected + for data input and output. */ +extern int set_decimal; + +/* The character used for grouping in numbers: '.' or ','; the + opposite of set_decimal. Only used in COMMA data input and + output. */ +extern int set_grouping; + +/* Prompt used for lines between BEGIN DATA and END DATA. */ +extern char *set_dprompt; + +/* Whether we echo commands to the listing file/printer; 0=no, 1=yes. */ +extern int set_echo; + +/* The character used to terminate commands. */ +extern int set_endcmd; + +/* Types of routing. */ +enum + { + SET_ROUTE_SCREEN = 001, /* Output to screen devices? */ + SET_ROUTE_LISTING = 002, /* Output to listing devices? */ + SET_ROUTE_OTHER = 004, /* Output to other devices? */ + SET_ROUTE_DISABLE = 010 /* Disable output--overrides all other bits. */ + }; + +/* Routing for errors, messages, and procedure results. */ +extern int set_errors, set_messages, set_results; + +/* Whether an error stops execution; 0=no, 1=yes. */ +extern int set_errorbreak; + +/* Default format for variables created by transformations and by DATA + LIST {FREE,LIST}. */ +extern struct fmt_spec set_format; + +/* I don't know what this setting means; 0=no, 1=yes, 2=blank. */ +extern int set_headers; + +/* If set_echo is on, whether commands from include files are echoed; + * 0=no, 1=yes. */ +extern int set_include; + +/* Journal file's name. */ +extern char *set_journal; + +/* Whether we're journaling. */ +extern int set_journaling; + +/* Lines per inch (vertical). */ +extern int set_lpi; + +/* 0=macro expansion is disabled, 1=macro expansion is enabled. */ +extern int set_mexpand; + +/* Maximum number of iterations in a macro loop. */ +extern int set_miterate; + +/* Maximum nesting level for macros. */ +extern int set_mnest; + +/* Whether we pause after each screen of output; 0=no, 1=yes. */ +extern int set_more; + +/* Independent of set_printback, controls whether the commands + generated by macro invocations are displayed. */ +extern int set_mprint; + +/* Maximum number of errors. */ +extern int set_mxerrs; + +/* Implied limit of unbounded loop. */ +extern int set_mxloops; + +/* Maximum number of warnings + errors. */ +extern int set_mxwarns; + +/* Whether a blank line is a command terminator; 0=no, 1=yes. */ +extern int set_nullline; + +/* Whether commands are written to the display; 0=off, 1=on. */ +extern int set_printback; + +#if !USE_INTERNAL_PAGER +/* Name of the pager program. */ +extern char *set_pager; +#endif /* !USE_INTERNAL_PAGER */ + +/* The command prompt. */ +extern char *set_prompt; + +/* Name of the results file. */ +extern char *set_results_file; + +/* Whether to allow certain unsafe operations. Cannot be unset after + it is set. */ +extern int set_safer; + +/* Whether save files should be compressed by default. */ +extern int set_scompression; + +/* The random number seed; NOT_LONG if we want a "random" random + number seed. */ +extern long set_seed; + +/* 1=The user has modified or made use of the random number seed. */ +extern int set_seed_used; + +/* 1=Turn on some heuristics that make testing PSPP for correct + workings a little easier. */ +extern int set_testing_mode; + +/* Whether to warn on undefined values in numeric data. */ +extern int set_undefined; + +/* Requested "view length" in lines. */ +extern int set_viewlength; + +/* Screen width. */ +extern int set_viewwidth; + +#endif /* !settings_h */ diff --git a/src/sfm-read.c b/src/sfm-read.c new file mode 100644 index 00000000..f6353d8a --- /dev/null +++ b/src/sfm-read.c @@ -0,0 +1,1540 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "error.h" +#include "file-handle.h" +#include "format.h" +#include "getline.h" +#include "magic.h" +#include "misc.h" +#include "sfm.h" +#include "sfmP.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* PORTME: This file may require substantial revision for those + systems that don't meet the typical 32-bit integer/64-bit double + model. It's kinda hard to tell without having one of them on my + desk. */ + +/* sfm's file_handle extension. */ +struct sfm_fhuser_ext + { + FILE *file; /* Actual file. */ + int opened; /* Reference count. */ + + struct dictionary *dict; /* File's dictionary. */ + + int reverse_endian; /* 1=file has endianness opposite us. */ + int case_size; /* Number of `values's per case. */ + long ncases; /* Number of cases, -1 if unknown. */ + int compressed; /* 1=compressed, 0=not compressed. */ + double bias; /* Compression bias, usually 100.0. */ + int weight_index; /* 0-based index of weighting variable, or -1. */ + + /* File's special constants. */ + flt64 sysmis; + flt64 highest; + flt64 lowest; + + /* Uncompression buffer. */ + flt64 *buf; /* Buffer data. */ + flt64 *ptr; /* Current location in buffer. */ + flt64 *end; /* End of buffer data. */ + + /* Compression instruction octet. */ + unsigned char x[sizeof (flt64)]; + /* Current instruction octet. */ + unsigned char *y; /* Location in current instruction octet. */ + }; + +static struct fh_ext_class sfm_r_class; + +#if GLOBAL_DEBUGGING +void dump_dictionary (struct dictionary * dict); +#endif + +/* Utilities. */ + +/* bswap_int32(): Reverse the byte order of 32-bit integer *X. */ +#if __linux__ +#include +static inline void +bswap_int32 (int32 * x) +{ + *x = ntohl (*x); +} +#else /* not Linux */ +static inline void +bswap_int32 (int32 * x) +{ + unsigned char *y = (char *) x; + unsigned char t; + t = y[0]; + y[0] = y[3]; + y[3] = t; + t = y[1]; + y[1] = y[2]; + y[2] = t; +} +#endif /* not Linux */ + +/* Reverse the byte order of 64-bit floating point *X. */ +static inline void +bswap_flt64 (flt64 * x) +{ + /* Note that under compilers of any quality, half of this function + should optimize out as dead code. */ + unsigned char *y = (char *) x; + + if (sizeof (flt64) == 8) + { + unsigned char t; + t = y[0]; + y[0] = y[7]; + y[7] = t; + t = y[1]; + y[1] = y[6]; + y[6] = t; + t = y[2]; + y[2] = y[5]; + y[5] = t; + t = y[3]; + y[3] = y[4]; + y[4] = t; + } + else + { + unsigned char t; + size_t x; + + for (x = 0; x < sizeof (flt64) / 2; x++) + { + t = y[x]; + y[x] = y[sizeof (flt64) - x]; + y[sizeof (flt64) - x] = t; + } + } +} + +static void +corrupt_msg (int class, const char *format,...) + __attribute__ ((format (printf, 2, 3))); + +/* Displays a corrupt sysfile error. */ +static void +corrupt_msg (int class, const char *format,...) +{ + char buf[1024]; + + { + va_list args; + + va_start (args, format); + vsnprintf (buf, 1024, format, args); + va_end (args); + } + + { + struct error e; + + e.class = class; + getl_location (&e.where.filename, &e.where.line_number); + e.title = _("corrupt system file: "); + e.text = buf; + + err_vmsg (&e); + } +} + +/* Closes a system file after we're done with it. */ +static void +sfm_close (struct file_handle * h) +{ + struct sfm_fhuser_ext *ext = h->ext; + + ext->opened--; + assert (ext->opened == 0); + if (EOF == fclose (ext->file)) + msg (ME, _("%s: Closing system file: %s."), h->fn, strerror (errno)); + free (ext->buf); + free (h->ext); +} + +/* Closes a system file if we're done with it. */ +void +sfm_maybe_close (struct file_handle *h) +{ + struct sfm_fhuser_ext *ext = h->ext; + + if (ext->opened == 1) + fh_close_handle (h); + else + ext->opened--; +} + +/* Dictionary reader. */ + +static void *bufread (struct file_handle * handle, void *buf, size_t nbytes, + size_t minalloc); + +static int read_header (struct file_handle * h, struct sfm_read_info * inf); +static int parse_format_spec (struct file_handle * h, int32 s, + struct fmt_spec * v, struct variable *vv); +static int read_value_labels (struct file_handle * h, struct variable ** var_by_index); +static int read_variables (struct file_handle * h, struct variable *** var_by_index); +static int read_machine_int32_info (struct file_handle * h, int size, int count); +static int read_machine_flt64_info (struct file_handle * h, int size, int count); +static int read_documents (struct file_handle * h); + +/* Displays the message X with corrupt_msg, then jumps to the lossage + label. */ +#define lose(X) \ + do \ + { \ + corrupt_msg X; \ + goto lossage; \ + } \ + while (0) + +/* Calls bufread with the specified arguments, and jumps to lossage if + the read fails. */ +#define assertive_bufread(a,b,c,d) \ + do \ + { \ + if (!bufread (a,b,c,d)) \ + goto lossage; \ + } \ + while (0) + +/* Reads the dictionary from file with handle H, and returns it in a + dictionary structure. This dictionary may be modified in order to + rename, reorder, and delete variables, etc. */ +struct dictionary * +sfm_read_dictionary (struct file_handle * h, struct sfm_read_info * inf) +{ + /* The file handle extension record. */ + struct sfm_fhuser_ext *ext; + + /* Allows for quick reference to variables according to indexes + relative to position within a case. */ + struct variable **var_by_index = NULL; + + /* Check whether the file is already open. */ + if (h->class == &sfm_r_class) + { + ext = h->ext; + ext->opened++; + return ext->dict; + } + else if (h->class != NULL) + { + msg (ME, _("Cannot read file %s as system file: already opened for %s."), + fh_handle_name (h), h->class->name); + return NULL; + } + + msg (VM (1), _("%s: Opening system-file handle %s for reading."), + fh_handle_filename (h), fh_handle_name (h)); + + /* Open the physical disk file. */ + ext = xmalloc (sizeof (struct sfm_fhuser_ext)); + ext->file = fopen (h->norm_fn, "rb"); + if (ext->file == NULL) + { + msg (ME, _("An error occurred while opening \"%s\" for reading " + "as a system file: %s."), h->fn, strerror (errno)); + err_cond_fail (); + free (ext); + return NULL; + } + + /* Initialize the sfm_fhuser_ext structure. */ + h->class = &sfm_r_class; + h->ext = ext; + ext->dict = NULL; + ext->buf = ext->ptr = ext->end = NULL; + ext->y = ext->x + sizeof ext->x; + ext->opened = 1; + + /* Default special constants. */ + ext->sysmis = -FLT64_MAX; + ext->highest = FLT64_MAX; + ext->lowest = second_lowest_flt64; + + /* Read the header. */ + if (!read_header (h, inf)) + goto lossage; + + /* Read about the variables. */ + if (!read_variables (h, &var_by_index)) + goto lossage; + + /* Handle weighting. */ + if (ext->weight_index != -1) + { + struct variable *wv = var_by_index[ext->weight_index]; + + if (wv == NULL) + lose ((ME, _("%s: Weighting variable may not be a continuation of " + "a long string variable."), h->fn)); + else if (wv->type == ALPHA) + lose ((ME, _("%s: Weighting variable may not be a string variable."), + h->fn)); + + strcpy (ext->dict->weight_var, wv->name); + } + else + ext->dict->weight_var[0] = 0; + + /* Read records of types 3, 4, 6, and 7. */ + for (;;) + { + int32 rec_type; + + assertive_bufread (h, &rec_type, sizeof rec_type, 0); + if (ext->reverse_endian) + bswap_int32 (&rec_type); + + switch (rec_type) + { + case 3: + if (!read_value_labels (h, var_by_index)) + goto lossage; + break; + + case 4: + lose ((ME, _("%s: Orphaned variable index record (type 4). Type 4 " + "records must always immediately follow type 3 records."), + h->fn)); + + case 6: + if (!read_documents (h)) + goto lossage; + break; + + case 7: + { + struct + { + int32 subtype P; + int32 size P; + int32 count P; + } + data; + + int skip = 0; + + assertive_bufread (h, &data, sizeof data, 0); + if (ext->reverse_endian) + { + bswap_int32 (&data.subtype); + bswap_int32 (&data.size); + bswap_int32 (&data.count); + } + + /*if(data.size != sizeof(int32) && data.size != sizeof(flt64)) + lose((ME, "%s: Element size in record type 7, subtype %d, is " + "not either the size of IN (%d) or OBS (%d); actual value " + "is %d.", + h->fn, data.subtype, sizeof(int32), sizeof(flt64), + data.size)); */ + + switch (data.subtype) + { + case 3: + if (!read_machine_int32_info (h, data.size, data.count)) + goto lossage; + break; + + case 4: + if (!read_machine_flt64_info (h, data.size, data.count)) + goto lossage; + break; + + case 5: + case 6: + case 11: /* ?? Used by SPSS 8.0. */ + skip = 1; + break; + + default: + msg (MW, _("%s: Unrecognized record type 7, subtype %d " + "encountered in system file."), h->fn, data.subtype); + skip = 1; + } + + if (skip) + { + void *x = bufread (h, NULL, data.size * data.count, 0); + if (x == NULL) + goto lossage; + free (x); + } + } + break; + + case 999: + { + int32 filler; + + assertive_bufread (h, &filler, sizeof filler, 0); + goto break_out_of_loop; + } + + default: + lose ((ME, _("%s: Unrecognized record type %d."), h->fn, rec_type)); + } + } + +break_out_of_loop: + /* Come here on successful completion. */ + msg (VM (2), _("Read system-file dictionary successfully.")); + +#if DEBUGGING + dump_dictionary (ext->dict); +#endif + free (var_by_index); + return ext->dict; + +lossage: + /* Come here on unsuccessful completion. */ + msg (VM (1), _("Error reading system-file header.")); + + free (var_by_index); + fclose (ext->file); + if (ext && ext->dict) + free_dictionary (ext->dict); + free (ext); + h->class = NULL; + h->ext = NULL; + return NULL; +} + +/* Read record type 7, subtype 3. */ +static int +read_machine_int32_info (struct file_handle * h, int size, int count) +{ + struct sfm_fhuser_ext *ext = h->ext; + + int32 data[8]; + int file_endian; + + int i; + + if (size != sizeof (int32) || count != 8) + lose ((ME, _("%s: Bad size (%d) or count (%d) field on record type 7, " + "subtype 3. Expected size %d, count 8."), + h->fn, size, count, sizeof (int32))); + + assertive_bufread (h, data, sizeof data, 0); + if (ext->reverse_endian) + for (i = 0; i < 8; i++) + bswap_int32 (&data[i]); + + /* PORTME: Check floating-point representation. */ + switch (FPREP) + { + case FPREP_IEEE754: + if (data[4] != 1) + lose ((ME, _("%s: Floating-point representation in system file is not " + "IEEE-754. PSPP cannot convert between floating-point " + "formats."), h->fn)); + break; + default: + assert (0); + } + + /* PORTME: Check recorded file endianness against intuited file + endianness. */ + file_endian = endian; + if (ext->reverse_endian) + { + if (file_endian == BIG) + file_endian = LITTLE; + else if (file_endian == LITTLE) + file_endian = BIG; + else + assert (0); + } + if ((file_endian == BIG) ^ (data[6] == 1)) + lose ((ME, _("%s: File-indicated endianness (%s) does not match endianness " + "intuited from file header (%s)."), + h->fn, file_endian == BIG ? _("big-endian") : _("little-endian"), + data[6] == 1 ? _("big-endian") : (data[6] == 2 ? _("little-endian") + : _("unknown")))); + + /* PORTME: Character representation code. */ + if (data[7] != 2 && data[7] != 3) + lose ((ME, _("%s: File-indicated character representation code (%s) is not " + "ASCII."), h->fn, + data[7] == 1 ? "EBCDIC" : (data[7] == 4 ? _("DEC Kanji") : _("Unknown")))); + + return 1; + +lossage: + return 0; +} + +/* Read record type 7, subtype 4. */ +static int +read_machine_flt64_info (struct file_handle * h, int size, int count) +{ + struct sfm_fhuser_ext *ext = h->ext; + + flt64 data[3]; + + int i; + + if (size != sizeof (flt64) || count != 3) + lose ((ME, _("%s: Bad size (%d) or count (%d) field on record type 7, " + "subtype 4. Expected size %d, count 8."), + h->fn, size, count, sizeof (flt64))); + + assertive_bufread (h, data, sizeof data, 0); + if (ext->reverse_endian) + for (i = 0; i < 3; i++) + bswap_flt64 (&data[i]); + + if (data[0] != SYSMIS || data[1] != FLT64_MAX + || data[2] != second_lowest_flt64) + { + ext->sysmis = data[0]; + ext->highest = data[1]; + ext->lowest = data[2]; + msg (MW, _("%s: File-indicated value is different from internal value " + "for at least one of the three system values. SYSMIS: " + "indicated %g, expected %g; HIGHEST: %g, %g; LOWEST: " + "%g, %g."), + h->fn, (double) data[0], (double) SYSMIS, + (double) data[1], (double) FLT64_MAX, + (double) data[2], (double) second_lowest_flt64); + } + + return 1; + +lossage: + return 0; +} + +static int +read_header (struct file_handle * h, struct sfm_read_info * inf) +{ + struct sfm_fhuser_ext *ext = h->ext; /* File extension strcut. */ + struct sysfile_header hdr; /* Disk buffer. */ + struct dictionary *dict; /* File dictionary. */ + char prod_name[sizeof hdr.prod_name + 1]; /* Buffer for product name. */ + int skip_amt; /* Amount of product name to omit. */ + int i; + + /* Create the dictionary. */ + dict = ext->dict = xmalloc (sizeof *dict); + dict->var = NULL; + dict->var_by_name = NULL; + dict->nvar = 0; + dict->N = 0; + dict->nval = -1; /* Unknown. */ + dict->n_splits = 0; + dict->splits = NULL; + dict->weight_var[0] = 0; + dict->weight_index = -1; + dict->filter_var[0] = 0; + dict->label = NULL; + dict->n_documents = 0; + dict->documents = NULL; + + /* Read header, check magic. */ + assertive_bufread (h, &hdr, sizeof hdr, 0); + if (0 != strncmp ("$FL2", hdr.rec_type, 4)) + lose ((ME, _("%s: Bad magic. Proper system files begin with " + "the four characters `$FL2'. This file will not be read."), + h->fn)); + + /* Check eye-catcher string. */ + memcpy (prod_name, hdr.prod_name, sizeof hdr.prod_name); + for (i = 0; i < 60; i++) + if (!isprint ((unsigned char) prod_name[i])) + prod_name[i] = ' '; + for (i = 59; i >= 0; i--) + if (!isgraph ((unsigned char) prod_name[i])) + { + prod_name[i] = '\0'; + break; + } + prod_name[60] = '\0'; + + { +#define N_PREFIXES 2 + static const char *prefix[N_PREFIXES] = + { + "@(#) SPSS DATA FILE", + "SPSS SYSTEM FILE.", + }; + + int i; + + for (i = 0; i < N_PREFIXES; i++) + if (!strncmp (prefix[i], hdr.prod_name, strlen (prefix[i]))) + { + skip_amt = strlen (prefix[i]); + break; + } + } + + /* Check endianness. */ + /* PORTME: endianness. */ + if (hdr.layout_code == 2) + ext->reverse_endian = 0; + else + { + bswap_int32 (&hdr.layout_code); + if (hdr.layout_code != 2) + lose ((ME, _("%s: File layout code has unexpected value %d. Value " + "should be 2, in big-endian or little-endian format."), + h->fn, hdr.layout_code)); + + ext->reverse_endian = 1; + bswap_int32 (&hdr.case_size); + bswap_int32 (&hdr.compressed); + bswap_int32 (&hdr.weight_index); + bswap_int32 (&hdr.ncases); + bswap_flt64 (&hdr.bias); + } + + /* Copy basic info and verify correctness. */ + ext->case_size = hdr.case_size; + if (hdr.case_size <= 0 || ext->case_size > (INT_MAX + / (int) sizeof (union value) / 2)) + lose ((ME, _("%s: Number of elements per case (%d) is not between 1 " + "and %d."), h->fn, hdr.case_size, INT_MAX / sizeof (union value) / 2)); + + ext->compressed = hdr.compressed; + + ext->weight_index = hdr.weight_index - 1; + if (hdr.weight_index < 0 || hdr.weight_index > hdr.case_size) + lose ((ME, _("%s: Index of weighting variable (%d) is not between 0 " + "and number of elements per case (%d)."), + h->fn, hdr.weight_index, ext->case_size)); + + ext->ncases = hdr.ncases; + if (ext->ncases < -1 || ext->ncases > INT_MAX / 2) + lose ((ME, _("%s: Number of cases in file (%ld) is not between -1 and " + "%d."), h->fn, (long) ext->ncases, INT_MAX / 2)); + + ext->bias = hdr.bias; + if (ext->bias != 100.0) + corrupt_msg (MW, _("%s: Compression bias (%g) is not the usual " + "value of 100."), h->fn, ext->bias); + + /* Make a file label only on the condition that the given label is + not all spaces or nulls. */ + { + int i; + + dict->label = NULL; + for (i = sizeof hdr.file_label - 1; i >= 0; i--) + if (!isspace ((unsigned char) hdr.file_label[i]) + && hdr.file_label[i] != 0) + { + dict->label = xmalloc (i + 2); + memcpy (dict->label, hdr.file_label, i + 1); + dict->label[i + 1] = 0; + break; + } + } + + if (inf) + { + char *cp; + + memcpy (inf->creation_date, hdr.creation_date, 9); + inf->creation_date[9] = 0; + + memcpy (inf->creation_time, hdr.creation_time, 8); + inf->creation_time[8] = 0; + + if (!ext->reverse_endian) + inf->endianness = endian; + else + inf->endianness = endian == BIG ? LITTLE : BIG; + + inf->compressed = hdr.compressed; + + inf->ncases = hdr.ncases; + + for (cp = &prod_name[skip_amt]; cp < &prod_name[60]; cp++) + if (isgraph ((unsigned char) *cp)) + break; + strcpy (inf->product, cp); + } + + return 1; + +lossage: + return 0; +} + +/* Reads most of the dictionary from file H; also fills in the + associated VAR_BY_INDEX array. + + Note: the dictionary returned by this function has an invalid NVAL + element, also the VAR[] array does not have the FV and LV elements + set, however the NV elements *are* set. This is because the caller + will probably modify the dictionary before reading it in from the + file. Also, the get.* elements are set to appropriate values to + allow the file to be read. */ +static int +read_variables (struct file_handle * h, struct variable *** var_by_index) +{ + int i; + + struct sfm_fhuser_ext *ext = h->ext; /* File extension record. */ + struct dictionary *dict = ext->dict; /* Dictionary being constructed. */ + struct sysfile_variable sv; /* Disk buffer. */ + int long_string_count = 0; /* # of long string continuation + records still expected. */ + int next_value = 0; /* Index to next `value' structure. */ + + /* Allocate variables. */ + dict->var = xmalloc (sizeof *dict->var * ext->case_size); + *var_by_index = xmalloc (sizeof **var_by_index * ext->case_size); + + /* Read in the entry for each variable and use the info to + initialize the dictionary. */ + for (i = 0; i < ext->case_size; i++) + { + struct variable *vv; + int j; + + assertive_bufread (h, &sv, sizeof sv, 0); + + if (ext->reverse_endian) + { + bswap_int32 (&sv.rec_type); + bswap_int32 (&sv.type); + bswap_int32 (&sv.has_var_label); + bswap_int32 (&sv.n_missing_values); + bswap_int32 (&sv.print); + bswap_int32 (&sv.write); + } + + if (sv.rec_type != 2) + lose ((ME, _("%s: position %d: Bad record type (%d); " + "the expected value was 2."), h->fn, i, sv.rec_type)); + + /* If there was a long string previously, make sure that the + continuations are present; otherwise make sure there aren't + any. */ + if (long_string_count) + { + if (sv.type != -1) + lose ((ME, _("%s: position %d: String variable does not have " + "proper number of continuation records."), h->fn, i)); + + (*var_by_index)[i] = NULL; + long_string_count--; + continue; + } + else if (sv.type == -1) + lose ((ME, _("%s: position %d: Superfluous long string continuation " + "record."), h->fn, i)); + + /* Check fields for validity. */ + if (sv.type < 0 || sv.type > 255) + lose ((ME, _("%s: position %d: Bad variable type code %d."), + h->fn, i, sv.type)); + if (sv.has_var_label != 0 && sv.has_var_label != 1) + lose ((ME, _("%s: position %d: Variable label indicator field is not " + "0 or 1."), h->fn, i)); + if (sv.n_missing_values < -3 || sv.n_missing_values > 3 + || sv.n_missing_values == -1) + lose ((ME, _("%s: position %d: Missing value indicator field is not " + "-3, -2, 0, 1, 2, or 3."), h->fn, i)); + + /* Construct internal variable structure, initialize critical bits. */ + vv = (*var_by_index)[i] = dict->var[dict->nvar++] = xmalloc (sizeof *vv); + vv->index = dict->nvar - 1; + vv->foo = -1; + vv->label = NULL; + vv->val_lab = NULL; + + /* Copy first character of variable name. */ + if (!isalpha ((unsigned char) sv.name[0]) + && sv.name[0] != '@' && sv.name[0] != '#') + lose ((ME, _("%s: position %d: Variable name begins with invalid " + "character."), h->fn, i)); + if (islower ((unsigned char) sv.name[0])) + msg (MW, _("%s: position %d: Variable name begins with lowercase letter " + "%c."), h->fn, i, sv.name[0]); + if (sv.name[0] == '#') + msg (MW, _("%s: position %d: Variable name begins with octothorpe " + "(`#'). Scratch variables should not appear in system " + "files."), h->fn, i); + vv->name[0] = toupper ((unsigned char) (sv.name[0])); + + /* Copy remaining characters of variable name. */ + for (j = 1; j < 8; j++) + { + int c = (unsigned char) sv.name[j]; + + if (isspace (c)) + break; + else if (islower (c)) + { + msg (MW, _("%s: position %d: Variable name character %d is " + "lowercase letter %c."), h->fn, i, j + 1, sv.name[j]); + vv->name[j] = toupper ((unsigned char) (c)); + } + else if (isalnum (c) || c == '.' || c == '@' + || c == '#' || c == '$' || c == '_') + vv->name[j] = c; + else + lose ((ME, _("%s: position %d: character `\\%03o' (%c) is not valid in a " + "variable name."), h->fn, i, c, c)); + } + vv->name[j] = 0; + + /* Set type, width, and `left' fields and allocate `value' + indices. */ + if (sv.type == 0) + { + vv->type = NUMERIC; + vv->width = 0; + vv->get.nv = 1; + vv->get.fv = next_value++; + vv->nv = 1; + } + else + { + vv->type = ALPHA; + vv->width = sv.type; + vv->nv = DIV_RND_UP (vv->width, MAX_SHORT_STRING); + vv->get.nv = DIV_RND_UP (vv->width, sizeof (flt64)); + vv->get.fv = next_value; + next_value += vv->get.nv; + long_string_count = vv->get.nv - 1; + } + vv->left = (vv->name[0] == '#'); + + /* Get variable label, if any. */ + if (sv.has_var_label == 1) + { + /* Disk buffer. */ + int32 len; + + /* Read length of label. */ + assertive_bufread (h, &len, sizeof len, 0); + if (ext->reverse_endian) + bswap_int32 (&len); + + /* Check len. */ + if (len < 0 || len > 255) + lose ((ME, _("%s: Variable %s indicates variable label of invalid " + "length %d."), h->fn, vv->name, len)); + + /* Read label into variable structure. */ + vv->label = bufread (h, NULL, ROUND_UP (len, sizeof (int32)), len + 1); + if (vv->label == NULL) + goto lossage; + vv->label[len] = '\0'; + } + + /* Set missing values. */ + if (sv.n_missing_values != 0) + { + flt64 mv[3]; + + if (vv->width > MAX_SHORT_STRING) + lose ((ME, _("%s: Long string variable %s may not have missing " + "values."), h->fn, vv->name)); + + assertive_bufread (h, mv, sizeof *mv * abs (sv.n_missing_values), 0); + + if (ext->reverse_endian && vv->type == NUMERIC) + for (j = 0; j < abs (sv.n_missing_values); j++) + bswap_flt64 (&mv[j]); + + if (sv.n_missing_values > 0) + { + vv->miss_type = sv.n_missing_values; + if (vv->type == NUMERIC) + for (j = 0; j < sv.n_missing_values; j++) + vv->missing[j].f = mv[j]; + else + for (j = 0; j < sv.n_missing_values; j++) + memcpy (vv->missing[j].s, &mv[j], vv->width); + } + else + { + int x = 0; + + if (vv->type == ALPHA) + lose ((ME, _("%s: String variable %s may not have missing " + "values specified as a range."), h->fn, vv->name)); + + if (mv[0] == ext->lowest) + { + vv->miss_type = MISSING_LOW; + vv->missing[x++].f = mv[1]; + } + else if (mv[1] == ext->highest) + { + vv->miss_type = MISSING_HIGH; + vv->missing[x++].f = mv[0]; + } + else + { + vv->miss_type = MISSING_RANGE; + vv->missing[x++].f = mv[0]; + vv->missing[x++].f = mv[1]; + } + + if (sv.n_missing_values == -3) + { + vv->miss_type += 3; + vv->missing[x++].f = mv[2]; + } + } + } + else + vv->miss_type = MISSING_NONE; + + if (!parse_format_spec (h, sv.print, &vv->print, vv) + || !parse_format_spec (h, sv.write, &vv->write, vv)) + goto lossage; + } + + /* Some consistency checks. */ + if (long_string_count != 0) + lose ((ME, _("%s: Long string continuation records omitted at end of " + "dictionary."), h->fn)); + if (next_value != ext->case_size) + lose ((ME, _("%s: System file header indicates %d variable positions but " + "%d were read from file."), h->fn, ext->case_size, next_value)); + dict->var = xrealloc (dict->var, sizeof *dict->var * dict->nvar); + + /* Construct AVL tree of dictionary in order to speed up later + processing and to check for duplicate varnames. */ + dict->var_by_name = avl_create (NULL, cmp_variable, NULL); + for (i = 0; i < dict->nvar; i++) + if (NULL != avl_insert (dict->var_by_name, dict->var[i])) + lose ((ME, _("%s: Duplicate variable name `%s' within system file."), + h->fn, dict->var[i]->name)); + + return 1; + +lossage: + for (i = 0; i < dict->nvar; i++) + { + free (dict->var[i]->label); + free (dict->var[i]); + } + free (dict->var); + if (dict->var_by_name) + avl_destroy (dict->var_by_name, NULL); + free (dict); + ext->dict = NULL; + + return 0; +} + +/* Translates the format spec from sysfile format to internal + format. */ +static int +parse_format_spec (struct file_handle *h, int32 s, struct fmt_spec *v, struct variable *vv) +{ + if ((size_t) ((s >> 16) & 0xff) + >= sizeof translate_fmt / sizeof *translate_fmt) + lose ((ME, _("%s: Bad format specifier byte (%d)."), + h->fn, (s >> 16) & 0xff)); + + v->type = translate_fmt[(s >> 16) & 0xff]; + v->w = (s >> 8) & 0xff; + v->d = s & 0xff; + + /* FIXME? Should verify the resulting specifier more thoroughly. */ + + if (v->type == -1) + lose ((ME, _("%s: Bad format specifier byte (%d)."), + h->fn, (s >> 16) & 0xff)); + if ((vv->type == ALPHA) ^ ((formats[v->type].cat & FCAT_STRING) != 0)) + lose ((ME, _("%s: %s variable %s has %s format specifier %s."), + h->fn, vv->type == ALPHA ? _("String") : _("Numeric"), + vv->name, + formats[v->type].cat & FCAT_STRING ? _("string") : _("numeric"), + formats[v->type].name)); + return 1; + +lossage: + return 0; +} + +/* Reads value labels from sysfile H and inserts them into the + associated dictionary. */ +int +read_value_labels (struct file_handle * h, struct variable ** var_by_index) +{ + struct sfm_fhuser_ext *ext = h->ext; /* File extension record. */ + + flt64 *raw_label = NULL; /* Array of raw label values. */ + struct value_label **cooked_label = NULL; /* Array of cooked labels. */ + int32 n_labels; /* Number of labels. */ + + struct variable **var = NULL; /* Associated variables. */ + int32 n_vars; /* Number of associated variables. */ + + int i; + + /* First step: read the contents of the type 3 record and record its + contents. Note that we can't do much with the data since we + don't know yet whether it is of numeric or string type. */ + + /* Read number of labels. */ + assertive_bufread (h, &n_labels, sizeof n_labels, 0); + if (ext->reverse_endian) + bswap_int32 (&n_labels); + + /* Allocate memory. */ + raw_label = xmalloc (sizeof *raw_label * n_labels); + cooked_label = xmalloc (sizeof *cooked_label * n_labels); + for (i = 0; i < n_labels; i++) + cooked_label[i] = NULL; + + /* Read each value/label tuple. */ + for (i = 0; i < n_labels; i++) + { + flt64 value; + unsigned char label_len; + + int rem; + + /* Read value, label length. */ + assertive_bufread (h, &value, sizeof value, 0); + assertive_bufread (h, &label_len, 1, 0); + memcpy (&raw_label[i], &value, sizeof value); + + /* Read label. */ + cooked_label[i] = xmalloc (sizeof **cooked_label); + cooked_label[i]->s = xmalloc (label_len + 1); + assertive_bufread (h, cooked_label[i]->s, label_len, 0); + cooked_label[i]->s[label_len] = 0; + + /* Skip padding. */ + rem = REM_RND_UP (label_len + 1, sizeof (flt64)); + if (rem) + assertive_bufread (h, &value, rem, 0); + } + + /* Second step: Read the type 4 record that has the list of + variables to which the value labels are to be applied. */ + + /* Read record type of type 4 record. */ + { + int32 rec_type; + + assertive_bufread (h, &rec_type, sizeof rec_type, 0); + if (ext->reverse_endian) + bswap_int32 (&rec_type); + + if (rec_type != 4) + lose ((ME, _("%s: Variable index record (type 4) does not immediately " + "follow value label record (type 3) as it ought."), h->fn)); + } + + /* Read number of variables associated with value label from type 4 + record. */ + assertive_bufread (h, &n_vars, sizeof n_vars, 0); + if (ext->reverse_endian) + bswap_int32 (&n_vars); + if (n_vars < 1 || n_vars > ext->dict->nvar) + lose ((ME, _("%s: Number of variables associated with a value label (%d) " + "is not between 1 and the number of variables (%d)."), + h->fn, n_vars, ext->dict->nvar)); + + /* Allocate storage. */ + var = xmalloc (sizeof *var * n_vars); + + /* Read the list of variables. */ + for (i = 0; i < n_vars; i++) + { + int32 var_index; + struct variable *v; + + /* Read variable index, check range. */ + assertive_bufread (h, &var_index, sizeof var_index, 0); + if (ext->reverse_endian) + bswap_int32 (&var_index); + if (var_index < 1 || var_index > ext->case_size) + lose ((ME, _("%s: Variable index associated with value label (%d) is " + "not between 1 and the number of values (%d)."), + h->fn, var_index, ext->case_size)); + + /* Make sure it's a real variable. */ + v = var_by_index[var_index - 1]; + if (v == NULL) + lose ((ME, _("%s: Variable index associated with value label (%d) refers " + "to a continuation of a string variable, not to an actual " + "variable."), h->fn, var_index)); + if (v->type == ALPHA && v->width > MAX_SHORT_STRING) + lose ((ME, _("%s: Value labels are not allowed on long string variables " + "(%s)."), h->fn, v->name)); + + /* Add it to the list of variables. */ + var[i] = v; + } + + /* Type check the variables. */ + for (i = 1; i < n_vars; i++) + if (var[i]->type != var[0]->type) + lose ((ME, _("%s: Variables associated with value label are not all of " + "identical type. Variable %s has %s type, but variable %s has " + "%s type."), h->fn, + var[0]->name, var[0]->type == ALPHA ? _("string") : _("numeric"), + var[i]->name, var[i]->type == ALPHA ? _("string") : _("numeric"))); + + /* Create a value_label for each value/label tuple, now that we know + the desired type. */ + for (i = 0; i < n_labels; i++) + { + if (var[0]->type == ALPHA) + { + const int copy_len = min (sizeof (flt64), MAX_SHORT_STRING); + memcpy (cooked_label[i]->v.s, (char *) &raw_label[i], copy_len); + if (MAX_SHORT_STRING > copy_len) + memset (&cooked_label[i]->v.s[copy_len], ' ', + MAX_SHORT_STRING - copy_len); + } else { + cooked_label[i]->v.f = raw_label[i]; + if (ext->reverse_endian) + bswap_flt64 (&cooked_label[i]->v.f); + } + cooked_label[i]->ref_count = n_vars; + } + + /* Assign the value_label's to each variable. */ + for (i = 0; i < n_vars; i++) + { + struct variable *v = var[i]; + int j; + + /* Create AVL tree if necessary. */ + if (!v->val_lab) + v->val_lab = avl_create (NULL, val_lab_cmp, (void *) (v->width)); + + /* Add each label to the variable. */ + for (j = 0; j < n_labels; j++) + { + struct value_label *old = avl_replace (v->val_lab, cooked_label[j]); + if (old == NULL) + continue; + + if (var[0]->type == NUMERIC) + msg (MW, _("%s: File contains duplicate label for value %g for " + "variable %s."), h->fn, cooked_label[j]->v.f, v->name); + else + msg (MW, _("%s: File contains duplicate label for value `%.*s' " + "for variable %s."), h->fn, v->width, + cooked_label[j]->v.s, v->name); + + free_value_label (old); + } + } + + free (cooked_label); + free (raw_label); + free (var); + return 1; + +lossage: + if (cooked_label) + for (i = 0; i < n_labels; i++) + if (cooked_label[i]) + { + free (cooked_label[i]->s); + free (cooked_label[i]); + } + free (raw_label); + free (var); + return 0; +} + +/* Reads NBYTES bytes from the file represented by H. If BUF is + non-NULL, uses that as the buffer; otherwise allocates at least + MINALLOC bytes. Returns a pointer to the buffer on success, NULL + on failure. */ +static void * +bufread (struct file_handle * h, void *buf, size_t nbytes, size_t minalloc) +{ + struct sfm_fhuser_ext *ext = h->ext; + + if (buf == NULL) + buf = xmalloc (max (nbytes, minalloc)); + if (1 != fread (buf, nbytes, 1, ext->file)) + { + if (ferror (ext->file)) + msg (ME, _("%s: Reading system file: %s."), h->fn, strerror (errno)); + else + corrupt_msg (ME, _("%s: Unexpected end of file."), h->fn); + return NULL; + } + return buf; +} + +/* Reads a document record, type 6, from system file H, and sets up + the documents and n_documents fields in the associated + dictionary. */ +static int +read_documents (struct file_handle * h) +{ + struct sfm_fhuser_ext *ext = h->ext; + struct dictionary *dict = ext->dict; + int32 n_lines; + + if (dict->documents != NULL) + lose ((ME, _("%s: System file contains multiple type 6 (document) records."), + h->fn)); + + assertive_bufread (h, &n_lines, sizeof n_lines, 0); + dict->n_documents = n_lines; + if (dict->n_documents <= 0) + lose ((ME, _("%s: Number of document lines (%ld) must be greater than 0."), + h->fn, (long) dict->n_documents)); + + dict->documents = bufread (h, NULL, 80 * n_lines, 0); + if (dict->documents == NULL) + return 0; + return 1; + +lossage: + return 0; +} + +#if GLOBAL_DEBUGGING +#define DEBUGGING 1 +#include "debug-print.h" +/* Displays dictionary DICT on stdout. */ +void +dump_dictionary (struct dictionary * dict) +{ + int i; + + debug_printf ((_("dictionary:\n"))); + for (i = 0; i < dict->nvar; i++) + { + char print[32]; + struct variable *v = dict->var[i]; + int n, j; + + debug_printf ((" var %s", v->name)); + /*debug_printf (("(indices:%d,%d)", v->index, v->foo));*/ + debug_printf (("(type:%s,%d)", (v->type == NUMERIC ? _("num") + : (v->type == ALPHA ? _("str") : "!!!")), + v->width)); + debug_printf (("(fv:%d,%d)", v->fv, v->nv)); + /*debug_printf (("(get.fv:%d,%d)", v->get.fv, v->get.nv));*/ + debug_printf (("(left:%s)(miss:", v->left ? _("left") : _("right"))); + + switch (v->miss_type) + { + case MISSING_NONE: + n = 0; + debug_printf ((_("none"))); + break; + case MISSING_1: + n = 1; + debug_printf ((_("one"))); + break; + case MISSING_2: + n = 2; + debug_printf ((_("two"))); + break; + case MISSING_3: + n = 3; + debug_printf ((_("three"))); + break; + case MISSING_RANGE: + n = 2; + debug_printf ((_("range"))); + break; + case MISSING_LOW: + n = 1; + debug_printf ((_("low"))); + break; + case MISSING_HIGH: + n = 1; + debug_printf ((_("high"))); + break; + case MISSING_RANGE_1: + n = 3; + debug_printf ((_("range+1"))); + break; + case MISSING_LOW_1: + n = 2; + debug_printf ((_("low+1"))); + break; + case MISSING_HIGH_1: + n = 2; + debug_printf ((_("high+1"))); + break; + default: + assert (0); + } + for (j = 0; j < n; j++) + if (v->type == NUMERIC) + debug_printf ((",%g", v->missing[j].f)); + else + debug_printf ((",\"%.*s\"", v->width, v->missing[j].s)); + strcpy (print, fmt_to_string (&v->print)); + debug_printf ((")(fmt:%s,%s)(lbl:%s)\n", + print, fmt_to_string (&v->write), + v->label ? v->label : "nolabel")); + } +} +#endif + +/* Data reader. */ + +/* Reads compressed data into H->BUF and sets other pointers + appropriately. Returns nonzero only if both no errors occur and + data was read. */ +static int +buffer_input (struct file_handle * h) +{ + struct sfm_fhuser_ext *ext = h->ext; + size_t amt; + + if (ext->buf == NULL) + ext->buf = xmalloc (sizeof *ext->buf * 128); + amt = fread (ext->buf, sizeof *ext->buf, 128, ext->file); + if (ferror (ext->file)) + { + msg (ME, _("%s: Error reading file: %s."), h->fn, strerror (errno)); + return 0; + } + ext->ptr = ext->buf; + ext->end = &ext->buf[amt]; + return amt; +} + +/* Reads a single case consisting of compressed data from system file + H into the array TEMP[] according to dictionary DICT, and returns + nonzero only if successful. */ +/* Data in system files is compressed in the following manner: + data values are grouped into sets of eight; each of the eight has + one instruction byte, which are output together in an octet; each + byte gives a value for that byte or indicates that the value can be + found following the instructions. */ +static int +read_compressed_data (struct file_handle * h, flt64 * temp) +{ + struct sfm_fhuser_ext *ext = h->ext; + + const unsigned char *p_end = ext->x + sizeof (flt64); + unsigned char *p = ext->y; + + const flt64 *temp_beg = temp; + const flt64 *temp_end = &temp[ext->case_size]; + + for (;;) + { + for (; p < p_end; p++) + switch (*p) + { + case 0: + /* Code 0 is ignored. */ + continue; + case 252: + /* Code 252 is end of file. */ + if (temp_beg != temp) + lose ((ME, _("%s: Compressed data is corrupted. Data ends " + "partway through a case."), h->fn)); + goto lossage; + case 253: + /* Code 253 indicates that the value is stored explicitly + following the instruction bytes. */ + if (ext->ptr == NULL || ext->ptr >= ext->end) + if (!buffer_input (h)) + { + lose ((ME, _("%s: Unexpected end of file."), h->fn)); + goto lossage; + } + memcpy (temp++, ext->ptr++, sizeof *temp); + if (temp >= temp_end) + goto winnage; + break; + case 254: + /* Code 254 indicates a string that is all blanks. */ + memset (temp++, ' ', sizeof *temp); + if (temp >= temp_end) + goto winnage; + break; + case 255: + /* Code 255 indicates the system-missing value. */ + *temp = ext->sysmis; + if (ext->reverse_endian) + bswap_flt64 (temp); + temp++; + if (temp >= temp_end) + goto winnage; + break; + default: + /* Codes 1 through 251 inclusive are taken to indicate a + value of (BYTE - BIAS), where BYTE is the byte's value + and BIAS is the compression bias (generally 100.0). */ + *temp = *p - ext->bias; + if (ext->reverse_endian) + bswap_flt64 (temp); + temp++; + if (temp >= temp_end) + goto winnage; + break; + } + + /* We have reached the end of this instruction octet. Read + another. */ + if (ext->ptr == NULL || ext->ptr >= ext->end) + if (!buffer_input (h)) + { + if (temp_beg != temp) + lose ((ME, _("%s: Unexpected end of file."), h->fn)); + goto lossage; + } + memcpy (ext->x, ext->ptr++, sizeof *temp); + p = ext->x; + } + + /* Not reached. */ + assert (0); + +winnage: + /* We have filled up an entire record. Update state and return + successfully. */ + ext->y = ++p; + return 1; + +lossage: + /* We have been unsuccessful at filling a record, either through i/o + error or through an end-of-file indication. Update state and + return unsuccessfully. */ + return 0; +} + +/* Reads one case from system file H into the value array PERM + according to the instructions given in associated dictionary DICT, + which must have the get.* elements appropriately set. Returns + nonzero only if successful. */ +int +sfm_read_case (struct file_handle * h, union value * perm, struct dictionary * dict) +{ + struct sfm_fhuser_ext *ext = h->ext; + + size_t nbytes; + flt64 *temp; + + int i; + + /* Make sure the caller remembered to finish polishing the + dictionary returned by sfm_read_dictionary(). */ + assert (dict->nval > 0); + + /* The first concern is to obtain a full case relative to the data + file. (Cases in the data file have no particular relationship to + cases in the active file.) */ + nbytes = sizeof *temp * ext->case_size; + temp = local_alloc (nbytes); + + if (ext->compressed == 0) + { + size_t amt = fread (temp, 1, nbytes, ext->file); + + if (amt != nbytes) + { + if (ferror (ext->file)) + msg (ME, _("%s: Reading system file: %s."), h->fn, strerror (errno)); + else if (amt != 0) + msg (ME, _("%s: Partial record at end of system file."), h->fn); + goto lossage; + } + } + else if (!read_compressed_data (h, temp)) + goto lossage; + + /* Translate a case in data file format to a case in active file + format. */ + for (i = 0; i < dict->nvar; i++) + { + struct variable *v = dict->var[i]; + + if (v->get.fv == -1) + continue; + + if (v->type == NUMERIC) + { + flt64 src = temp[v->get.fv]; + if (ext->reverse_endian) + bswap_flt64 (&src); + perm[v->fv].f = src == ext->sysmis ? SYSMIS : src; + } + else + memcpy (&perm[v->fv].s, &temp[v->get.fv], v->width); + } + + local_free (temp); + return 1; + +lossage: + local_free (temp); + return 0; +} + +static struct fh_ext_class sfm_r_class = +{ + 3, + N_("reading as a system file"), + sfm_close, +}; diff --git a/src/sfm-write.c b/src/sfm-write.c new file mode 100644 index 00000000..0e99013f --- /dev/null +++ b/src/sfm-write.c @@ -0,0 +1,756 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#if HAVE_UNISTD_H +#include /* Required by SunOS4. */ +#endif +#include "alloc.h" +#include "approx.h" +#include "avl.h" +#include "error.h" +#include "file-handle.h" +#include "getline.h" +#include "magic.h" +#include "misc.h" +#include "sfm.h" +#include "sfmP.h" +#include "str.h" +#include "var.h" +#include "version.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* PORTME: This file may require substantial revision for those + systems that don't meet the typical 32-bit integer/64-bit double + model. It's kinda hard to tell without having one of them on my + desk. */ + +/* Compression bias used by PSPP. Values between (1 - + COMPRESSION_BIAS) and (251 - COMPRESSION_BIAS) inclusive can be + compressed. */ +#define COMPRESSION_BIAS 100 + +/* sfm writer file_handle extension. */ +struct sfm_fhuser_ext + { + FILE *file; /* Actual file. */ + + int compressed; /* 1=compressed, 0=not compressed. */ + flt64 *buf; /* Buffered data. */ + flt64 *end; /* Buffer end. */ + flt64 *ptr; /* Current location in buffer. */ + unsigned char *x; /* Location in current instruction octet. */ + unsigned char *y; /* End of instruction octet. */ + int n_cases; /* Number of cases written so far. */ + + char *elem_type; /* ALPHA or NUMERIC for each flt64 element. */ + }; + +static struct fh_ext_class sfm_w_class; + +static char *append_string_max (char *, const char *, const char *); +static int write_header (struct sfm_write_info *inf); +static int bufwrite (struct file_handle *h, const void *buf, size_t nbytes); +static int write_variable (struct sfm_write_info *inf, struct variable *v); +static int write_value_labels (struct sfm_write_info *inf, struct variable * s, int index); +static int write_rec_7_34 (struct sfm_write_info *inf); +static int write_documents (struct sfm_write_info *inf); + +/* Writes the dictionary INF->dict to system file INF->h. The system + file is compressed if INF->compress is nonzero. INF->case_size is + set to the number of flt64 elements in a single case. Returns + nonzero only if successful. */ +int +sfm_write_dictionary (struct sfm_write_info *inf) +{ + struct dictionary *d = inf->dict; + struct sfm_fhuser_ext *ext; + int i; + int index; + + if (inf->h->class != NULL) + { + msg (ME, _("Cannot write file %s as system file: already opened for %s."), + fh_handle_name (inf->h), inf->h->class->name); + return 0; + } + + msg (VM (1), _("%s: Opening system-file handle %s for writing."), + fh_handle_filename (inf->h), fh_handle_name (inf->h)); + + /* Open the physical disk file. */ + inf->h->class = &sfm_w_class; + inf->h->ext = ext = xmalloc (sizeof (struct sfm_fhuser_ext)); + ext->file = fopen (inf->h->norm_fn, "wb"); + ext->elem_type = NULL; + if (ext->file == NULL) + { + msg (ME, _("An error occurred while opening \"%s\" for writing " + "as a system file: %s."), inf->h->fn, strerror (errno)); + err_cond_fail (); + free (ext); + return 0; + } + + /* Initialize the sfm_fhuser_ext structure. */ + ext->compressed = inf->compress; + ext->buf = ext->ptr = NULL; + ext->x = ext->y = NULL; + ext->n_cases = 0; + + /* Write the file header. */ + if (!write_header (inf)) + goto lossage; + + /* Write basic variable info. */ + for (i = 0; i < d->nvar; i++) + write_variable (inf, d->var[i]); + + /* Write out value labels. */ + for (index = i = 0; i < d->nvar; i++) + { + struct variable *v = d->var[i]; + + if (!write_value_labels (inf, v, index)) + goto lossage; + index += (v->type == NUMERIC ? 1 + : DIV_RND_UP (v->width, sizeof (flt64))); + } + + if (d->documents != NULL && !write_documents (inf)) + goto lossage; + if (!write_rec_7_34 (inf)) + goto lossage; + + /* Write record 999. */ + { + struct + { + int32 rec_type P; + int32 filler P; + } + rec_999; + + rec_999.rec_type = 999; + rec_999.filler = 0; + + if (!bufwrite (inf->h, &rec_999, sizeof rec_999)) + goto lossage; + } + + msg (VM (2), _("Wrote system-file header successfully.")); + + return 1; + +lossage: + msg (VM (1), _("Error writing system-file header.")); + fclose (ext->file); + inf->h->class = NULL; + inf->h->ext = NULL; + free (ext->elem_type); + ext->elem_type = NULL; + return 0; +} + +/* Returns value of X truncated to two least-significant digits. */ +static int +rerange (int x) +{ + if (x < 0) + x = -x; + if (x >= 100) + x %= 100; + return x; +} + +/* Write the sysfile_header header to the system file represented by + INF. */ +static int +write_header (struct sfm_write_info *inf) +{ + struct dictionary *d = inf->dict; + struct sfm_fhuser_ext *ext = inf->h->ext; + struct sysfile_header hdr; + char *p; + int i; + + time_t t; + + memcpy (hdr.rec_type, "$FL2", 4); + + p = stpcpy (hdr.prod_name, "@(#) SPSS DATA FILE "); + p = append_string_max (p, version, &hdr.prod_name[60]); + p = append_string_max (p, " - ", &hdr.prod_name[60]); + p = append_string_max (p, host_system, &hdr.prod_name[60]); + memset (p, ' ', &hdr.prod_name[60] - p); + + hdr.layout_code = 2; + + hdr.case_size = 0; + for (i = 0; i < d->nvar; i++) + { + struct variable *v = d->var[i]; + hdr.case_size += (v->type == NUMERIC ? 1 + : DIV_RND_UP (v->width, sizeof (flt64))); + } + inf->case_size = hdr.case_size; + + p = ext->elem_type = xmalloc (inf->case_size); + for (i = 0; i < d->nvar; i++) + { + struct variable *v = d->var[i]; + int count = (v->type == NUMERIC ? 1 + : DIV_RND_UP (v->width, sizeof (flt64))); + while (count--) + *p++ = v->type; + } + + hdr.compressed = inf->compress; + + update_weighting (d); + if (d->weight_index != -1) + { + int recalc_weight_index = 1; + + for (i = 0; i < d->weight_index; i++) + { + struct variable *v = d->var[i]; + recalc_weight_index += (v->type == NUMERIC ? 1 + : DIV_RND_UP (v->width, sizeof (flt64))); + } + hdr.weight_index = recalc_weight_index; + } + else + hdr.weight_index = 0; + + hdr.ncases = -1; + hdr.bias = COMPRESSION_BIAS; + + if ((time_t) - 1 == time (&t)) + { + memcpy (hdr.creation_date, "01 Jan 70", 9); + memcpy (hdr.creation_time, "00:00:00", 8); + } + else + { + static const char *month_name[12] = + { + "Jan", "Feb", "Mar", "Apr", "May", "Jun", + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec", + }; + struct tm *tmp = localtime (&t); + int day = rerange (tmp->tm_mday); + int mon = rerange (tmp->tm_mon + 1); + int year = rerange (tmp->tm_year); + int hour = rerange (tmp->tm_hour + 1); + int min = rerange (tmp->tm_min + 1); + int sec = rerange (tmp->tm_sec + 1); + char buf[10]; + + sprintf (buf, "%02d %s %02d", day, month_name[mon - 1], year); + memcpy (hdr.creation_date, buf, sizeof hdr.creation_date); + sprintf (buf, "%02d:%02d:%02d", hour - 1, min - 1, sec - 1); + memcpy (hdr.creation_time, buf, sizeof hdr.creation_time); + } + + st_bare_pad_copy (hdr.file_label, d->label ? d->label : "", + sizeof hdr.file_label); + memset (hdr.padding, 0, sizeof hdr.padding); + + if (!bufwrite (inf->h, &hdr, sizeof hdr)) + return 0; + return 1; +} + +/* Translates format spec from internal form in SRC to system file + format in DEST. */ +static inline void +write_format_spec (struct fmt_spec *src, int32 *dest) +{ + *dest = (formats[src->type].spss << 16) | (src->w << 8) | src->d; +} + +/* Write the variable record(s) for primary variable P and secondary + variable S to the system file represented by INF. */ +static int +write_variable (struct sfm_write_info *inf, struct variable *v) +{ + struct sysfile_variable sv; + + /* Missing values. */ + flt64 m[3]; /* Missing value values. */ + int nm; /* Number of missing values, possibly negative. */ + + sv.rec_type = 2; + sv.type = (v->type == NUMERIC ? 0 : v->width); + sv.has_var_label = (v->label != NULL); + + switch (v->miss_type) + { + case MISSING_NONE: + nm = 0; + break; + case MISSING_1: + case MISSING_2: + case MISSING_3: + for (nm = 0; nm < v->miss_type; nm++) + m[nm] = v->missing[nm].f; + break; + case MISSING_RANGE: + m[0] = v->missing[0].f; + m[1] = v->missing[1].f; + nm = -2; + break; + case MISSING_LOW: + m[0] = second_lowest_flt64; + m[1] = v->missing[0].f; + nm = -2; + break; + case MISSING_HIGH: + m[0] = v->missing[0].f; + m[1] = FLT64_MAX; + nm = -2; + break; + case MISSING_RANGE_1: + m[0] = v->missing[0].f; + m[1] = v->missing[1].f; + m[2] = v->missing[2].f; + nm = -3; + break; + case MISSING_LOW_1: + m[0] = second_lowest_flt64; + m[1] = v->missing[0].f; + m[2] = v->missing[1].f; + nm = -3; + break; + case MISSING_HIGH_1: + m[0] = v->missing[0].f; + m[1] = second_lowest_flt64; + m[2] = v->missing[1].f; + nm = -3; + break; + default: + assert (0); + } + + sv.n_missing_values = nm; + write_format_spec (&v->print, &sv.print); + write_format_spec (&v->write, &sv.write); + memcpy (sv.name, v->name, strlen (v->name)); + memset (&sv.name[strlen (v->name)], ' ', 8 - strlen (v->name)); + if (!bufwrite (inf->h, &sv, sizeof sv)) + return 0; + + if (v->label) + { + struct label + { + int32 label_len P; + char label[120] P; + } + l; + + int ext_len; + + l.label_len = min (strlen (v->label), 120); + ext_len = ROUND_UP (l.label_len, sizeof l.label_len); + memcpy (l.label, v->label, l.label_len); + memset (&l.label[l.label_len], ' ', ext_len - l.label_len); + + if (!bufwrite (inf->h, &l, offsetof (struct label, label) + ext_len)) + return 0; + } + + if (nm && !bufwrite (inf->h, m, sizeof *m * nm)) + return 0; + + if (v->type == ALPHA && v->width > (int) sizeof (flt64)) + { + int i; + int pad_count; + + sv.type = -1; + sv.has_var_label = 0; + sv.n_missing_values = 0; + memset (&sv.print, 0, sizeof sv.print); + memset (&sv.write, 0, sizeof sv.write); + memset (&sv.name, 0, sizeof sv.name); + + pad_count = DIV_RND_UP (v->width, (int) sizeof (flt64)) - 1; + for (i = 0; i < pad_count; i++) + if (!bufwrite (inf->h, &sv, sizeof sv)) + return 0; + } + + return 1; +} + +/* Writes the value labels for variable V having system file variable + index INDEX to the system file associated with INF. Returns + nonzero only if successful. */ +static int +write_value_labels (struct sfm_write_info * inf, struct variable *v, int index) +{ + struct value_label_rec + { + int32 rec_type P; + int32 n_labels P; + flt64 labels[1] P; + }; + + struct variable_index_rec + { + int32 rec_type P; + int32 n_vars P; + int32 vars[1] P; + }; + + avl_traverser i; + struct value_label_rec *vlr; + struct variable_index_rec vir; + struct value_label *vl; + size_t vlr_size; + flt64 *loc; + avl_traverser_init (i); + + if (v->val_lab == NULL || avl_count (v->val_lab) == 0) + return 1; + + /* Pass 1: Count bytes. */ + vlr_size = (sizeof (struct value_label_rec) + + sizeof (flt64) * (avl_count (v->val_lab) - 1)); + while (NULL != (vl = avl_traverse (v->val_lab, &i))) + vlr_size += ROUND_UP (strlen (vl->s) + 1, sizeof (flt64)); + + /* Pass 2: Copy bytes. */ + vlr = local_alloc (vlr_size); + vlr->rec_type = 3; + vlr->n_labels = avl_count (v->val_lab); + loc = vlr->labels; + while (NULL != (vl = avl_traverse (v->val_lab, &i))) + { + int len = strlen (vl->s); + + *loc++ = vl->v.f; + *(unsigned char *) loc = len; + memcpy (&((unsigned char *) loc)[1], vl->s, len); + memset (&((unsigned char *) loc)[1 + len], ' ', + REM_RND_UP (len + 1, sizeof (flt64))); + loc += DIV_RND_UP (len + 1, sizeof (flt64)); + } + + if (!bufwrite (inf->h, vlr, vlr_size)) + { + local_free (vlr); + return 0; + } + local_free (vlr); + + vir.rec_type = 4; + vir.n_vars = 1; + vir.vars[0] = index + 1; + if (!bufwrite (inf->h, &vir, sizeof vir)) + return 0; + + return 1; +} + +/* Writes record type 6, document record. */ +static int +write_documents (struct sfm_write_info * inf) +{ + struct dictionary *d = inf->dict; + struct + { + int32 rec_type P; /* Always 6. */ + int32 n_lines P; /* Number of lines of documents. */ + } + rec_6; + + rec_6.rec_type = 6; + rec_6.n_lines = d->n_documents; + if (!bufwrite (inf->h, &rec_6, sizeof rec_6)) + return 0; + if (!bufwrite (inf->h, d->documents, 80 * d->n_documents)) + return 0; + + return 1; +} + +/* Writes record type 7, subtypes 3 and 4. */ +static int +write_rec_7_34 (struct sfm_write_info * inf) +{ + struct + { + int32 rec_type_3 P; + int32 subtype_3 P; + int32 data_type_3 P; + int32 n_elem_3 P; + int32 elem_3[8] P; + int32 rec_type_4 P; + int32 subtype_4 P; + int32 data_type_4 P; + int32 n_elem_4 P; + flt64 elem_4[3] P; + } + rec_7; + + /* Components of the version number, from major to minor. */ + int version_component[3]; + + /* Used to step through the version string. */ + char *p; + + /* Parses the version string, which is assumed to be of the form + #.#x, where each # is a string of digits, and x is a single + letter. */ + version_component[0] = strtol (bare_version, &p, 10); + if (*p == '.') + p++; + version_component[1] = strtol (bare_version, &p, 10); + version_component[2] = (isalpha ((unsigned char) *p) + ? tolower ((unsigned char) *p) - 'a' : 0); + + rec_7.rec_type_3 = 7; + rec_7.subtype_3 = 3; + rec_7.data_type_3 = sizeof (int32); + rec_7.n_elem_3 = 8; + rec_7.elem_3[0] = version_component[0]; + rec_7.elem_3[1] = version_component[1]; + rec_7.elem_3[2] = version_component[2]; + rec_7.elem_3[3] = -1; + + /* PORTME: 1=IEEE754, 2=IBM 370, 3=DEC VAX E. */ +#if FPREP==FPREP_IEEE754 + rec_7.elem_3[4] = 1; +#else +#error Floating-point representation unknown here. +#endif + + rec_7.elem_3[5] = 1; + + /* PORTME: 1=big-endian, 2=little-endian. */ + if (endian == BIG) + rec_7.elem_3[6] = 1; + else if (endian == LITTLE) + rec_7.elem_3[6] = 2; + else + rec_7.elem_3[6] = 0; + + /* PORTME: 1=EBCDIC, 2=7-bit ASCII, 3=8-bit ASCII, 4=DEC Kanji. */ + rec_7.elem_3[7] = 2; + + rec_7.rec_type_4 = 7; + rec_7.subtype_4 = 4; + rec_7.data_type_4 = sizeof (flt64); + rec_7.n_elem_4 = 3; + rec_7.elem_4[0] = -FLT64_MAX; + rec_7.elem_4[1] = FLT64_MAX; + rec_7.elem_4[2] = second_lowest_flt64; + + if (!bufwrite (inf->h, &rec_7, sizeof rec_7)) + return 0; + return 1; +} + +/* Write NBYTES starting at BUF to the system file represented by + H. */ +static int +bufwrite (struct file_handle * h, const void *buf, size_t nbytes) +{ + struct sfm_fhuser_ext *ext = h->ext; + + assert (buf); + if (1 != fwrite (buf, nbytes, 1, ext->file)) + { + msg (ME, _("%s: Writing system file: %s."), h->fn, strerror (errno)); + return 0; + } + return 1; +} + +/* Copies string DEST to SRC with the proviso that DEST does not reach + byte END; no null terminator is copied. Returns a pointer to the + byte after the last byte copied. */ +static char * +append_string_max (char *dest, const char *src, const char *end) +{ + int nbytes = min (end - dest, (int) strlen (src)); + memcpy (dest, src, nbytes); + return dest + nbytes; +} + +/* Makes certain that the compression buffer of H has room for another + element. If there's not room, pads out the current instruction + octet with zero and dumps out the buffer. */ +static inline int +ensure_buf_space (struct file_handle *h) +{ + struct sfm_fhuser_ext *ext = h->ext; + + if (ext->ptr >= ext->end) + { + memset (ext->x, 0, ext->y - ext->x); + ext->x = ext->y; + ext->ptr = ext->buf; + if (!bufwrite (h, ext->buf, sizeof *ext->buf * 128)) + return 0; + } + return 1; +} + +/* Writes case ELEM consisting of N_ELEM flt64 elements to the system + file represented by H. Return success. */ +int +sfm_write_case (struct file_handle * h, const flt64 *elem, int n_elem) +{ + struct sfm_fhuser_ext *ext = h->ext; + const flt64 *end_elem = &elem[n_elem]; + char *elem_type = ext->elem_type; + + ext->n_cases++; + + if (ext->compressed == 0) + return bufwrite (h, elem, sizeof *elem * n_elem); + + if (ext->buf == NULL) + { + ext->buf = xmalloc (sizeof *ext->buf * 128); + ext->ptr = ext->buf; + ext->end = &ext->buf[128]; + ext->x = (unsigned char *) (ext->ptr++); + ext->y = (unsigned char *) (ext->ptr); + } + for (; elem < end_elem; elem++, elem_type++) + { + if (ext->x >= ext->y) + { + if (!ensure_buf_space (h)) + return 0; + ext->x = (unsigned char *) (ext->ptr++); + ext->y = (unsigned char *) (ext->ptr); + } + + if (*elem_type == NUMERIC) + { + if (*elem == -FLT64_MAX) + { + *ext->x++ = 255; + continue; + } + else + { + int value = *elem < 0 ? *elem - EPSILON : *elem + EPSILON; + + if (value >= 1 - COMPRESSION_BIAS + && value <= 251 - COMPRESSION_BIAS + && approx_eq (value, *elem)) + { + *ext->x++ = value + COMPRESSION_BIAS; + continue; + } + } + } + else + { + if (0 == memcmp ((char *) elem, + " ", + sizeof (flt64))) + { + *ext->x++ = 254; + continue; + } + } + + *ext->x++ = 253; + if (!ensure_buf_space (h)) + return 0; + *ext->ptr++ = *elem; + } + + return 1; +} + +/* Closes a system file after we're done with it. */ +static void +sfm_close (struct file_handle * h) +{ + struct sfm_fhuser_ext *ext = h->ext; + + if (ext->buf != NULL && ext->ptr > ext->buf) + { + memset (ext->x, 0, ext->y - ext->x); + bufwrite (h, ext->buf, (ext->ptr - ext->buf) * sizeof *ext->buf); + } + + /* Attempt to seek back to the beginning in order to write the + number of cases. If that's not possible (i.e., we're writing to + a tty or a pipe), then it's not a big deal because we wrote the + code that indicates an unknown number of cases. */ + if (0 == fseek (ext->file, offsetof (struct sysfile_header, ncases), + SEEK_SET)) + { + int32 n_cases = ext->n_cases; + + /* I don't really care about the return value: it doesn't matter + whether this data is written. This is the only situation in + which you will see me fail to check a return value. */ + fwrite (&n_cases, sizeof n_cases, 1, ext->file); + } + + if (EOF == fclose (ext->file)) + msg (ME, _("%s: Closing system file: %s."), h->fn, strerror (errno)); + free (ext->buf); + + free (ext->elem_type); + free (ext); +} + +static struct fh_ext_class sfm_w_class = +{ + 4, + N_("writing as a system file"), + sfm_close, +}; diff --git a/src/sfm.h b/src/sfm.h new file mode 100644 index 00000000..6b3f6a1b --- /dev/null +++ b/src/sfm.h @@ -0,0 +1,66 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !sfm_h +#define sfm_h 1 + +/* System file manager (sfm). + + This module is in charge of reading and writing system files. For + now, only ordinary system files are supported; in the future, PC+ + compatible system files should be supported, too. sfm is an + fhuser, so see file-handle.h for the fhuser interface. */ + +/* Information produced by sfm_read_dictionary() that doesn't fit into + a dictionary struct. */ +struct sfm_read_info + { + char creation_date[10]; /* `dd mmm yy' plus a null. */ + char creation_time[9]; /* `hh:mm:ss' plus a null. */ + int endianness; /* BIG or LITTLE. */ + int compressed; /* 0=no, 1=yes. */ + int ncases; /* -1 if unknown. */ + char product[61]; /* Product name plus a null. */ + }; + +struct dictionary; +struct file_handle; +union value; + +struct dictionary *sfm_read_dictionary (struct file_handle *, + struct sfm_read_info *); +int sfm_read_case (struct file_handle *, union value *, struct dictionary *); +void sfm_maybe_close (struct file_handle *); + +/* Information needed by sfm_write_dictionary(). */ +struct sfm_write_info + { + /* Read by sfm_write_dictionary(). */ + struct file_handle *h; /* File handle. */ + struct dictionary *dict; /* Primary dictionary. */ + int compress; /* 1=compress, 0=do not compress. */ + + /* Written by sfm_write_dictionary(). */ + int case_size; /* Number of flt64 elements per case. */ + }; + +int sfm_write_dictionary (struct sfm_write_info *); +int sfm_write_case (struct file_handle *, const flt64* elem, int n_elem); + +#endif /* !sfm_h */ diff --git a/src/sfmP.h b/src/sfmP.h new file mode 100644 index 00000000..d03ba042 --- /dev/null +++ b/src/sfmP.h @@ -0,0 +1,63 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* PORTME: There might easily be alignment problems with some of these + structures. */ + +/* This attribute might avoid some problems. On the other hand... */ +#define P __attribute__((packed)) + +#if __BORLANDC__ +#pragma option -a- /* Turn off alignment. */ +#endif + +/* Record Type 1: General Information. */ +struct sysfile_header + { + char rec_type[4] P; /* Record-type code, "$FL2". */ + char prod_name[60] P; /* Product identification. */ + int32 layout_code P; /* 2. */ + int32 case_size P; /* Number of `value's per case. */ + int32 compressed P; /* 1=compressed, 0=not compressed. */ + int32 weight_index P; /* 1-based index of weighting var, or zero. */ + int32 ncases P; /* Number of cases, -1 if unknown. */ + flt64 bias P; /* Compression bias (100.0). */ + char creation_date[9] P; /* `dd mmm yy' creation date of file. */ + char creation_time[8] P; /* `hh:mm:ss' 24-hour creation time. */ + char file_label[64] P; /* File label. */ + char padding[3] P; /* Ignored padding. */ + }; + +/* Record Type 2: Variable. */ +struct sysfile_variable + { + int32 rec_type P; /* 2. */ + int32 type P; /* 0=numeric, 1-255=string width, + -1=continued string. */ + int32 has_var_label P; /* 1=has a variable label, 0=doesn't. */ + int32 n_missing_values P; /* Missing value code of -3,-2,0,1,2, or 3. */ + int32 print P; /* Print format. */ + int32 write P; /* Write format. */ + char name[8] P; /* Variable name. */ + /* The rest of the structure varies. */ + }; + +#if __BORLANDC__ +#pragma -a4 +#endif diff --git a/src/som.c b/src/som.c new file mode 100644 index 00000000..dde12b5f --- /dev/null +++ b/src/som.c @@ -0,0 +1,275 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "output.h" +#include "som.h" +/*#undef DEBUGGING*/ +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* Table. */ +int table_num = 1; +int subtable_num; + +/* Increments table_num so different procedures' output can be + distinguished. */ +void +som_new_series (void) +{ + if (subtable_num != 0) + { + table_num++; + subtable_num = 0; + } +} + +/* Ejects the paper for all active devices. */ +void +som_eject_page (void) +{ + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + outp_eject_page (d); +} + +/* Skip down a single line on all active devices. */ +void +som_blank_line (void) +{ + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + if (d->page_open && d->cp_y != 0) + d->cp_y += d->font_height; +} + +/* Driver. */ +struct outp_driver *d; + +/* Table. */ +struct som_table *t; + +/* Flags. */ +static unsigned flags; + +/* Number of columns, rows. */ +static int nc, nr; + +/* Number of columns or rows in left, right, top, bottom headers. */ +static int hl, hr, ht, hb; + +/* Column style. */ +static int cs; + +/* Table height, width. */ +static int th, tw; + +static void render_columns (void); +static void render_simple (void); +static void render_segments (void); + +static void output_table (struct outp_driver *, struct som_table *); + +/* Output table T to appropriate output devices. */ +void +som_submit (struct som_table *t) +{ +#if GLOBAL_DEBUGGING + static int entry; + + assert (entry++ == 0); +#endif + + t->class->table (t); + t->class->flags (&flags); + t->class->count (&nc, &nr); + t->class->headers (&hl, &hr, &ht, &hb); + +#if GLOBAL_DEBUGGING + if (hl + hr > nc || ht + hb > nr) + { + printf ("headers: (l,r)=(%d,%d), (t,b)=(%d,%d) in table size (%d,%d)\n", + hl, hr, ht, hb, nc, nr); + abort (); + } + else if (hl + hr == nc) + printf ("warning: headers (l,r)=(%d,%d) in table width %d\n", hl, hr, nc); + else if (ht + hb == nr) + printf ("warning: headers (t,b)=(%d,%d) in table height %d\n", ht, hb, nr); +#endif + + t->class->columns (&cs); + + if (!(flags & SOMF_NO_TITLE)) + subtable_num++; + + { + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + output_table (d, t); + } + +#if GLOBAL_DEBUGGING + assert (--entry == 0); +#endif +} + +/* Output table TABLE to driver DRIVER. */ +static void +output_table (struct outp_driver *driver, struct som_table *table) +{ + d = driver; + t = table; + + assert (d->driver_open); + if (!d->page_open && !d->class->open_page (d)) + { + d->device = OUTP_DEV_DISABLED; + return; + } + + if (d->class->special) + { + driver->class->submit (d, t); + return; + } + + t->class->driver (d); + t->class->area (&tw, &th); + + if (!(flags & SOMF_NO_SPACING) && d->cp_y != 0) + d->cp_y += d->font_height; + + if (cs != SOM_COL_NONE + && 2 * (tw + d->prop_em_width) <= d->width + && nr - (ht + hb) > 5) + render_columns (); + else if (tw < d->width && th + d->cp_y < d->length) + render_simple (); + else + render_segments (); +} + +/* Render the table into multiple columns. */ +static void +render_columns (void) +{ + int y0, y1; + int max_len = 0; + int index = 0; + + assert (cs == SOM_COL_DOWN); + assert (d->cp_x == 0); + + for (y0 = ht; y0 < nr - hb; y0 = y1) + { + int len; + + t->class->cumulate (SOM_ROWS, y0, &y1, d->length - d->cp_y, &len); + + if (y0 == y1) + { + assert (d->cp_y); + outp_eject_page (d); + } else { + if (len > max_len) + max_len = len; + + t->class->title (index++, 0); + t->class->render (0, y0, nc, y1); + + d->cp_x += tw + 2 * d->prop_em_width; + if (d->cp_x + tw > d->width) + { + d->cp_x = 0; + d->cp_y += max_len; + max_len = 0; + } + } + } + + if (d->cp_x > 0) + { + d->cp_x = 0; + d->cp_y += max_len; + } +} + +/* Render the table by itself on the current page. */ +static void +render_simple (void) +{ + assert (d->cp_x == 0); + assert (tw < d->width && th + d->cp_y < d->length); + + t->class->title (0, 0); + t->class->render (hl, ht, nc - hr, nr - hb); + d->cp_y += th; +} + +/* General table breaking routine. */ +static void +render_segments (void) +{ + int count = 0; + + int x_index; + int x0, x1; + + assert (d->cp_x == 0); + + for (x_index = 0, x0 = hl; x0 < nc - hr; x0 = x1, x_index++) + { + int y_index; + int y0, y1; + + t->class->cumulate (SOM_COLUMNS, x0, &x1, d->width, NULL); + if (x_index == 0 && x1 != nc - hr) + x_index++; + + for (y_index = 0, y0 = ht; y0 < nr - hb; y0 = y1, y_index++) + { + int len; + + if (count++ != 0 && d->cp_y != 0) + d->cp_y += d->font_height; + + t->class->cumulate (SOM_ROWS, y0, &y1, d->length - d->cp_y, &len); + if (y_index == 0 && y1 != nr - hb) + y_index++; + + if (y0 == y1) + { + assert (d->cp_y); + outp_eject_page (d); + } else { + t->class->title (x_index ? x_index : y_index, + x_index ? y_index : 0); + t->class->render (x0, y0, x1, y1); + + d->cp_y += len; + } + } + } +} diff --git a/src/som.h b/src/som.h new file mode 100644 index 00000000..9ac69c86 --- /dev/null +++ b/src/som.h @@ -0,0 +1,109 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !som_h +#define som_h 1 + +/* Structured Output Manager. + + som considers the output stream to be a series of tables. Each + table is made up of a rectangular grid of cells. Cells can be + joined to form larger cells. Rows and columns can be separated by + rules of various types. Tables too large to fit on a single page + will be divided into sections. Rows and columns can be designated + as headers, which causes them to be repeated in each section. + + Every table is an instance of a particular table class. A table + class is responsible for keeping track of cell data, for handling + requests from the som, and finally for rendering cell data to the + output drivers. Tables may implement these operations in any way + desired, and in fact almost every operation performed by som may be + overridden in a table class. */ + +/* Table. */ +struct som_table + { + struct som_table_class *class; /* Table class. */ + void *ext; /* Owned by table class. */ + }; + +/* Group styles. */ +enum + { + SOM_COL_NONE, /* No columns. */ + SOM_COL_DOWN /* Columns down first. */ + }; + +/* Cumulation types. */ +enum + { + SOM_ROWS, SOM_ROW = SOM_ROWS, /* Rows. */ + SOM_COLUMNS, SOM_COLUMN = SOM_COLUMNS /* Columns. */ + }; + +/* Flags. */ +enum + { + SOMF_NONE = 0, + SOMF_NO_SPACING = 01, /* No spacing before the table. */ + SOMF_NO_TITLE = 02 /* No title. */ + }; + +/* Table class. */ +struct outp_driver; +struct som_table_class + { + /* Set table, driver. */ + void (*table) (struct som_table *); + void (*driver) (struct outp_driver *); + + /* Query columns and rows. */ + void (*count) (int *n_columns, int *n_rows); + void (*area) (int *horiz, int *vert); + void (*width) (int *columns); + void (*height) (int *rows); + void (*columns) (int *style); + int (*breakable) (int row); /* ? */ + void (*headers) (int *l, int *r, int *t, int *b); + void (*join) (int *(column[2]), int *(row[2])); /* ? */ + void (*cumulate) (int cumtype, int start, int *end, int max, int *actual); + void (*flags) (unsigned *); + + /* Set columns and rows. */ + void (*set_width) (int column, int width); /* ? */ + void (*set_height) (int row, int height); /* ? */ + + /* Rendering. */ + void (*title) (int x, int y); + void (*render) (int x1, int y1, int x2, int y2); + }; + +/* Table indexes. */ +extern int table_num; +extern int subtable_num; + +/* Submission. */ +void som_new_series (void); +void som_submit (struct som_table *t); + +/* Miscellaneous. */ +void som_eject_page (void); +void som_blank_line (void); + +#endif /* som_h */ diff --git a/src/sort.c b/src/sort.c new file mode 100644 index 00000000..e5feef94 --- /dev/null +++ b/src/sort.c @@ -0,0 +1,1385 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "command.h" +#include "error.h" +#include "expr.h" +#include "heap.h" +#include "lexer.h" +#include "misc.h" +#include "sort.h" +#include "str.h" +#include "var.h" +#include "vfm.h" +#include "vfmP.h" + +#if HAVE_UNISTD_H +#include +#endif + +#if HAVE_SYS_TYPES_H +#include +#endif + +#if HAVE_SYS_STAT_H +#include +#endif + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +/* Variables to sort. */ +struct variable **v_sort; +int nv_sort; + +/* Used when internal-sorting to a separate file. */ +static struct case_list **separate_case_tab; + +/* Exported by qsort.c. */ +void blp_quicksort (void *pbase, size_t total_elems, size_t size, + int (*cmp) (const void *, const void *), + void *temp_buf); + +/* Other prototypes. */ +static int compare_case_lists (const void *, const void *); +static int do_internal_sort (int separate); +static int do_external_sort (int separate); +int parse_sort_variables (void); +void read_sort_output (int (*write_case) (void)); + +/* Performs the SORT CASES procedures. */ +int +cmd_sort_cases (void) +{ + /* First, just parse the command. */ + lex_match_id ("SORT"); + lex_match_id ("CASES"); + lex_match (T_BY); + + if (!parse_sort_variables ()) + return CMD_FAILURE; + + cancel_temporary (); + + /* Then it's time to do the actual work. There are two cases: + + (internal sort) All the data is in memory. In this case, we + perform an EXECUTE to get the data into the desired form, then + sort the cases in place, if it is still all in memory. + + (external sort) The data is not in memory. It may be coming from + a system file or other data file, etc. In any case, it is now + time to perform an external sort. This is better explained in + do_external_sort(). */ + + /* Do all this dirty work. */ + { + int success = sort_cases (0); + free (v_sort); + if (success) + return lex_end_of_command (); + else + return CMD_FAILURE; + } +} + +/* Parses a list of sort variables into v_sort and nv_sort. */ +int +parse_sort_variables (void) +{ + v_sort = NULL; + nv_sort = 0; + do + { + int prev_nv_sort = nv_sort; + int order = SRT_ASCEND; + + if (!parse_variables (&default_dict, &v_sort, &nv_sort, + PV_NO_DUPLICATE | PV_APPEND | PV_NO_SCRATCH)) + return 0; + if (lex_match ('(')) + { + if (lex_match_id ("D") || lex_match_id ("DOWN")) + order = SRT_DESCEND; + else if (!lex_match_id ("A") && !lex_match_id ("UP")) + { + free (v_sort); + msg (SE, _("`A' or `D' expected inside parentheses.")); + return 0; + } + if (!lex_match (')')) + { + free (v_sort); + msg (SE, _("`)' expected.")); + return 0; + } + } + for (; prev_nv_sort < nv_sort; prev_nv_sort++) + v_sort[prev_nv_sort]->p.srt.order = order; + } + while (token != '.' && token != '/'); + + return 1; +} + +/* Sorts the active file based on the key variables specified in + global variables v_sort and nv_sort. The output is either to the + active file, if SEPARATE is zero, or to a separate file, if + SEPARATE is nonzero. In the latter case the output cases can be + read with a call to read_sort_output(). (In the former case the + output cases should be dealt with through the usual vfm interface.) + + The caller is responsible for freeing v_sort[]. */ +int +sort_cases (int separate) +{ + assert (separate_case_tab == NULL); + + /* Not sure this is necessary but it's good to be safe. */ + if (separate && vfm_source == &sort_stream) + procedure (NULL, NULL, NULL); + + /* SORT CASES cancels PROCESS IF. */ + expr_free (process_if_expr); + process_if_expr = NULL; + + if (do_internal_sort (separate)) + return 1; + + page_to_disk (); + return do_external_sort (separate); +} + +/* If a reasonable situation is set up, do an internal sort of the + data. Return success. */ +static int +do_internal_sort (int separate) +{ + if (vfm_source != &vfm_disk_stream) + { + if (vfm_source != &vfm_memory_stream) + procedure (NULL, NULL, NULL); + if (vfm_source == &vfm_memory_stream) + { + struct case_list **case_tab = malloc (sizeof *case_tab + * (vfm_source_info.ncases + 1)); + if (vfm_source_info.ncases == 0) + { + free (case_tab); + return 1; + } + if (case_tab != NULL) + { + struct case_list *clp = memory_source_cases; + struct case_list **ctp = case_tab; + int i; + + for (; clp; clp = clp->next) + *ctp++ = clp; + qsort (case_tab, vfm_source_info.ncases, sizeof *case_tab, + compare_case_lists); + + if (!separate) + { + memory_source_cases = case_tab[0]; + for (i = 1; i < vfm_source_info.ncases; i++) + case_tab[i - 1]->next = case_tab[i]; + case_tab[vfm_source_info.ncases - 1]->next = NULL; + free (case_tab); + } else { + case_tab[vfm_source_info.ncases] = NULL; + separate_case_tab = case_tab; + } + + return 1; + } + } + } + return 0; +} + +/* Compares the NV_SORT variables in V_SORT[] between the `case_list's + at _A and _B, and returns a strcmp()-type result. */ +static int +compare_case_lists (const void *pa, const void *pb) +{ + struct case_list *a = *(struct case_list **) pa; + struct case_list *b = *(struct case_list **) pb; + struct variable *v; + int result = 0; + int i; + + for (i = 0; i < nv_sort; i++) + { + v = v_sort[i]; + + if (v->type == NUMERIC) + { + if (approx_ne (a->c.data[v->fv].f, b->c.data[v->fv].f)) + { + result = (a->c.data[v->fv].f > b->c.data[v->fv].f) ? 1 : -1; + break; + } + } + else + { + result = memcmp (a->c.data[v->fv].s, b->c.data[v->fv].s, v->width); + if (result != 0) + break; + } + } + + if (v->p.srt.order == SRT_ASCEND) + return result; + else + { + assert (v->p.srt.order == SRT_DESCEND); + return -result; + } +} + +/* External sort. */ + +/* Maximum number of input + output file handles. */ +#if defined FOPEN_MAX && (FOPEN_MAX - 5 < 18) +#define MAX_FILE_HANDLES (FOPEN_MAX - 5) +#else +#define MAX_FILE_HANDLES 18 +#endif + +#if MAX_FILE_HANDLES < 3 +#error At least 3 file handles must be available for sorting. +#endif + +/* Number of input buffers. */ +#define N_INPUT_BUFFERS (MAX_FILE_HANDLES - 1) + +/* Maximum order of merge. This is the value suggested by Knuth; + specifically, he said to use tree selection, which we don't + implement, for larger orders of merge. */ +#define MAX_MERGE_ORDER 7 + +/* Minimum total number of records for buffers. */ +#define MIN_BUFFER_TOTAL_SIZE_RECS 64 + +/* Minimum single input or output buffer size, in bytes and records. */ +#define MIN_BUFFER_SIZE_BYTES 4096 +#define MIN_BUFFER_SIZE_RECS 16 + +/* Structure for replacement selection tree. */ +struct repl_sel_tree + { + struct repl_sel_tree *loser;/* Loser associated w/this internal node. */ + int rn; /* Run number of `loser'. */ + struct repl_sel_tree *fe; /* Internal node above this external node. */ + struct repl_sel_tree *fi; /* Internal node above this internal node. */ + union value record[1]; /* The case proper. */ + }; + +/* Static variables used for sorting. */ +static struct repl_sel_tree **x; /* Buffers. */ +static int x_max; /* Size of buffers, in records. */ +static int records_per_buffer; /* Number of records in each buffer. */ + +/* In the merge phase, the first N_INPUT_BUFFERS handle[] elements are + input files and the last element is the output file. Before that, + they're all used as output files, although the last one is + segregated. */ +static FILE *handle[MAX_FILE_HANDLES]; /* File handles. */ + +/* Now, MAX_FILE_HANDLES is the maximum number of files we will *try* + to open. But if we can't open that many, max_handles will be set + to the number we apparently can open. */ +static int max_handles; /* Maximum number of handles. */ + +/* When we create temporary files, they are all put in the same + directory and numbered sequentially from zero. tmp_basename is the + drive/directory, etc., and tmp_extname can be sprintf() with "%08x" + to the file number, then tmp_basename used to open the file. */ +static char *tmp_basename; /* Temporary file basename. */ +static char *tmp_extname; /* Temporary file extension name. */ + +/* We use Huffman's method to determine the merge pattern. This means + that we need to know which runs are the shortest at any given time. + Priority queues as implemented by heap.c are a natural for this + task (probably because I wrote the code specifically for it). */ +static struct heap *huffman_queue; /* Huffman priority queue. */ + +/* Prototypes for helper functions. */ +static void sort_stream_write (void); +static int write_initial_runs (int separate); +static int allocate_cases (void); +static int allocate_file_handles (void); +static int merge (void); +static void rmdir_temp_dir (void); + +/* Performs an external sort of the active file. A description of the + procedure follows. All page references refer to Knuth's _Art of + Computer Programming, Vol. 3: Sorting and Searching_, which is the + canonical resource for sorting. + + 1. The data is read and S initial runs are formed through the + action of algorithm 5.4.1R (replacement selection). + + 2. Huffman's method (p. 365-366) is used to determine the optimum + merge pattern. + + 3. If an OS that supports overlapped reading, writing, and + computing is being run, we should use 5.4.6F for forecasting. + Otherwise, buffers are filled only when they run out of data. + FIXME: Since the author of PSPP uses GNU/Linux, which does not + yet implement overlapped r/w/c, 5.4.6F is not used. + + 4. We perform P-way merges: + + (a) The desired P is the smallest P such that ceil(ln(S)/ln(P)) + is minimized. (FIXME: Since I don't have an algorithm for + minimizing this, it's just set to MAX_MERGE_ORDER.) + + (b) P is reduced if the selected value would make input buffers + less than 4096 bytes each, or 16 records, whichever is larger. + + (c) P is reduced if we run out of available file handles or space + for file handles. + + (d) P is reduced if we don't have space for one or two output + buffers, which have the same minimum size as input buffers. (We + need two output buffers if 5.4.6F is in use for forecasting.) */ +static int +do_external_sort (int separate) +{ + int success = 0; + + assert (MAX_FILE_HANDLES >= 3); + + x = NULL; + tmp_basename = NULL; + + huffman_queue = heap_create (512); + if (huffman_queue == NULL) + return 0; + + if (!allocate_cases ()) + goto lossage; + + if (!allocate_file_handles ()) + goto lossage; + + if (!write_initial_runs (separate)) + goto lossage; + + merge (); + + success = 1; + + /* Despite the name, flow of control comes here regardless of + whether or not the sort is successful. */ +lossage: + heap_destroy (huffman_queue); + + if (x) + { + int i; + + for (i = 0; i <= x_max; i++) + free (x[i]); + free (x); + } + + if (!success) + rmdir_temp_dir (); + + return success; +} + +#if !HAVE_GETPID +#define getpid() (0) +#endif + +/* Sets up to open temporary files. */ +/* PORTME: This creates a directory for temporary files. Some OSes + might not have that concept... */ +static int +allocate_file_handles (void) +{ + const char *dir; /* Directory prefix. */ + char *buf; /* String buffer. */ + char *cp; /* Pointer into buf. */ + + dir = getenv ("SPSSTMPDIR"); + if (dir == NULL) + dir = getenv ("SPSSXTMPDIR"); + if (dir == NULL) + dir = getenv ("TMPDIR"); +#ifdef P_tmpdir + if (dir == NULL) + dir = P_tmpdir; +#endif +#if __unix__ + if (dir == NULL) + dir = "/tmp"; +#elif __MSDOS__ + if (dir == NULL) + dir = getenv ("TEMP"); + if (dir == NULL) + dir = getenv ("TMP"); + if (dir == NULL) + dir = "\\"; +#else + dir = ""; +#endif + + buf = xmalloc (strlen (dir) + 1 + 4 + 8 + 4 + 1 + INT_DIGITS + 1); + cp = spprintf (buf, "%s%c%04lX%04lXpspp", dir, DIR_SEPARATOR, + ((long) time (0)) & 0xffff, ((long) getpid ()) & 0xffff); + if (-1 == mkdir (buf, S_IRWXU)) + { + free (buf); + msg (SE, _("%s: Cannot create temporary directory: %s."), + buf, strerror (errno)); + return 0; + } + *cp++ = DIR_SEPARATOR; + + tmp_basename = buf; + tmp_extname = cp; + + max_handles = MAX_FILE_HANDLES; + + return 1; +} + +/* Removes the directory created for temporary files, if one exists. + Also frees tmp_basename. */ +static void +rmdir_temp_dir (void) +{ + if (NULL == tmp_basename) + return; + + tmp_extname[-1] = '\0'; + if (rmdir (tmp_basename) == -1) + msg (SE, _("%s: Error removing directory for temporary files: %s."), + tmp_basename, strerror (errno)); + + free (tmp_basename); +} + +/* Allocates room for lots of cases as a buffer. */ +static int +allocate_cases (void) +{ + /* This is the size of one case. */ + const int case_size = (sizeof (struct repl_sel_tree) + + sizeof (union value) * (default_dict.nval - 1) + + sizeof (struct repl_sel_tree *)); + + x = NULL; + + /* Allocate as many cases as we can, assuming a space of four + void pointers for malloc()'s internal bookkeeping. */ + x_max = MAX_WORKSPACE / (case_size + 4 * sizeof (void *)); + x = malloc (sizeof (struct repl_sel_tree *) * x_max); + if (x != NULL) + { + int i; + + for (i = 0; i < x_max; i++) + { + x[i] = malloc (sizeof (struct repl_sel_tree) + + sizeof (union value) * (default_dict.nval - 1)); + if (x[i] == NULL) + break; + } + x_max = i; + } + if (x == NULL || x_max < MIN_BUFFER_TOTAL_SIZE_RECS) + { + if (x != NULL) + { + int i; + + for (i = 0; i < x_max; i++) + free (x[i]); + } + free (x); + msg (SE, _("Out of memory. Could not allocate room for minimum of %d " + "cases of %d bytes each. (PSPP workspace is currently " + "restricted to a maximum of %d KB.)"), + MIN_BUFFER_TOTAL_SIZE_RECS, case_size, MAX_WORKSPACE / 1024); + x_max = 0; + x = NULL; + return 0; + } + + /* The last element of the array is used to store lastkey. */ + x_max--; + + debug_printf ((_("allocated %d cases == %d bytes\n"), + x_max, x_max * case_size)); + return 1; +} + +/* Replacement selection. */ + +static int rmax, rc, rq; +static struct repl_sel_tree *q; +static union value *lastkey; +static int run_no, file_index; +static int deferred_abort; +static int run_length; + +static int compare_record (union value *, union value *); + +static inline void +output_record (union value *v) +{ + union value *src_case; + + if (deferred_abort) + return; + + if (compaction_necessary) + { + compact_case (compaction_case, (struct ccase *) v); + src_case = (union value *) compaction_case; + } + else + src_case = (union value *) v; + + if ((int) fwrite (src_case, sizeof *src_case, compaction_nval, + handle[file_index]) + != compaction_nval) + { + deferred_abort = 1; + sprintf (tmp_extname, "%08x", run_no); + msg (SE, _("%s: Error writing temporary file: %s."), + tmp_basename, strerror (errno)); + return; + } + + run_length++; +} + +static int +close_handle (int i) +{ + int result = fclose (handle[i]); + msg (VM (2), _("SORT: Closing handle %d."), i); + + handle[i] = NULL; + if (EOF == result) + { + sprintf (tmp_extname, "%08x", i); + msg (SE, _("%s: Error closing temporary file: %s."), + tmp_basename, strerror (errno)); + return 0; + } + return 1; +} + +static int +close_handles (int beg, int end) +{ + int success = 1; + int i; + + for (i = beg; i < end; i++) + success &= close_handle (i); + return success; +} + +static int +open_handle_w (int handle_no, int run_no) +{ + sprintf (tmp_extname, "%08x", run_no); + msg (VM (1), _("SORT: %s: Opening for writing as run %d."), + tmp_basename, run_no); + + /* The `x' modifier causes the GNU C library to insist on creating a + new file--if the file already exists, an error is signaled. The + ANSI C standard says that other libraries should ignore anything + after the `w+b', so it shouldn't be a problem. */ + return NULL != (handle[handle_no] = fopen (tmp_basename, "w+bx")); +} + +static int +open_handle_r (int handle_no, int run_no) +{ + FILE *f; + + sprintf (tmp_extname, "%08x", run_no); + msg (VM (1), _("SORT: %s: Opening for writing as run %d."), + tmp_basename, run_no); + f = handle[handle_no] = fopen (tmp_basename, "rb"); + + if (f == NULL) + { + msg (SE, _("%s: Error opening temporary file for reading: %s."), + tmp_basename, strerror (errno)); + return 0; + } + + return 1; +} + +/* Begins a new initial run, specifically its output file. */ +static void +begin_run (void) +{ + /* Decide which handle[] to use. If run_no is max_handles or + greater, then we've run out of handles so it's time to just do + one file at a time, which by default is handle 0. */ + file_index = (run_no < max_handles ? run_no : 0); + run_length = 0; + + /* Alright, now create the temporary file. */ + if (open_handle_w (file_index, run_no) == 0) + { + /* Failure to create the temporary file. Check if there are + unacceptably few files already open. */ + if (file_index < 3) + { + deferred_abort = 1; + msg (SE, _("%s: Error creating temporary file: %s."), + tmp_basename, strerror (errno)); + return; + } + + /* Close all the open temporary files. */ + if (!close_handles (0, file_index)) + return; + + /* Now try again to create the temporary file. */ + max_handles = file_index; + file_index = 0; + if (open_handle_w (0, run_no) == 0) + { + /* It still failed, report it this time. */ + deferred_abort = 1; + msg (SE, _("%s: Error creating temporary file: %s."), + tmp_basename, strerror (errno)); + return; + } + } +} + +/* Ends the current initial run. Just increments run_no if no initial + run has been started yet. */ +static void +end_run (void) +{ + /* Close file handles if necessary. */ + { + int result; + + if (run_no == max_handles - 1) + result = close_handles (0, max_handles); + else if (run_no >= max_handles) + result = close_handle (0); + else + result = 1; + if (!result) + deferred_abort = 1; + } + + /* Advance to next run. */ + run_no++; + if (run_no) + heap_insert (huffman_queue, run_no - 1, run_length); +} + +/* Performs 5.4.1R. */ +static int +write_initial_runs (int separate) +{ + run_no = -1; + deferred_abort = 0; + + /* Steps R1, R2, R3. */ + rmax = 0; + rc = 0; + lastkey = NULL; + q = x[0]; + rq = 0; + { + int j; + + for (j = 0; j < x_max; j++) + { + struct repl_sel_tree *J = x[j]; + + J->loser = J; + J->rn = 0; + J->fe = x[(x_max + j) / 2]; + J->fi = x[j / 2]; + memset (J->record, 0, default_dict.nval * sizeof (union value)); + } + } + + /* Most of the iterations of steps R4, R5, R6, R7, R2, R3, ... */ + if (!separate) + { + if (vfm_sink) + vfm_sink->destroy_sink (); + vfm_sink = &sort_stream; + } + procedure (NULL, NULL, NULL); + + /* Final iterations of steps R4, R5, R6, R7, R2, R3, ... */ + for (;;) + { + struct repl_sel_tree *t; + + /* R4. */ + rq = rmax + 1; + + /* R5. */ + t = q->fe; + + /* R6 and R7. */ + for (;;) + { + /* R6. */ + if (t->rn < rq + || (t->rn == rq + && compare_record (t->loser->record, q->record) < 0)) + { + struct repl_sel_tree *temp_tree; + int temp_int; + + temp_tree = t->loser; + t->loser = q; + q = temp_tree; + + temp_int = t->rn; + t->rn = rq; + rq = temp_int; + } + + /* R7. */ + if (t == x[1]) + break; + t = t->fi; + } + + /* R2. */ + if (rq != rc) + { + end_run (); + if (rq > rmax) + break; + begin_run (); + rc = rq; + } + + /* R3. */ + if (rq != 0) + { + output_record (q->record); + lastkey = x[x_max]->record; + memcpy (lastkey, q->record, sizeof (union value) * vfm_sink_info.nval); + } + } + assert (run_no == rmax); + + /* If an unrecoverable error occurred somewhere in the above code, + then the `deferred_abort' flag would have been set. */ + if (deferred_abort) + { + int i; + + for (i = 0; i < max_handles; i++) + if (handle[i] != NULL) + { + sprintf (tmp_extname, "%08x", i); + + if (fclose (handle[i]) == EOF) + msg (SE, _("%s: Error closing temporary file: %s."), + tmp_basename, strerror (errno)); + + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file: %s."), + tmp_basename, strerror (errno)); + + handle[i] = NULL; + } + return 0; + } + + return 1; +} + +/* Compares the NV_SORT variables in V_SORT[] between the `value's at + A and B, and returns a strcmp()-type result. */ +static int +compare_record (union value * a, union value * b) +{ + int i; + int result = 0; + struct variable *v; + + assert (a != NULL); + if (b == NULL) /* Sort NULLs after everything else. */ + return -1; + + for (i = 0; i < nv_sort; i++) + { + v = v_sort[i]; + + if (v->type == NUMERIC) + { + if (approx_ne (a[v->fv].f, b[v->fv].f)) + { + result = (a[v->fv].f > b[v->fv].f) ? 1 : -1; + break; + } + } + else + { + result = memcmp (a[v->fv].s, b[v->fv].s, v->width); + if (result != 0) + break; + } + } + + if (v->p.srt.order == SRT_ASCEND) + return result; + else + { + assert (v->p.srt.order == SRT_DESCEND); + return -result; + } +} + +/* Merging. */ + +static int merge_once (int run_index[], int run_length[], int n_runs); + +/* Modula function as defined by Knuth. */ +static int +mod (int x, int y) +{ + int result; + + if (y == 0) + return x; + result = abs (x) % abs (y); + if (y < 0) + result = -result; + return result; +} + +/* Performs a series of P-way merges of initial runs using Huffman's + method. */ +static int +merge (void) +{ + /* Order of merge. */ + int order; + + /* Idiot check. */ + assert (MIN_BUFFER_SIZE_RECS * 2 <= MIN_BUFFER_TOTAL_SIZE_RECS - 1); + + /* Close all the input files. I hope that the boundary conditions + are correct on this but I'm not sure. */ + if (run_no < max_handles) + { + int i; + + for (i = 0; i < run_no; ) + if (!close_handle (i++)) + { + for (; i < run_no; i++) + close_handle (i); + return 0; + } + } + + /* Determine order of merge. */ + order = MAX_MERGE_ORDER; + if (x_max / order < MIN_BUFFER_SIZE_RECS) + order = x_max / MIN_BUFFER_SIZE_RECS; + else if (x_max / order * sizeof (union value) * default_dict.nval + < MIN_BUFFER_SIZE_BYTES) + order = x_max / (MIN_BUFFER_SIZE_BYTES + / (sizeof (union value) * (default_dict.nval - 1))); + + /* Make sure the order of merge is bounded. */ + if (order < 2) + order = 2; + if (order > rmax) + order = rmax; + assert (x_max / order > 0); + + /* Calculate number of records per buffer. */ + records_per_buffer = x_max / order; + + /* Add (1 - S) mod (P - 1) dummy runs of length 0. */ + { + int n_dummy_runs = mod (1 - rmax, order - 1); + debug_printf (("rmax=%d, order=%d, n_dummy_runs=%d\n", + rmax, order, n_dummy_runs)); + assert (n_dummy_runs >= 0); + while (n_dummy_runs--) + { + heap_insert (huffman_queue, -2, 0); + rmax++; + } + } + + /* Repeatedly merge the P shortest existing runs until only one run + is left. */ + while (rmax > 1) + { + int run_index[MAX_MERGE_ORDER]; + int run_length[MAX_MERGE_ORDER]; + int total_run_length = 0; + int i; + + assert (rmax >= order); + + /* Find the shortest runs; put them in runs[] in reverse order + of length, to force dummy runs of length 0 to the end of the + list. */ + debug_printf ((_("merging runs"))); + for (i = order - 1; i >= 0; i--) + { + run_index[i] = heap_delete (huffman_queue, &run_length[i]); + assert (run_index[i] != -1); + total_run_length += run_length[i]; + debug_printf ((" %d(%d)", run_index[i], run_length[i])); + } + debug_printf ((_(" into run %d(%d)\n"), run_no, total_run_length)); + + if (!merge_once (run_index, run_length, order)) + { + int index; + + while (-1 != (index = heap_delete (huffman_queue, NULL))) + { + sprintf (tmp_extname, "%08x", index); + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file: %s."), + tmp_basename, strerror (errno)); + } + + return 0; + } + + if (!heap_insert (huffman_queue, run_no++, total_run_length)) + { + msg (SE, _("Out of memory expanding Huffman priority queue.")); + return 0; + } + + rmax -= order - 1; + } + + /* There should be exactly one element in the priority queue after + all that merging. This represents the entire sorted active file. + So we could find a total case count by deleting this element from + the queue. */ + assert (heap_size (huffman_queue) == 1); + + return 1; +} + +/* Merges N_RUNS initial runs into a new run. The jth run for 0 <= j + < N_RUNS is taken from temporary file RUN_INDEX[j]; it is composed + of RUN_LENGTH[j] cases. */ +static int +merge_once (int run_index[], int run_length[], int n_runs) +{ + /* For each run, the number of records remaining in its buffer. */ + int buffered[MAX_MERGE_ORDER]; + + /* For each run, the index of the next record in the buffer. */ + int buffer_ptr[MAX_MERGE_ORDER]; + + /* Open input files. */ + { + int i; + + for (i = 0; i < n_runs; i++) + if (run_index[i] != -2 && !open_handle_r (i, run_index[i])) + { + /* Close and remove temporary files. */ + while (i--) + { + close_handle (i); + sprintf (tmp_extname, "%08x", i); + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file: %s."), + tmp_basename, strerror (errno)); + } + + return 0; + } + } + + /* Create output file. */ + if (!open_handle_w (N_INPUT_BUFFERS, run_no)) + { + msg (SE, _("%s: Error creating temporary file for merge: %s."), + tmp_basename, strerror (errno)); + goto lossage; + } + + /* Prime each buffer. */ + { + int i; + + for (i = 0; i < n_runs; i++) + if (run_index[i] == -2) + { + n_runs = i; + break; + } + else + { + int j; + int ofs = records_per_buffer * i; + + buffered[i] = min (records_per_buffer, run_length[i]); + for (j = 0; j < buffered[i]; j++) + if ((int) fread (x[j + ofs]->record, sizeof (union value), + default_dict.nval, handle[i]) + != default_dict.nval) + { + sprintf (tmp_extname, "%08x", run_index[i]); + if (ferror (handle[i])) + msg (SE, _("%s: Error reading temporary file in merge: %s."), + tmp_basename, strerror (errno)); + else + msg (SE, _("%s: Unexpected end of temporary file in merge."), + tmp_basename); + goto lossage; + } + buffer_ptr[i] = ofs; + run_length[i] -= buffered[i]; + } + } + + /* Perform the merge proper. */ + while (n_runs) /* Loop while some data is left. */ + { + int i; + int min = 0; + + for (i = 1; i < n_runs; i++) + if (compare_record (x[buffer_ptr[min]]->record, + x[buffer_ptr[i]]->record) > 0) + min = i; + + if ((int) fwrite (x[buffer_ptr[min]]->record, sizeof (union value), + default_dict.nval, handle[N_INPUT_BUFFERS]) + != default_dict.nval) + { + sprintf (tmp_extname, "%08x", run_index[i]); + msg (SE, _("%s: Error writing temporary file in " + "merge: %s."), tmp_basename, strerror (errno)); + goto lossage; + } + + /* Remove one case from the buffer for this input file. */ + if (--buffered[min] == 0) + { + /* The input buffer is empty. Do any cases remain in the + initial run on disk? */ + if (run_length[min]) + { + /* Yes. Read them in. */ + + int j; + int ofs; + + /* Reset the buffer pointer. Note that we can't simply + set it to (i * records_per_buffer) since the run + order might have changed. */ + ofs = buffer_ptr[min] -= buffer_ptr[min] % records_per_buffer; + + buffered[min] = min (records_per_buffer, run_length[min]); + for (j = 0; j < buffered[min]; j++) + if ((int) fread (x[j + ofs]->record, sizeof (union value), + default_dict.nval, handle[min]) + != default_dict.nval) + { + sprintf (tmp_extname, "%08x", run_index[min]); + if (ferror (handle[min])) + msg (SE, _("%s: Error reading temporary file in " + "merge: %s."), + tmp_basename, strerror (errno)); + else + msg (SE, _("%s: Unexpected end of temporary file " + "in merge."), + tmp_basename); + goto lossage; + } + run_length[min] -= buffered[min]; + } + else + { + /* No. Delete this run. */ + + /* Close the file. */ + FILE *f = handle[min]; + handle[min] = NULL; + sprintf (tmp_extname, "%08x", run_index[min]); + if (fclose (f) == EOF) + msg (SE, _("%s: Error closing temporary file in merge: " + "%s."), tmp_basename, strerror (errno)); + + /* Delete the file. */ + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file in merge: " + "%s."), tmp_basename, strerror (errno)); + + n_runs--; + if (min != n_runs) + { + /* Since this isn't the last run, we move the last + run into its spot to force all the runs to be + contiguous. */ + run_index[min] = run_index[n_runs]; + run_length[min] = run_length[n_runs]; + buffer_ptr[min] = buffer_ptr[n_runs]; + buffered[min] = buffered[n_runs]; + handle[min] = handle[n_runs]; + } + } + } + else + buffer_ptr[min]++; + } + + /* Close output file. */ + { + FILE *f = handle[N_INPUT_BUFFERS]; + handle[N_INPUT_BUFFERS] = NULL; + if (fclose (f) == EOF) + { + sprintf (tmp_extname, "%08x", run_no); + msg (SE, _("%s: Error closing temporary file in merge: " + "%s."), + tmp_basename, strerror (errno)); + return 0; + } + } + + return 1; + +lossage: + /* Close all the input and output files. */ + { + int i; + + for (i = 0; i < n_runs; i++) + if (run_length[i] != 0) + { + close_handle (i); + sprintf (tmp_basename, "%08x", run_index[i]); + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file: %s."), + tmp_basename, strerror (errno)); + } + } + close_handle (N_INPUT_BUFFERS); + sprintf (tmp_basename, "%08x", run_no); + if (remove (tmp_basename) != 0) + msg (SE, _("%s: Error removing temporary file: %s."), + tmp_basename, strerror (errno)); + return 0; +} + +/* External sort input program. */ + +/* Reads all the records from the source stream and passes them + to write_case(). */ +void +sort_stream_read (void) +{ + read_sort_output (write_case); +} + +/* Reads all the records from the output stream and passes them to the + function provided, which must have an interface identical to + write_case(). */ +void +read_sort_output (int (*write_case) (void)) +{ + int i; + FILE *f; + + if (separate_case_tab) + { + struct ccase *save_temp_case = temp_case; + struct case_list **p; + + for (p = separate_case_tab; *p; p++) + { + temp_case = &(*p)->c; + write_case (); + } + + free (separate_case_tab); + separate_case_tab = NULL; + + temp_case = save_temp_case; + } else { + sprintf (tmp_extname, "%08x", run_no - 1); + f = fopen (tmp_basename, "rb"); + if (!f) + { + msg (ME, _("%s: Cannot open sort result file: %s."), tmp_basename, + strerror (errno)); + err_failure (); + return; + } + + for (i = 0; i < vfm_source_info.ncases; i++) + { + if (!fread (temp_case, vfm_source_info.case_size, 1, f)) + { + if (ferror (f)) + msg (ME, _("%s: Error reading sort result file: %s."), + tmp_basename, strerror (errno)); + else + msg (ME, _("%s: Unexpected end of sort result file: %s."), + tmp_basename, strerror (errno)); + err_failure (); + break; + } + + if (!write_case ()) + break; + } + + if (fclose (f) == EOF) + msg (ME, _("%s: Error closing sort result file: %s."), tmp_basename, + strerror (errno)); + + if (remove (tmp_basename) != 0) + msg (ME, _("%s: Error removing sort result file: %s."), tmp_basename, + strerror (errno)); + else + rmdir_temp_dir (); + } +} + +#if 0 /* dead code */ +/* Alternate interface to sort_stream_write used for external sorting + when SEPARATE is true. */ +static int +write_separate (struct ccase *c) +{ + assert (c == temp_case); + + sort_stream_write (); + return 1; +} +#endif + +/* Performs one iteration of 5.4.1R steps R4, R5, R6, R7, R2, and + R3. */ +static void +sort_stream_write (void) +{ + struct repl_sel_tree *t; + + /* R4. */ + memcpy (q->record, temp_case->data, vfm_sink_info.case_size); + if (compare_record (q->record, lastkey) < 0) + if (++rq > rmax) + rmax = rq; + + /* R5. */ + t = q->fe; + + /* R6 and R7. */ + for (;;) + { + /* R6. */ + if (t->rn < rq + || (t->rn == rq && compare_record (t->loser->record, q->record) < 0)) + { + struct repl_sel_tree *temp_tree; + int temp_int; + + temp_tree = t->loser; + t->loser = q; + q = temp_tree; + + temp_int = t->rn; + t->rn = rq; + rq = temp_int; + } + + /* R7. */ + if (t == x[1]) + break; + t = t->fi; + } + + /* R2. */ + if (rq != rc) + { + end_run (); + begin_run (); + assert (rq <= rmax); + rc = rq; + } + + /* R3. */ + if (rq != 0) + { + output_record (q->record); + lastkey = x[x_max]->record; + memcpy (lastkey, q->record, vfm_sink_info.case_size); + } +} + +/* Switches mode from sink to source. */ +void +sort_stream_mode (void) +{ + /* If this is not done, then we get the following source/sink pairs: + source=memory/disk/DATA LIST/etc., sink=SORT; source=SORT, + sink=SORT; which is not good. */ + vfm_sink = NULL; +} + +struct case_stream sort_stream = + { + NULL, + sort_stream_read, + sort_stream_write, + sort_stream_mode, + NULL, + NULL, + "SORT", + }; diff --git a/src/sort.h b/src/sort.h new file mode 100644 index 00000000..e6c9fed9 --- /dev/null +++ b/src/sort.h @@ -0,0 +1,31 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !sort_h +#define sort_h 1 + +/* SORT CASES programmatic interface. */ +int sort_cases (int separate); +void read_sort_output (int (*write_case)(void)); + +/* Variables to sort. */ +extern struct variable **v_sort; +extern int nv_sort; + +#endif /* !sort_h */ diff --git a/src/split-file.c b/src/split-file.c new file mode 100644 index 00000000..29fc432e --- /dev/null +++ b/src/split-file.c @@ -0,0 +1,56 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +int +cmd_split_file (void) +{ + lex_match_id ("SPLIT"); + lex_match_id ("FILE"); + + if (lex_match_id ("OFF")) + { + default_dict.n_splits = 0; + free (default_dict.splits); + default_dict.splits = NULL; + } + else + { + struct variable **v; + int n; + + lex_match (T_BY); + if (!parse_variables (NULL, &v, &n, PV_NO_DUPLICATE)) + return CMD_FAILURE; + + default_dict.n_splits = n; + default_dict.splits = v = xrealloc (v, sizeof *v * (n + 1)); + v[n] = NULL; + } + + return lex_end_of_command (); +} diff --git a/src/stat.h b/src/stat.h new file mode 100644 index 00000000..69580857 --- /dev/null +++ b/src/stat.h @@ -0,0 +1,65 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include + +#ifdef STAT_MACROS_BROKEN +#undef S_ISBLK +#undef S_ISCHR +#undef S_ISDIR +#undef S_ISFIFO +#undef S_ISLNK +#undef S_ISMPB +#undef S_ISMPC +#undef S_ISNWK +#undef S_ISREG +#undef S_ISSOCK +#endif /* STAT_MACROS_BROKEN. */ + +#if !defined(S_ISBLK) && defined(S_IFBLK) +#define S_ISBLK(m) (((m) & S_IFMT) == S_IFBLK) +#endif +#if !defined(S_ISCHR) && defined(S_IFCHR) +#define S_ISCHR(m) (((m) & S_IFMT) == S_IFCHR) +#endif +#if !defined(S_ISDIR) && defined(S_IFDIR) +#define S_ISDIR(m) (((m) & S_IFMT) == S_IFDIR) +#endif +#if !defined(S_ISREG) && defined(S_IFREG) +#define S_ISREG(m) (((m) & S_IFMT) == S_IFREG) +#endif +#if !defined(S_ISFIFO) && defined(S_IFIFO) +#define S_ISFIFO(m) (((m) & S_IFMT) == S_IFIFO) +#endif +#if !defined(S_ISLNK) && defined(S_IFLNK) +#define S_ISLNK(m) (((m) & S_IFMT) == S_IFLNK) +#endif +#if !defined(S_ISSOCK) && defined(S_IFSOCK) +#define S_ISSOCK(m) (((m) & S_IFMT) == S_IFSOCK) +#endif +#if !defined(S_ISMPB) && defined(S_IFMPB) /* V7 */ +#define S_ISMPB(m) (((m) & S_IFMT) == S_IFMPB) +#define S_ISMPC(m) (((m) & S_IFMT) == S_IFMPC) +#endif +#if !defined(S_ISNWK) && defined(S_IFNWK) /* HP/UX */ +#define S_ISNWK(m) (((m) & S_IFMT) == S_IFNWK) +#endif +#if !defined(HAVE_MKFIFO) +#define mkfifo(path, mode) (mknod ((path), (mode) | S_IFIFO, 0)) +#endif diff --git a/src/stats.c b/src/stats.c new file mode 100644 index 00000000..a52ab402 --- /dev/null +++ b/src/stats.c @@ -0,0 +1,203 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include "stats.h" + +/* Returns the fourth power of its argument. */ +double +hypercube (double x) +{ + x *= x; + return x * x; +} + +/* Returns the cube of its argument. */ +double +cube (double x) +{ + return x * x * x; +} + +/* Returns the square of its argument. */ +double +sqr (double x) +{ + return x * x; +} + +/* + * kurtosis = [(n+1){n*sum(X**4) - 4*sum(X)*sum(X**3) + * + 6*sum(X)**2*sum(X**2)/n - 3*sum(X)**4/n**2}] + * /[(n-1)(n-2)(n-3)*(variance)**2] + * -[3*{(n-1)**2}] + * /[(n-2)(n-3)] + * + * This and other formulas from _Biometry_, Sokal and Rohlf, + * W. H. Freeman and Company, 1969. See pages 117 and 136 especially. + */ +double +calc_kurt (const double d[4], double n, double variance) +{ + return + (((n + 1) * (n * d[3] + - 4.0 * d[0] * d[2] + + 6.0 * sqr (d[0]) * d[1] / n + - 3.0 * hypercube (d[0]) / sqr (n))) + / ((n - 1.0) * (n - 2.0) * (n - 3.0) * sqr (variance)) + - (3.0 * sqr (n - 1.0)) + / ((n - 2.0) * (n - 3.))); +} + +/* + * standard error of kurtosis = sqrt([24n((n-1)**2)]/[(n-3)(n-2)(n+3)(n+5)]) + */ +double +calc_sekurt (double n) +{ + return sqrt ((24.0 * n * sqr (n - 1.0)) + / ((n - 3.0) * (n - 2.0) * (n + 3.0) * (n + 5.0))); +} + +/* + * skewness = [n*sum(X**3) - 3*sum(X)*sum(X**2) + 2*sum(X)**3/n]/ + * /[(n-1)(n-2)*(variance)**3] + */ +double +calc_skew (const double d[3], double n, double stddev) +{ + return + ((n * d[2] - 3.0 * d[0] * d[1] + 2.0 * cube (d[0]) / n) + / ((n - 1.0) * (n - 2.0) * cube (stddev))); +} + +/* + * standard error of skewness = sqrt([6n(n-1)] / [(n-2)(n+1)(n+3)]) + */ +double +calc_seskew (double n) +{ + return + sqrt ((6.0 * n * (n - 1.0)) + / ((n - 2.0) * (n + 1.0) * (n + 3.0))); +} + +/* Returns one-sided significance level corresponding to standard + normal deviate X. Algorithm from _SPSS Statistical Algorithms_, + Appendix 1. */ +#if 0 +double +normal_sig (double x) +{ + const double a1 = .070523078; + const double a2 = .0422820123; + const double a3 = .0092705272; + const double a4 = .0001520143; + const double a5 = .0002765672; + const double a6 = .0000430638; + + const double z = fabs (x) <= 14.14 ? 0.7071067812 * fabs (x) : 10.; + double r; + + r = 1. + z * (a1 + z * (a2 + z * (a3 + z * (a4 + z * (a5 + z * a6))))); + r *= r; /* r ** 2 */ + r *= r; /* r ** 4 */ + r *= r; /* r ** 16 */ + + return .5 / r; +} +#else /* 1 */ +/* Taken from _BASIC Statistics: An Introduction to Problem Solving + with Your Personal Computer_, Jerry W. O'Dell, TAB 1984, page 314-5. */ +double +normal_sig (double z) +{ + double h; + + h = 1 + 0.0498673470 * z; + z *= z; + h += 0.0211410061 * z; + z *= z; + h += 0.0032776263 * z; + z *= z; + h += 0.0000380036 * z; + z *= z; + h += 0.0000488906 * z; + z *= z; + h += 0.0000053830 * z; + return pow (h, -16.) / 2.; +} +#endif /* 1 */ + +/* Algorithm from _Turbo Pascal Programmer's Toolkit_, Rugg and + Feldman, Que 1989. Returns the significance level of chi-square + value CHISQ with DF degrees of freedom, correct to at least 7 + decimal places. */ +double +chisq_sig (double x, int k) +{ + if (x <= 0. || k < 1) + return 1.0; + else if (k == 1) + return 2. * normal_sig (sqrt (x)); + else if (k <= 30) + { + double z, z_partial, term, denom, numerator, value; + + z = 1.; + z_partial = 1.; + term = k; + do + { + term += 2; + z_partial *= x / term; + if (z_partial >= 10000000.) + return 0.; + z += z_partial; + } + while (z_partial >= 1.e-7); + denom = term = 2 - k % 2; + while (term < k) + { + term += 2; + denom *= term; + } + if (k % 2) + { + value = ((k + 1) / 2) * log (x) - x / 2.; + numerator = exp (value) * sqrt (2. / x / PI); + } + else + { + value = k / 2. * log (x) - x / 2.; + numerator = exp (value); + } + return 1. - numerator * z / denom; + } + else + { + double term, numer, norm_x; + + term = 2. / 9. / k; + numer = pow (x / k, 1. / 3.); + norm_x = numer / sqrt (term); + return 1.0 - normal_sig (norm_x); + } +} diff --git a/src/stats.h b/src/stats.h new file mode 100644 index 00000000..81a3f112 --- /dev/null +++ b/src/stats.h @@ -0,0 +1,84 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !statistics_h +#define statistics_h 1 + +/* These are all sample statistics except for mean since uses + population statistics for whatever reason. */ + +/* Define pi to the maximum precision available. */ +#include /* defines M_PI on many systems */ +#ifndef PI +#ifdef M_PI +#define PI M_PI +#else /* !PI && !M_PI */ +#define PI 3.14159265358979323846264338327 +#endif /* !PI && !M_PI */ +#endif /* !PI */ + +/* Returns the fourth power of its argument. */ +extern inline double +hypercube (double x) +{ + x *= x; + return x * x; +} + +/* Returns the cube of its argument. */ +extern inline double +cube (double x) +{ + return x * x * x; +} + +/* Returns the square of its argument. */ +extern inline double +sqr (double x) +{ + return x * x; +} + +/* Mean, standard error of mean. */ +#define calc_mean(D, N) \ + ((D)[0] / (N)) +#define calc_semean(STDDEV, N) \ + ((STDDEV) / sqrt (N)) + +/* Variance, standard deviation, coefficient of variance. */ +#define calc_variance(D, N) \ + ( ((D)[1] - sqr ((D)[0])/(N)) / ((N)-1) ) +#define calc_stddev(VARIANCE) \ + (sqrt (VARIANCE)) +#define calc_cfvar(D, N) \ + ( calc_stddev (calc_variance (D, N)) / calc_mean (D, N) ) + +/* Kurtosis, standard error of kurtosis. */ +double calc_kurt (const double d[4], double n, double variance); +double calc_sekurt (double n); + +/* Skewness, standard error of skewness. */ +double calc_skew (const double d[3], double n, double stddev); +double calc_seskew (double n); + +/* Significance. */ +double normal_sig (double x); +double chisq_sig (double chisq, int df); + +#endif /* !statistics_h */ diff --git a/src/str.c b/src/str.c new file mode 100644 index 00000000..4bf2d60c --- /dev/null +++ b/src/str.c @@ -0,0 +1,584 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "error.h" +#include "pool.h" +#include "str.h" + +/* sprintf() wrapper functions for convenience. */ + +#if !__GNUC__ +char * +spprintf (char *buf, const char *format,...) +{ +#if HAVE_GOOD_SPRINTF + int count; +#endif + va_list args; + + va_start (args, format); +#if HAVE_GOOD_SPRINTF + count = +#endif + vsprintf (buf, format, args); + va_end (args); + +#if HAVE_GOOD_SPRINTF + return &buf[count]; +#else + return strchr (buf, 0); +#endif +} +#endif /* !__GNUC__ */ + +#if !__GNUC__ && !HAVE_GOOD_SPRINTF +int +nsprintf (char *buf, const char *format,...) +{ + va_list args; + + va_start (args, format); + vsprintf (buf, format, args); + va_end (args); + + return strlen (buf); +} + +int +nvsprintf (char *buf, const char *format, va_list args) +{ + vsprintf (buf, format, args); + return strlen (buf); +} +#endif /* Not GNU C and not good sprintf(). */ + +/* Reverses the order of NBYTES bytes at address P, thus converting + between little- and big-endian byte orders. */ +void +mm_reverse (void *p, size_t nbytes) +{ + unsigned char *h = p, *t = &h[nbytes - 1]; + unsigned char temp; + + nbytes /= 2; + while (nbytes--) + { + temp = *h; + *h++ = *t; + *t-- = temp; + } +} + +/* Finds the last NEEDLE of length NEEDLE_LEN in a HAYSTACK of length + HAYSTACK_LEN. Returns a pointer to the needle found. */ +char * +mm_find_reverse (const char *haystack, size_t haystack_len, + const char *needle, size_t needle_len) +{ + int i; + for (i = haystack_len - needle_len; i >= 0; i--) + if (!memcmp (needle, &haystack[i], needle_len)) + return (char *) &haystack[i]; + return 0; +} + +/* Compares S0 of length S0L to S1 of length S1L. The shorter string + is considered to be padded with spaces to the length of the + longer. */ +int +st_compare_pad (const char *s0, int s0l, const char *s1, int s1l) +{ + /* 254 spaces. */ + static char blanks[254] = + " " + " " + " " + " " + " "; + + int diff = s0l - s1l; + int r; + + if (diff == 0) + { + if (s0l == 0) + return 0; + return memcmp (s0, s1, s0l); + } + else if (diff > 0) + { + /* s0l > s1l */ + if (s1l) + { + r = memcmp (s0, s1, s1l); + if (r) + return r; + } + return memcmp (&s0[s1l], blanks, diff); + } + else + /* diff<0 */ + { + /* s0l < s1l */ + if (s0l) + { + r = memcmp (s0, s1, s0l); + if (r) + return r; + } + return memcmp (blanks, &s1[s0l], -diff); + } +} + +/* Copies SRC to DEST, truncating to N characters or right-padding + with spaces to N characters as necessary. Does not append a null + character. SRC must be null-terminated. */ +void +st_bare_pad_copy (char *dest, const char *src, size_t n) +{ + size_t len; + + len = strlen (src); + if (len >= n) + memcpy (dest, src, n); + else + { + memcpy (dest, src, len); + memset (&dest[len], ' ', n - len); + } +} + +/* Copies SRC to DEST, truncating SRC to N characters or right-padding + with spaces to N characters if necessary. Does not append a null + character. SRC must be LEN characters long but does not need to be + null-terminated. */ +void +st_bare_pad_len_copy (char *dest, const char *src, size_t n, size_t len) +{ + if (len >= n) + memcpy (dest, src, n); + else + { + memcpy (dest, src, len); + memset (&dest[len], ' ', n - len); + } +} + +/* Copies SRC to DEST, truncating SRC to N-1 characters or + right-padding with spaces to N-1 characters if necessary. Always + appends a null character. */ +void +st_pad_copy (char *dest, const char *src, size_t n) +{ + size_t len; + + len = strlen (src); + if (len == n - 1) + strcpy (dest, src); + else if (len < n - 1) + { + memcpy (dest, src, len); + memset (&dest[len], ' ', n - 1 - len); + dest[n - 1] = 0; + } + else + { + memcpy (dest, src, n - 1); + dest[n - 1] = 0; + } +} + +/* Initializes ST inside pool POOL (which may be a null pointer) with + initial contents S. */ +void +ds_create (struct pool *pool, struct string *st, const char *s) +{ + st->pool = pool; + st->length = strlen (s); + st->size = 8 + st->length * 2; + st->string = pool_malloc (pool, st->size + 1); + strcpy (st->string, s); +} + +/* Initializes ST inside POOL (which may be null), making room for at + least SIZE characters. */ +void +ds_init (struct pool *pool, struct string *st, size_t size) +{ + st->pool = pool; + st->length = 0; + if (size > 8) + st->size = size; + else + st->size = 8; + st->string = pool_malloc (pool, st->size + 1); +} + +/* Replaces the contents of ST with STRING. STRING may overlap with + ST. */ +void +ds_replace (struct string *st, const char *string) +{ + char *s = st->string; + st->string = NULL; + ds_create (st->pool, st, string); + pool_free (st->pool, s); +} + +/* Frees ST. */ +void +ds_destroy (struct string *st) +{ + pool_free (st->pool, st->string); +} + +/* Truncates ST to zero length. */ +void +ds_clear (struct string *st) +{ + st->length = 0; +} + +/* Ensures that ST can hold at least MIN_SIZE characters plus a null + terminator. */ +void +ds_extend (struct string *st, size_t min_size) +{ + if (min_size > st->size) + { + st->size *= 2; + if (st->size < min_size) + st->size = min_size * 2; + + st->string = pool_realloc (st->pool, st->string, st->size + 1); + } +} + +/* Shrink ST to the minimum size need to contain its content. */ +void +ds_shrink (struct string *st) +{ + if (st->size != st->length) + { + st->size = st->length; + st->string = pool_realloc (st->pool, st->string, st->size + 1); + } +} + +/* Truncates ST to at most LENGTH characters long. */ +void +ds_truncate (struct string *st, size_t length) +{ + if (length >= st->length) + return; + st->length = length; +} + +/* Returns the length of ST. */ +size_t +ds_length (const struct string *st) +{ + return st->length; +} + +/* Returns the allocation size of ST. */ +size_t +ds_size (const struct string *st) +{ + return st->size; +} + +/* Returns the value of ST as a null-terminated string. */ +char * +ds_value (const struct string *st) +{ + ((char *) st->string)[st->length] = '\0'; + return st->string; +} + +/* Returns a pointer to the null terminator ST. + This might not be an actual null character unless ds_value() has + been called since the last modification to ST. */ +char * +ds_end (const struct string *st) +{ + return st->string + st->length; +} + +/* Concatenates S onto ST. */ +void +ds_concat (struct string *st, const char *s) +{ + size_t s_len = strlen (s); + ds_extend (st, st->length + s_len); + strcpy (st->string + st->length, s); + st->length += s_len; +} + +/* Concatenates LEN characters from BUF onto ST. */ +void +ds_concat_buffer (struct string *st, const char *buf, size_t len) +{ + ds_extend (st, st->length + len); + memcpy (st->string + st->length, buf, len); + st->length += len; +} + +/* Formats FORMAT as a printf string and appends the result to ST. */ +void +ds_printf (struct string *st, const char *format, ...) +{ + /* Fscking glibc silently changed behavior between 2.0 and 2.1. + Fsck fsck fsck. Before, it returned -1 on buffer overflow. Now, + it returns the number of characters (not bytes) that would have + been written. */ + va_list args; + + int avail, needed; + + va_start (args, format); + avail = st->size - st->length + 1; + needed = vsnprintf (st->string + st->length, avail, format, args); + va_end (args); + + if (needed >= avail) + { + ds_extend (st, st->length + needed); + + va_start (args, format); + vsprintf (st->string + st->length, format, args); + va_end (args); + } + else + while (needed == -1) + { + ds_extend (st, (st->size + 1) * 2); + avail = st->size - st->length + 1; + + va_start (args, format); + needed = vsnprintf (st->string + st->length, avail, format, args); + va_end (args); + } + + st->length += needed; +} + +/* Appends character CH to ST. */ +void +ds_putchar (struct string *st, int ch) +{ + if (st->length == st->size) + ds_extend (st, st->length + 1); + st->string[st->length++] = ch; +} + +/* Reads a newline-terminated line from STREAM into ST. + Newline is the last character of ST on return, unless an I/O error + or end of file is encountered after reading some characters. + Returns 1 if a line is successfully read, or 0 if no characters at + all were read before an I/O error or end of file was + encountered. */ +int +ds_getline (struct string *st, FILE *stream) +{ + int c; + + c = getc (stream); + if (c == EOF) + return 0; + + for (;;) + { + ds_putchar (st, c); + if (c == '\n') + return 1; + + c = getc (stream); + if (c == EOF) + return 1; + } +} + +/* Reads a line from STREAM into ST, then preprocesses as follows: + + - Splices lines terminated with `\'. + + - Deletes comments introduced by `#' outside of single or double + quotes. + + - Trailing whitespace will be deleted. + + Increments cust_ln as appropriate. + + Returns nonzero only if a line was successfully read. */ +int +ds_get_config_line (FILE *stream, struct string *st, struct file_locator *where) +{ + /* Read the first line. */ + ds_clear (st); + where->line_number++; + if (!ds_getline (st, stream)) + return 0; + + /* Read additional lines, if any. */ + for (;;) + { + /* Remove trailing whitespace. */ + { + char *s = ds_value (st); + size_t len = ds_length (st); + + while (len > 0 && isspace ((unsigned char) s[len - 1])) + len--; + ds_truncate (st, len); + } + + /* Check for trailing \. Remove if found, bail otherwise. */ + if (ds_length (st) == 0 || ds_value (st)[ds_length (st) - 1] != '\\') + break; + ds_truncate (st, ds_length (st) - 1); + + /* Append another line and go around again. */ + { + int success = ds_getline (st, stream); + where->line_number++; + if (!success) + return 1; + } + } + + /* Find a comment and remove. */ + { + char *cp; + int quote = 0; + + for (cp = ds_value (st); *cp; cp++) + if (quote) + { + if (*cp == quote) + quote = 0; + else if (*cp == '\\') + cp++; + } + else if (*cp == '\'' || *cp == '"') + quote = *cp; + else if (*cp == '#') + { + ds_truncate (st, cp - ds_value (st)); + break; + } + } + + return 1; +} + +/* Lengthed strings. */ + +/* Creates a new lengthed string LS in POOL with contents as a copy of + S. */ +void +ls_create (struct pool *pool, struct len_string *ls, const char *s) +{ + ls->length = strlen (s); + ls->string = pool_alloc (pool, ls->length + 1); + memcpy (ls->string, s, ls->length + 1); +} + +/* Creates a new lengthed string LS in POOL with contents as a copy of + BUFFER with length LEN. */ +void +ls_create_buffer (struct pool *pool, struct len_string *ls, + const char *buffer, size_t len) +{ + ls->length = len; + ls->string = pool_malloc (pool, len + 1); + memcpy (ls->string, buffer, len); + ls->string[len] = '\0'; +} + +/* Sets the fields of LS to the specified values. */ +void +ls_init (struct len_string *ls, const char *string, size_t length) +{ + ls->string = (char *) string; + ls->length = length; +} + +/* Copies the fields of SRC to DST. */ +void +ls_shallow_copy (struct len_string *dst, const struct len_string *src) +{ + *dst = *src; +} + +/* Frees the memory in POOL backing LS. */ +void +ls_destroy (struct pool *pool, struct len_string *ls) +{ + pool_free (pool, ls->string); +} + +/* Sets LS to a null pointer value. */ +void +ls_null (struct len_string *ls) +{ + ls->string = NULL; +} + +/* Returns nonzero only if LS has a null pointer value. */ +int +ls_null_p (const struct len_string *ls) +{ + return ls->string == NULL; +} + +/* Returns nonzero only if LS is a null pointer or has length 0. */ +int +ls_empty_p (const struct len_string *ls) +{ + return ls->string == NULL || ls->length == 0; +} + +/* Returns the length of LS, which must not be null. */ +size_t +ls_length (const struct len_string *ls) +{ + return ls->length; +} + +/* Returns a pointer to the character string in LS. */ +char * +ls_value (const struct len_string *ls) +{ + return (char *) ls->string; +} + +/* Returns a pointer to the null terminator of the character string in + LS. */ +char * +ls_end (const struct len_string *ls) +{ + return (char *) (ls->string + ls->length); +} diff --git a/src/str.h b/src/str.h new file mode 100644 index 00000000..dedcc10d --- /dev/null +++ b/src/str.h @@ -0,0 +1,215 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !str_h +#define str_h 1 + +/* Headers and miscellaneous. */ + +#include +#include + +#if STDC_HEADERS + #include +#else + #ifndef HAVE_STRCHR + #define strchr index + #define strrchr rindex + #endif + + char *strchr (), *strrchr (); +#endif + +#if !HAVE_STRTOK_R + char *strtok_r (char *, const char *, char **); +#endif + +#if !HAVE_STPCPY && !__linux__ + char *stpcpy (char *dest, const char *src); +#endif + +#if !HAVE_STRCASECMP + int strcasecmp (const char *s1, const char *s2); +#endif + +#if !HAVE_STRNCASECMP + int strncasecmp (const char *s1, const char *s2, size_t n); +#endif + +#if !HAVE_MEMMEM + void *memmem (const void *haystack, size_t haystack_len, + const void *needle, size_t needle_len); +#endif + +/* sprintf() wrapper functions for convenience. */ + +/* spprintf() calls sprintf() and returns the address of the null + terminator in the resulting string. It should be portable the way + it's been implemented. */ +#if __GNUC__ + #if HAVE_GOOD_SPRINTF + #define spprintf(BUF, FORMAT, ARGS...) \ + ((BUF) + sprintf ((BUF), (FORMAT) , ## ARGS)) + #else + #define spprintf(BUF, FORMAT, ARGS...) \ + ({ sprintf ((BUF), (FORMAT) , ## ARGS); \ + strchr ((BUF), 0); }) + #endif +#else /* Not GNU C. */ + char *spprintf (char *buf, const char *format, ...); +#endif /* Not GNU C. */ + +/* nsprintf() calls sprintf() and returns the strlen() of the + resulting string. It should be portable the way it's been + implemented. */ +#if __GNUC__ + #if HAVE_GOOD_SPRINTF + #define nsprintf(BUF, FORMAT, ARGS...) \ + (sprintf ((BUF), (FORMAT) , ## ARGS)) + #define nvsprintf(BUF, FORMAT, ARGS) \ + (vsprintf ((BUF), (FORMAT), (ARGS))) + #else /* Not good sprintf(). */ + #define nsprintf(BUF, FORMAT, ARGS...) \ + ({ \ + char *pbuf = BUF; \ + sprintf ((pbuf), (FORMAT) , ## ARGS); \ + strlen (pbuf); \ + }) + #define nvsprintf(BUF, FORMAT, ARGS) \ + ({ \ + char *pbuf = BUF; \ + vsprintf ((pbuf), (FORMAT), (ARGS)); \ + strlen (pbuf); \ + }) + #endif /* Not good sprintf(). */ +#else /* Not GNU C. */ + #if HAVE_GOOD_SPRINTF + #define nsprintf sprintf + #define nvsprintf vsprintf + #else /* Not good sprintf(). */ + int nsprintf (char *buf, const char *format, ...); + int nvsprintf (char *buf, const char *format, va_list args); + #endif /* Not good sprintf(). */ +#endif /* Not GNU C. */ + +#if !HAVE_GETLINE +long getline (char **lineptr, size_t *n, FILE *stream); +#endif + +#if !HAVE_GETDELIM +long getdelim (char **lineptr, size_t * n, int delimiter, FILE * stream); +#endif + +/* Miscellaneous. */ + +void mm_reverse (void *, size_t); +char *mm_find_reverse (const char *, size_t, const char *, size_t); + +int st_compare_pad (const char *, int, const char *, int); +char *st_spaces (int); +void st_bare_pad_copy (char *dest, const char *src, size_t n); +void st_bare_pad_len_copy (char *dest, const char *src, size_t n, size_t len); +void st_pad_copy (char *dest, const char *src, size_t n); + +/* Lengthed strings. */ +struct len_string + { + char *string; + size_t length; + }; + +struct pool; +void ls_create (struct pool *, struct len_string *, const char *); +void ls_create_buffer (struct pool *, struct len_string *, + const char *, size_t len); +void ls_init (struct len_string *, const char *, size_t); +void ls_shallow_copy (struct len_string *, const struct len_string *); +void ls_destroy (struct pool *, struct len_string *); + +void ls_null (struct len_string *); +int ls_null_p (const struct len_string *); +int ls_empty_p (const struct len_string *); + +size_t ls_length (const struct len_string *); +char *ls_value (const struct len_string *); +char *ls_end (const struct len_string *); + +/* Dynamic strings. */ + +struct string + { + struct pool *pool; + size_t length; + size_t size; + char *string; + }; + +void ds_create (struct pool *, struct string *, const char *); +void ds_init (struct pool *, struct string *, size_t size); +void ds_replace (struct string *, const char *); +void ds_destroy (struct string *); +void ds_clear (struct string *); +void ds_extend (struct string *, size_t min_size); +void ds_shrink (struct string *); +void ds_truncate (struct string *, size_t length); + +size_t ds_length (const struct string *); +char *ds_value (const struct string *); +char *ds_end (const struct string *); +size_t ds_size (const struct string *); + +struct file_locator; +int ds_getline (struct string *st, FILE *stream); +int ds_get_config_line (FILE *, struct string *, struct file_locator *); +void ds_putchar (struct string *, int ch); +void ds_concat (struct string *, const char *); +void ds_concat_buffer (struct string *, const char *buf, size_t len); +void ds_printf (struct string *, const char *, ...) + __attribute__ ((format (printf, 2, 3))); + +#if __GNUC__ > 1 +extern inline void +ds_putchar (struct string *st, int ch) +{ + if (st->length == st->size) + ds_extend (st, st->length + 1); + st->string[st->length++] = ch; +} + +extern inline size_t +ds_length (const struct string *st) +{ + return st->length; +} + +extern inline char * +ds_value (const struct string *st) +{ + ((char *) st->string)[st->length] = '\0'; + return st->string; +} + +extern inline char * +ds_end (const struct string *st) +{ + return st->string + st->length; +} +#endif + +#endif /* str_h */ diff --git a/src/sysfile-info.c b/src/sysfile-info.c new file mode 100644 index 00000000..dda4f546 --- /dev/null +++ b/src/sysfile-info.c @@ -0,0 +1,620 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "error.h" +#include "file-handle.h" +#include "lexer.h" +#include "misc.h" +#include "output.h" +#include "sfm.h" +#include "som.h" +#include "tab.h" +#include "var.h" +#include "vector.h" + +/* Constants for DISPLAY utility. */ +enum + { + AS_NAMES = 0, + AS_INDEX, + AS_VARIABLES, + AS_LABELS, + AS_DICTIONARY, + AS_SCRATCH, + AS_VECTOR + }; + +int describe_variable (struct variable *v, struct tab_table *t, int r, int as); + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +sysfile_info_dim (struct tab_table *t, struct outp_driver *d) +{ + static const int max[] = {20, 5, 35, 3, 0}; + const int *p; + int i; + + for (p = max; *p; p++) + t->w[p - max] = min (tab_natural_width (t, d, p - max), + *p * d->prop_em_width); + for (i = 0; i < t->nr; i++) + t->h[i] = tab_natural_height (t, d, i); +} + +/* SYSFILE INFO utility. */ +int +cmd_sysfile_info (void) +{ + struct file_handle *h; + struct dictionary *d; + struct tab_table *t; + struct sfm_read_info inf; + int r, nr; + int i; + + lex_match_id ("SYSFILE"); + lex_match_id ("INFO"); + + lex_match_id ("FILE"); + lex_match ('='); + + h = fh_parse_file_handle (); + if (!h) + return CMD_FAILURE; + + d = sfm_read_dictionary (h, &inf); + fh_close_handle (h); + if (!d) + return CMD_FAILURE; + + t = tab_create (2, 9, 0); + tab_vline (t, TAL_1 | TAL_SPACING, 1, 0, 8); + tab_text (t, 0, 0, TAB_LEFT, _("File:")); + tab_text (t, 1, 0, TAB_LEFT, fh_handle_filename (h)); + tab_text (t, 0, 1, TAB_LEFT, _("Label:")); + tab_text (t, 1, 1, TAB_LEFT, + d->label ? d->label : _("No label.")); + tab_text (t, 0, 2, TAB_LEFT, _("Created:")); + tab_text (t, 1, 2, TAB_LEFT | TAT_PRINTF, "%s %s by %s", + inf.creation_date, inf.creation_time, inf.product); + tab_text (t, 0, 3, TAB_LEFT, _("Endian:")); + tab_text (t, 1, 3, TAB_LEFT, + (inf.endianness == BIG ? _("Big.") + : (inf.endianness == LITTLE ? _("Little.") + : (assert (0), _(""))))); + tab_text (t, 0, 4, TAB_LEFT, _("Variables:")); + tab_text (t, 1, 4, TAB_LEFT | TAT_PRINTF, "%d", + d->nvar); + tab_text (t, 0, 5, TAB_LEFT, _("Cases:")); + tab_text (t, 1, 5, TAB_LEFT | TAT_PRINTF, + inf.ncases == -1 ? _("Unknown") : "%d", inf.ncases); + tab_text (t, 0, 6, TAB_LEFT, _("Type:")); + tab_text (t, 1, 6, TAB_LEFT, _("System File.")); + tab_text (t, 0, 7, TAB_LEFT, _("Weight:")); + tab_text (t, 1, 7, TAB_LEFT, + d->weight_var[0] ? d->weight_var : _("Not weighted.")); + tab_text (t, 0, 8, TAB_LEFT, _("Mode:")); + tab_text (t, 1, 8, TAB_LEFT | TAT_PRINTF, + _("Compression %s."), inf.compressed ? _("on") : _("off")); + tab_dim (t, tab_natural_dimensions); + tab_submit (t); + + nr = 1 + 2 * d->nvar; + t = tab_create (4, nr, 1); + tab_dim (t, sysfile_info_dim); + tab_headers (t, 0, 0, 1, 0); + tab_text (t, 0, 0, TAB_LEFT | TAT_TITLE, _("Variable")); + tab_joint_text (t, 1, 0, 2, 0, TAB_LEFT | TAT_TITLE, _("Description")); + tab_text (t, 3, 0, TAB_LEFT | TAT_TITLE, _("Position")); + tab_hline (t, TAL_2, 0, 3, 1); + for (r = 1, i = 0; i < d->nvar; i++) + { + int nvl = d->var[i]->val_lab ? avl_count (d->var[i]->val_lab) : 0; + + if (r + 10 + nvl > nr) + { + nr = max (nr * d->nvar / (i + 1), nr); + nr += 10 + nvl; + tab_realloc (t, 4, nr); + } + + r = describe_variable (d->var[i], t, r, AS_DICTIONARY); + } + tab_box (t, TAL_1, TAL_1, -1, -1, 0, 0, 3, r); + tab_vline (t, TAL_1, 0, 0, r); + tab_vline (t, TAL_1, 1, 0, r); + tab_vline (t, TAL_1, 3, 0, r); + tab_resize (t, -1, r); + tab_flags (t, SOMF_NO_TITLE); + tab_submit (t); + + free_dictionary (d); + + return lex_end_of_command (); +} + +/* DISPLAY utility. */ + +static void display_macros (void); +static void display_documents (void); +static void display_variables (struct variable **, int, int); +static void display_vectors (int sorted); + +static int cmp_var_by_name (const void *, const void *); + +int +cmd_display (void) +{ + /* Whether to sort the list of variables alphabetically. */ + int sorted; + + /* Variables to display. */ + int n; + struct variable **vl; + + lex_match_id ("DISPLAY"); + + if (lex_match_id ("MACROS")) + display_macros (); + else if (lex_match_id ("DOCUMENTS")) + display_documents (); + else if (lex_match_id ("FILE")) + { + som_blank_line (); + if (!lex_force_match_id ("LABEL")) + return CMD_FAILURE; + if (default_dict.label == NULL) + tab_output_text (TAB_LEFT, + _("The active file does not have a file label.")); + else + { + tab_output_text (TAB_LEFT | TAT_TITLE, _("File label:")); + tab_output_text (TAB_LEFT | TAT_FIX, default_dict.label); + } + } + else + { + static const char *sbc[] = + {"NAMES", "INDEX", "VARIABLES", "LABELS", + "DICTIONARY", "SCRATCH", "VECTORS", NULL}; + const char **cp; + int as; + + sorted = lex_match_id ("SORTED"); + + for (cp = sbc; *cp; cp++) + if (token == T_ID && lex_id_match (*cp, tokid)) + { + lex_get (); + break; + } + as = cp - sbc; + + if (*cp == NULL) + as = AS_NAMES; + + if (as == AS_VECTOR) + { + display_vectors (sorted); + return CMD_SUCCESS; + } + + lex_match ('/'); + lex_match_id ("VARIABLES"); + lex_match ('='); + + if (token != '.') + { + if (!parse_variables (NULL, &vl, &n, PV_NONE)) + { + free (vl); + return CMD_FAILURE; + } + as = AS_DICTIONARY; + } + else + fill_all_vars (&vl, &n, FV_NONE); + + if (as == AS_SCRATCH) + { + int i, m; + for (i = 0, m = n; i < n; i++) + if (vl[i]->name[0] != '#') + { + vl[i] = NULL; + m--; + } + as = AS_NAMES; + n = m; + } + + if (n == 0) + { + msg (SW, _("No variables to display.")); + return CMD_FAILURE; + } + + if (sorted) + qsort (vl, n, sizeof *vl, cmp_var_by_name); + + display_variables (vl, n, as); + + free (vl); + } + + return lex_end_of_command (); +} + +static int +cmp_var_by_name (const void *a, const void *b) +{ + return strcmp ((*((struct variable **) a))->name, (*((struct variable **) b))->name); +} + +static void +display_macros (void) +{ + som_blank_line (); + tab_output_text (TAB_LEFT, _("Macros not supported.")); +} + +static void +display_documents (void) +{ + som_blank_line (); + if (default_dict.n_documents == 0) + tab_output_text (TAB_LEFT, _("The active file dictionary does not " + "contain any documents.")); + else + { + char buf[81]; + int i; + + tab_output_text (TAB_LEFT | TAT_TITLE, + _("Documents in the active file:")); + som_blank_line (); + buf[80] = 0; + for (i = 0; i < default_dict.n_documents; i++) + { + int len = 79; + + memcpy (buf, &default_dict.documents[i * 80], 80); + while ((isspace ((unsigned char) buf[len]) || buf[len] == 0) + && len > 0) + len--; + buf[len + 1] = 0; + tab_output_text (TAB_LEFT | TAT_FIX | TAT_NOWRAP, buf); + } + } +} + +static int _as; + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +variables_dim (struct tab_table *t, struct outp_driver *d) +{ + int pc; + int i; + + t->w[0] = tab_natural_width (t, d, 0); + if (_as == AS_DICTIONARY || _as == AS_VARIABLES || _as == AS_LABELS) + { + t->w[1] = max (tab_natural_width (t, d, 1), d->prop_em_width * 5); + t->w[2] = max (tab_natural_width (t, d, 2), d->prop_em_width * 35); + pc = 3; + } + else pc = 1; + if (_as != AS_NAMES) + t->w[pc] = tab_natural_width (t, d, pc); + + for (i = 0; i < t->nr; i++) + t->h[i] = tab_natural_height (t, d, i); +} + +static void +display_variables (struct variable **vl, int n, int as) +{ + struct variable **vp = vl; /* Variable pointer. */ + struct tab_table *t; + int nc; /* Number of columns. */ + int nr; /* Number of rows. */ + int pc; /* `Position column' */ + int r; /* Current row. */ + int i; + + _as = as; + switch (as) + { + case AS_INDEX: + nc = 2; + break; + case AS_NAMES: + nc = 1; + break; + default: + nc = 4; + break; + } + + t = tab_create (nc, n + 5, 1); + tab_headers (t, 0, 0, 1, 0); + nr = n + 5; + tab_hline (t, TAL_2, 0, nc - 1, 1); + tab_text (t, 0, 0, TAB_LEFT | TAT_TITLE, _("Variable")); + if (as != AS_NAMES) + { + pc = (as == AS_INDEX ? 1 : 3); + tab_text (t, pc, 0, TAB_LEFT | TAT_TITLE, _("Position")); + } + if (as == AS_DICTIONARY || as == AS_VARIABLES) + tab_joint_text (t, 1, 0, 2, 0, TAB_LEFT | TAT_TITLE, _("Description")); + else if (as == AS_LABELS) + tab_joint_text (t, 1, 0, 2, 0, TAB_LEFT | TAT_TITLE, _("Label")); + tab_dim (t, variables_dim); + + for (i = r = 1; i <= n; i++) + { + struct variable *v; + + while (*vp == NULL) + vp++; + v = *vp++; + + if (as == AS_DICTIONARY || as == AS_VARIABLES) + { + int nvl = v->val_lab ? avl_count (v->val_lab) : 0; + + if (r + 10 + nvl > nr) + { + nr = max (nr * n / (i + 1), nr); + nr += 10 + nvl; + tab_realloc (t, nc, nr); + } + + r = describe_variable (v, t, r, as); + } else { + tab_text (t, 0, r, TAB_LEFT, v->name); + if (as == AS_LABELS) + tab_joint_text (t, 1, r, 2, r, TAB_LEFT, + v->label == NULL ? "(no label)" : v->label); + if (as != AS_NAMES) + { + tab_text (t, pc, r, TAT_PRINTF, "%d", v->index + 1); + tab_hline (t, TAL_1, 0, nc - 1, r); + } + r++; + } + } + tab_hline (t, as == AS_NAMES ? TAL_1 : TAL_2, 0, nc - 1, 1); + if (as != AS_NAMES) + { + tab_box (t, TAL_1, TAL_1, -1, -1, 0, 0, nc - 1, r - 1); + tab_vline (t, TAL_1, 1, 0, r - 1); + } + else + tab_flags (t, SOMF_NO_TITLE); + if (as == AS_DICTIONARY || as == AS_VARIABLES || as == AS_LABELS) + tab_vline (t, TAL_1, 3, 0, r - 1); + tab_resize (t, -1, r); + tab_columns (t, TAB_COL_DOWN, 1); + tab_submit (t); +} + +/* Puts a description of variable V into table T starting at row R. + The variable will be described in the format AS. Returns the next + row available for use in the table. */ +int +describe_variable (struct variable *v, struct tab_table *t, int r, int as) +{ + /* Put the name, var label, and position into the first row. */ + tab_text (t, 0, r, TAB_LEFT, v->name); + tab_text (t, 3, r, TAT_PRINTF, "%d", v->index + 1); + + if (as == AS_DICTIONARY && v->label) + { + tab_joint_text (t, 1, r, 2, r, TAB_LEFT, v->label); + r++; + } + + /* Print/write format, or print and write formats. */ + if (v->print.type == v->write.type + && v->print.w == v->write.w + && v->print.d == v->write.d) + { + tab_joint_text (t, 1, r, 2, r, TAB_LEFT | TAT_PRINTF, _("Format: %s"), + fmt_to_string (&v->print)); + r++; + } + else + { + tab_joint_text (t, 1, r, 2, r, TAB_LEFT | TAT_PRINTF, + _("Print Format: %s"), fmt_to_string (&v->print)); + r++; + tab_joint_text (t, 1, r, 2, r, TAB_LEFT | TAT_PRINTF, + _("Write Format: %s"), fmt_to_string (&v->write)); + r++; + } + + /* Missing values if any. */ + if (v->miss_type != MISSING_NONE) + { + char buf[80]; + char *cp = stpcpy (buf, _("Missing Values: ")); + + if (v->type == NUMERIC) + switch (v->miss_type) + { + case MISSING_1: + sprintf (cp, "%g", v->missing[0].f); + break; + case MISSING_2: + sprintf (cp, "%g; %g", v->missing[0].f, v->missing[1].f); + break; + case MISSING_3: + sprintf (cp, "%g; %g; %g", v->missing[0].f, + v->missing[1].f, v->missing[2].f); + break; + case MISSING_RANGE: + sprintf (cp, "%g THRU %g", v->missing[0].f, v->missing[1].f); + break; + case MISSING_LOW: + sprintf (cp, "LOWEST THRU %g", v->missing[0].f); + break; + case MISSING_HIGH: + sprintf (cp, "%g THRU HIGHEST", v->missing[0].f); + break; + case MISSING_RANGE_1: + sprintf (cp, "%g THRU %g; %g", + v->missing[0].f, v->missing[1].f, v->missing[2].f); + break; + case MISSING_LOW_1: + sprintf (cp, "LOWEST THRU %g; %g", + v->missing[0].f, v->missing[1].f); + break; + case MISSING_HIGH_1: + sprintf (cp, "%g THRU HIGHEST; %g", + v->missing[0].f, v->missing[1].f); + break; + default: + assert (0); + } + else + { + int i; + + for (i = 0; i < v->miss_type; i++) + { + if (i != 0) + cp = stpcpy (cp, "; "); + *cp++ = '"'; + memcpy (cp, v->missing[i].s, v->width); + cp += v->width; + *cp++ = '"'; + } + *cp = 0; + } + + tab_joint_text (t, 1, r, 2, r, TAB_LEFT, buf); + r++; + } + + /* Value labels. */ + if (as == AS_DICTIONARY && v->val_lab) + { + avl_traverser trav; + struct value_label *vl; + int nvl = avl_count (v->val_lab); + int orig_r = r; + int i; + +#if 0 + tab_text (t, 1, r, TAB_LEFT, _("Value")); + tab_text (t, 2, r, TAB_LEFT, _("Label")); + r++; +#endif + + tab_hline (t, TAL_1, 1, 2, r); + avl_traverser_init (trav); + for (i = 1, vl = avl_traverse (v->val_lab, &trav); vl; + i++, vl = avl_traverse (v->val_lab, &trav)) + { + char buf[128]; + + if (v->type == ALPHA) + { + memcpy (buf, vl->v.s, v->width); + buf[v->width] = 0; + } + else + sprintf (buf, "%g", vl->v.f); + + tab_text (t, 1, r, TAB_NONE, buf); + tab_text (t, 2, r, TAB_LEFT, vl->s); + r++; + + if (i == nvl) + break; + } + + for (;;) + { + if (vl == NULL) + break; + vl = avl_traverse (v->val_lab, &trav); + } + + tab_vline (t, TAL_1, 2, orig_r, r - 1); + } + + /* Draw a line below the last row of information on this variable. */ + tab_hline (t, TAL_1, 0, 3, r); + + return r; +} + +static int +compare_vectors_by_name (const void *a, const void *b) +{ + return strcmp ((*((struct vector **) a))->name, (*((struct vector **) b))->name); +} + +/* Display a list of vectors. If SORTED is nonzero then they are + sorted alphabetically. */ +static void +display_vectors (int sorted) +{ + struct vector **vl; + int i; + struct tab_table *t; + + if (nvec == 0) + { + msg (SW, _("No vectors defined.")); + return; + } + + vl = xmalloc (sizeof *vl * nvec); + for (i = 0; i < nvec; i++) + vl[i] = &vec[i]; + if (sorted) + qsort (vl, nvec, sizeof *vl, compare_vectors_by_name); + + t = tab_create (1, nvec + 1, 0); + tab_headers (t, 0, 0, 1, 0); + tab_columns (t, TAB_COL_DOWN, 1); + tab_dim (t, tab_natural_dimensions); + tab_hline (t, TAL_1, 0, 0, 1); + tab_text (t, 0, 0, TAT_TITLE | TAB_LEFT, _("Vector")); + tab_flags (t, SOMF_NO_TITLE); + for (i = 0; i < nvec; i++) + tab_text (t, 0, i + 1, TAB_LEFT, vl[i]->name); + tab_submit (t); + + free (vl); +} diff --git a/src/t-test.q b/src/t-test.q new file mode 100644 index 00000000..6b65d0ec --- /dev/null +++ b/src/t-test.q @@ -0,0 +1,1087 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "str.h" +#include "dcdflib/cdflib.h" +#include "command.h" +#include "lexer.h" +#include "error.h" +#include "magic.h" +#include "var.h" +#include "vfm.h" + +/* (specification) + "T-TEST" (tts_): + groups=custom; + variables=varlist("PV_NO_SCRATCH | PV_NUMERIC"); + *+pairs=custom; + +missing=miss:!analysis/listwise, + incl:include/!exclude; + +format=fmt:!labels/nolabels; + +criteria=:ci(d:criteria,"%s > 0. && %s < 1."). +*/ +/* (declarations) */ +/* (functions) */ + +#undef DEBUGGING +#define DEBUGGING 1 +#include "debug-print.h" + +/* Command parsing information. */ +static struct cmd_t_test cmd; + +/* Variable for the GROUPS subcommand, if given. */ +static struct variable *groups; + +/* GROUPS: Number of values specified by the user; the values + specified if any. */ +static int n_groups_values; +static union value groups_values[2]; + +/* PAIRED: Number of pairs; each pair. */ +static int n_pairs; +static struct variable *(*pairs)[2]; + +/* Routines to scan data and perform t-tests */ +static void precalc (void); +static void postcalc (void); +static void g_postcalc (void); +static void t_pairs (void); +static void t_groups (void); +static int groups_calc (struct ccase *); +static int pairs_calc (struct ccase *); +static int z_calc (struct ccase *); + +struct value_list + { + double sum; + double ss; + double n; + struct value_list *next; + }; + +/* general workhorses - should move these to a separate library... */ +double variance (double n, double ss, double sum); + +double covariance (double x_sum, double x_n, + double y_sum, double y_n, double ss); + +double pooled_variance (double n_1, double var_1, + double n_2, double var_2); + +double oneway (double *f, double *p, struct value_list *list); + +double pearson_r (double c_xy, double c_xx, double c_yy); + +double f_sig (double f, double dfn, double dfd); +double t_crt (double df, double q); +double t_sig (double t, double df); + +/* massive function simply to remove any responsibility for output + from the function which does the actual t-test calculations */ +void print_t_groups (struct variable * grps, union value * g1, union value * g2, + double n1, double n2, double mean1, double mean2, + double sd1, double sd2, double se1, double se2, + double diff, double l_f, double l_p, + double p_t, double p_sig, double p_df, double p_sed, + double p_l, double p_h, + double s_t, double s_sig, double s_df, double s_sed, + double s_l, double s_h); + +/* Global variables to communicate between calc() and postcalc() + should move to a structure in the p union of variable... */ +static double v1_n, v1_ss, v1_sum, v1_se, v1_var, v1_mean; +static double v2_n, v2_ss, v2_sum, v2_se, v2_var, v2_mean; +static double v1_z_sum, v1_z_ss; +static double v2_z_sum, v2_z_ss; +static double diff, se_diff, sp, xy_sum, xy_diff, xy_ss; +static int cur_var; + +/* some defines for CDFlib */ +#define FIND_P 1 +#define FIND_CRITICAL_VALUE 2 +#define ERROR_SIG -1 + +#ifdef DEBUGGING +static void debug_print (void); +#endif + +/* Parses and executes the T-TEST procedure. */ +int +cmd_t_test (void) +{ + struct cmd_t_test cmd; + + if (!lex_force_match_id ("T")) + return CMD_FAILURE; + lex_match ('-'); + lex_match_id ("TEST"); + + if (!parse_t_test (&cmd)) + return CMD_FAILURE; + +#if DEBUGGING + debug_print (); +#endif + + if (n_pairs > 0) + procedure (precalc, pairs_calc, postcalc); + else + /* probably groups then... */ + { + printf ("\n\n t-tests for independent samples of %s %s\n", + groups->name, groups->label); + + for (cur_var = 0; cur_var < cmd.n_variables; cur_var++) + { + v1_n = v1_ss = v1_sum = v1_se = v1_var = v1_mean = 0.0; + v2_n = v2_ss = v2_sum = v2_se = v2_var = v2_mean = 0.0; + v1_z_sum = v1_z_ss = v2_z_sum = v2_z_ss = 0.0; + diff = se_diff = sp = xy_diff = xy_ss = xy_sum = 0.0; + + procedure (precalc, groups_calc, g_postcalc); + procedure (precalc, z_calc, postcalc); + } + } + + return CMD_SUCCESS; +} + +void +precalc (void) +{ + return; /* rilly void... */ +} + +int +groups_calc (struct ccase * c) +{ + int bad_weight; + double group, w; + struct variable *v = cmd.v_variables[cur_var]; + double X = c->data[v->fv].f; + + /* Get the weight for this case. */ + if (default_dict.weight_index == -1) + w = 1.0; + else + { + w = c->data[default_dict.weight_index].f; + if (w <= 0.0 || w == SYSMIS) + { + w = 0.0; + bad_weight = 1; + printf ("Bad weight\n"); + } + } + + if (X == SYSMIS || X == 0.0) /* FIXME: should be USER_MISSING? */ + { + /* printf("Missing value\n"); */ + return 1; + } + else + { + X = X * w; + group = c->data[groups->fv].f; + + if (group == groups_values[0].f) + { + v1_sum += X; + v1_ss += X * X; + v1_n += w; + } + else if (group == groups_values[1].f) + { + v2_sum += X; + v2_ss += X * X; + v2_n += w; + } + } + + return 1; +} + +void +g_postcalc (void) +{ + v1_mean = v1_sum / v1_n; + v2_mean = v2_sum / v2_n; + return; +} + +int /* this pass generates the z-zcores */ +z_calc (struct ccase * c) +{ + int bad_weight; + double group, z, w; + struct variable *v = cmd.v_variables[cur_var]; + double X = c->data[v->fv].f; + + z = 0.0; + + /* Get the weight for this case. */ + if (default_dict.weight_index == -1) + w = 1.0; + else + { + w = c->data[default_dict.weight_index].f; + if (w <= 0.0 || w == SYSMIS) + { + w = 0.0; + bad_weight = 1; + } + } + + if (X == SYSMIS || X == 0.0) /* FIXME: how to specify user missing? */ + { + return 1; + } + else + { + group = c->data[groups->fv].f; + X = w * X; + + if (group == groups_values[0].f) + { + z = fabs (X - v1_mean); + v1_z_sum += z; + v1_z_ss += pow (z, 2); + } + else if (group == groups_values[1].f) + { + z = fabs (X - v2_mean); + v2_z_ss += pow (z, 2); + v2_z_sum += z; + } + } + + return 1; +} + + +int +pairs_calc (struct ccase * c) +{ + int i; + struct variable *v1, *v2; + double X, Y; + + for (i = 0; i < n_pairs; i++) + { + + v1 = pairs[i][0]; + v2 = pairs[i][1]; + X = c->data[v1->fv].f; + Y = c->data[v2->fv].f; + + if (X == SYSMIS || Y == SYSMIS) + { + printf ("Missing value\n"); + } + else + { + xy_sum += X * Y; + xy_diff += (X - Y); + xy_ss += pow ((X - Y), 2); + v1_sum += X; + v2_sum += Y; + v1_n++; + v2_n++; + v1_ss += (X * X); + v2_ss += (Y * Y); + } + } + + return 1; +} + +void +postcalc (void) +{ + /* Calculate basic statistics */ + v1_var = variance (v1_n, v1_ss, v1_sum); /* variances */ + v2_var = variance (v2_n, v2_ss, v2_sum); + v1_se = sqrt (v1_var / v1_n); /* standard errors */ + v2_se = sqrt (v2_var / v2_n); + diff = v1_mean - v2_mean; + + if (n_pairs > 0) + { + t_pairs (); + } + else + { + t_groups (); + } + + return; +} + +void +t_groups (void) +{ + double df_pooled, t_pooled, t_sep, p_pooled, p_sep; + double crt_t_p, crt_t_s, tmp, v1_z, v2_z, f_levene, p_levene; + double df_sep, se_diff_s, se_diff_p; + struct value_list *val_1, *val_2; + + /* Levene's test */ + val_1 = malloc (sizeof (struct value_list)); + val_1->sum = v1_z_sum; + val_1->ss = v1_z_ss; + val_1->n = v1_n; + val_2 = malloc (sizeof (struct value_list)); + val_2->sum = v2_z_sum; + val_2->ss = v2_z_ss; + val_2->n = v2_n; + + val_1->next = val_2; + val_2->next = NULL; + + f_levene = oneway (&f_levene, &p_levene, val_1); + + /* T test results for pooled variances */ + se_diff_p = sqrt (pooled_variance (v1_n, v1_var, v2_n, v2_var)); + df_pooled = v1_n + v2_n - 2.0; + t_pooled = diff / se_diff_p; + p_pooled = t_sig (t_pooled, df_pooled); + crt_t_p = t_crt (df_pooled, 0.025); + + if ((2.0 * p_pooled) >= 1.0) + p_pooled = 1.0 - p_pooled; + + /* oh god, the separate variance calculations... */ + t_sep = diff / sqrt ((v1_var / v1_n) + (v2_var / v2_n)); + + tmp = (v1_var / v1_n) + (v2_var / v2_n); + tmp = (v1_var / v1_n) / tmp; + tmp = pow (tmp, 2); + tmp = tmp / (v1_n - 1.0); + v1_z = tmp; + + tmp = (v1_var / v1_n) + (v2_var / v2_n); + tmp = (v2_var / v2_n) / tmp; + tmp = pow (tmp, 2); + tmp = tmp / (v2_n - 1.0); + v2_z = tmp; + + tmp = 1.0 / (v1_z + v2_z); + + df_sep = tmp; + p_sep = t_sig (t_sep, df_sep); + if ((2.0 * p_sep) >= 1.0) + p_sep = 1.0 - p_sep; + crt_t_s = t_crt (df_sep, 0.025); + se_diff_s = sqrt ((v1_var / v1_n) + (v2_var / v2_n)); + + /* FIXME: convert to a proper PSPP output call */ + print_t_groups (groups, &groups_values[0], &groups_values[1], + v1_n, v2_n, v1_mean, v2_mean, + sqrt (v1_var), sqrt (v2_var), v1_se, v2_se, + diff, f_levene, p_levene, + t_pooled, 2.0 * p_pooled, df_pooled, se_diff_p, + diff - (crt_t_p * se_diff_p), diff + (crt_t_p * se_diff_p), + t_sep, 2.0 * p_sep, df_sep, se_diff_s, + diff - (crt_t_s * se_diff_s), diff + (crt_t_s * se_diff_s)); + return; +} + +void +t_pairs (void) +{ + double cov12, cov11, cov22, r, t, p, crt_t, sp, r_t, r_p; + struct variable *v1, *v2; + + v1 = pairs[0][0]; + v2 = pairs[0][1]; + cov12 = covariance (v1_sum, v1_n, v2_sum, v2_n, xy_sum); + cov11 = covariance (v1_sum, v1_n, v1_sum, v1_n, v1_ss); + cov22 = covariance (v2_sum, v2_n, v2_sum, v2_n, v2_ss); + r = pearson_r (cov12, cov11, cov22); + /* this t and it's associated p is a significance test for the pearson's r */ + r_t = r * sqrt ((v1_n - 2.0) / (1.0 - (r * r))); + r_p = t_sig (r_t, v1_n - 2.0); + + /* now we move to the t test for the difference in means */ + diff = xy_diff / v1_n; + sp = sqrt (variance (v1_n, xy_ss, xy_diff)); + se_diff = sp / sqrt (v1_n); + t = diff / se_diff; + crt_t = t_crt (v1_n - 1.0, 0.025); + p = t_sig (t, v1_n - 1.0); + + + printf (" Number of 2-tail\n"); + printf (" Variable pairs Corr Sig Mean SD SE of Mean\n"); + printf ("---------------------------------------------------------------\n"); + printf ("%s %8.4f %8.4f %8.4f\n", + v1->name, v1_mean, sqrt (v1_var), v1_se); + printf (" %8.4f %0.4f %0.4f\n", v1_n, r, r_p); + printf ("%s %8.4f %8.4f %8.4f\n", + v2->name, v2_mean, sqrt (v2_var), v2_se); + printf ("---------------------------------------------------------------\n"); + + printf ("\n\n\n"); + printf (" Paired Differences |\n"); + printf (" Mean SD SE of Mean | t-value df 2-tail Sig\n"); + printf ("--------------------------------------|---------------------------\n"); + + printf ("%8.4f %8.4f %8.4f | %8.4f %8.4f %8.4f\n", + diff, sp, se_diff, t, v1_n - 1.0, 2.0 * (1.0 - p)); + + printf ("95pc CI (%8.4f, %8.4f) |\n\n", + diff - (se_diff * crt_t), diff + (se_diff * crt_t)); + + return; +} + +static int parse_value (union value *); + +/* Parses the GROUPS subcommand. */ +int +tts_custom_groups (struct cmd_t_test *cmd unused) +{ + groups = parse_variable (); + if (!groups) + { + lex_error (_("expecting variable name in GROUPS subcommand")); + return 0; + } + if (groups->type == T_STRING && groups->width > MAX_SHORT_STRING) + { + msg (SE, _("Long string variable %s is not valid here."), + groups->name); + return 0; + } + + if (!lex_match ('(')) + { + if (groups->type == NUMERIC) + { + n_groups_values = 2; + groups_values[0].f = 1; + groups_values[1].f = 2; + return 1; + } + else + { + msg (SE, _("When applying GROUPS to a string variable, at " + "least one value must be specified.")); + return 0; + } + } + + if (!parse_value (&groups_values[0])) + return 0; + n_groups_values = 1; + + lex_match (','); + + if (lex_match (')')) + return 1; + + if (!parse_value (&groups_values[1])) + return 0; + n_groups_values = 2; + + if (!lex_force_match (')')) + return 0; + + return 1; +} + +/* Parses the current token (numeric or string, depending on the + variable in `groups') into value V and returns success. */ +static int +parse_value (union value * v) +{ + if (groups->type == NUMERIC) + { + if (!lex_force_num ()) + return 0; + v->f = tokval; + } + else + { + if (!lex_force_string ()) + return 0; + strncpy (v->s, ds_value (&tokstr), ds_length (&tokstr)); + } + + lex_get (); + + return 1; +} + +/* Parses the PAIRS subcommand. */ +static int +tts_custom_pairs (struct cmd_t_test *cmd unused) +{ + struct variable **vars; + int n_before_WITH; + int n_vars; + int paired; + int extra; +#if DEBUGGING + int n_predicted; +#endif + + if ((token != T_ID || !is_varname (tokid)) && token != T_ALL) + return 2; + if (!parse_variables (&default_dict, &vars, &n_vars, + PV_DUPLICATE | PV_NUMERIC | PV_NO_SCRATCH)) + return 0; + + assert (n_vars); + if (lex_match (T_WITH)) + { + n_before_WITH = n_vars; + + if (!parse_variables (&default_dict, &vars, &n_vars, + PV_DUPLICATE | PV_APPEND + | PV_NUMERIC | PV_NO_SCRATCH)) + { + free (vars); + return 0; + } + } + else + n_before_WITH = 0; + + paired = (lex_match ('(') && lex_match_id ("PAIRED") && lex_match (')')); + + if (paired) + { + if (n_before_WITH * 2 != n_vars) + { + free (vars); + msg (SE, _("PAIRED was specified but the number of variables " + "preceding WITH (%d) did not match the number " + "following (%d)."), + n_before_WITH, n_vars - n_before_WITH); + return 0; + } + + extra = n_before_WITH; + } + else if (n_before_WITH) + extra = n_before_WITH * (n_vars - n_before_WITH); + else + { + if (n_vars < 2) + { + free (vars); + msg (SE, _("At least two variables must be specified " + "on PAIRS.")); + return 0; + } + + extra = n_vars * (n_vars - 1) / 2; + } + +#if DEBUGGING + n_predicted = n_pairs + extra; +#endif + + pairs = xrealloc (pairs, sizeof (struct variable *[2]) * (n_pairs + extra)); + + if (paired) + { + int i; + + for (i = 0; i < extra; i++) + { + pairs[n_pairs][0] = vars[i]; + pairs[n_pairs++][1] = vars[i + extra]; + } + } + else if (n_before_WITH) + { + int i; + + for (i = 0; i < n_before_WITH; i++) + { + int j; + + for (j = n_before_WITH; j < n_vars; j++) + { + pairs[n_pairs][0] = vars[i]; + pairs[n_pairs++][1] = vars[j]; + } + } + } + else + { + int i; + + for (i = 0; i < n_vars; i++) + { + int j; + + for (j = i + 1; j < n_vars; j++) + { + pairs[n_pairs][0] = vars[i]; + pairs[n_pairs++][1] = vars[j]; + } + } + } + +#if DEBUGGING + assert (n_pairs == n_predicted); +#endif + + free (vars); + return 1; +} + +#if DEBUGGING +static void +debug_print (void) +{ + printf ("T-TEST\n"); + if (groups) + { + printf (" GROUPS=%s", groups->name); + if (n_groups_values) + { + int i; + + printf (" ("); + for (i = 0; i < n_groups_values; i++) + if (groups->type == NUMERIC) + printf ("%g%s", groups_values[i].f, i ? " " : ""); + else + printf ("%.*s%s", groups->width, groups_values[i].s, + i ? " " : ""); + printf (")"); + } + printf ("\n"); + } + if (cmd.n_variables) + { + int i; + + printf (" VARIABLES="); + for (i = 0; i < cmd.n_variables; i++) + printf ("%s ", cmd.v_variables[i]->name); + printf ("\n"); + } + if (cmd.sbc_pairs) + { + int i; + + printf (" PAIRS="); + for (i = 0; i < n_pairs; i++) + printf ("%s ", pairs[i][0]->name); + printf ("WITH"); + for (i = 0; i < n_pairs; i++) + printf (" %s", pairs[i][1]->name); + printf (" (PAIRED)\n"); + } + printf (" MISSING=%s %s\n", + cmd.miss == TTS_ANALYSIS ? "ANALYSIS" : "LISTWISE", + cmd.miss == TTS_INCLUDE ? "INCLUDE" : "EXCLUDE"); + printf (" FORMAT=%s\n", + cmd.fmt == TTS_LABELS ? "LABELS" : "NOLABELS"); + if (cmd.criteria != NOT_LONG) + printf (" CRITERIA=%f\n", cmd.criteria); +} + +#endif /* DEBUGGING */ + +/* Here are some general routines tha should probably be moved into + a separate library and documented as part of the PSPP "API" */ +double +variance (double n, double ss, double sum) +{ + return ((ss - ((sum * sum) / n)) / (n - 1.0)); +} + +double +pooled_variance (double n_1, double var_1, double n_2, double var_2) +{ + double tmp; + + tmp = n_1 + n_2 - 2.0; + tmp = (((n_1 - 1.0) * var_1) + ((n_2 - 1.0) * var_2)) / tmp; + tmp = tmp * ((n_1 + n_2) / (n_1 * n_2)); + return tmp; +} + +double +oneway (double *f, double *p, struct value_list *levels) +{ + double k, SSTR, SSE, SSTO, N, MSTR, MSE, sum, dftr, dfe, print; + struct value_list *g; + + k = 0.0; + + for (g = levels; g != NULL; g = g->next) + { + k++; + sum += g->sum; + N += g->n; + SSTR += g->ss - (pow (g->sum, 2) / g->n); + SSTO += g->ss; + } + + SSTO = SSTO - (pow (sum, 2) / N); + SSE = SSTO - SSTR; + + dftr = N - k; + dfe = k - 1.0; + MSTR = SSTR / dftr; + MSE = SSE / dfe; + + *f = (MSE / MSTR); + *p = f_sig (*f, dfe, dftr); + + print = 1.0; + if (print == 1.0) + { + printf ("sum1 %f, sum2 %f, ss1 %f, ss2 %f\n", + levels->sum, levels->next->sum, levels->ss, levels->next->ss); + printf (" - - - - - - O N E W A Y - - - - - -\n\n"); + printf (" Variable %s %s\n", + cmd.v_variables[0]->name, cmd.v_variables[0]->label); + printf ("By Variable %s %s\n", groups->name, groups->label); + printf ("\n Analysis of Variance\n\n"); + printf (" Sum of Mean F F\n"); + printf ("Source D.F. Squares Squares Ratio Prob\n\n"); + printf ("Between %8.0f %8.4f %8.4f %8.4f %8.4f\n", + dfe, SSE, MSE, *f, *p); + printf ("Within %8.0f %8.4f %8.4f\n", dftr, SSTR, MSTR); + printf ("Total %8.0f %8.4f\n\n\n", N - 1.0, SSTO); + } + return (*f); +} + +double +f_sig (double f, double dfn, double dfd) +{ + int which, status; + double p, q, bound; + + which = FIND_P; + status = 1; + p = q = bound = 0.0; + cdff (&which, &p, &q, &f, &dfn, &dfd, &status, &bound); + + switch (status) + { + case -1: + { + printf ("Parameter 1 is out of range\n"); + break; + } + case -2: + { + printf ("Parameter 2 is out of range\n"); + break; + } + case -3: + { + printf ("Parameter 3 is out of range\n"); + break; + } + case -4: + { + printf ("Parameter 4 is out of range\n"); + break; + } + case -5: + { + printf ("Parameter 5 is out of range\n"); + break; + } + case -6: + { + printf ("Parameter 6 is out of range\n"); + break; + } + case -7: + { + printf ("Parameter 7 is out of range\n"); + break; + } + case -8: + { + printf ("Parameter 8 is out of range\n"); + break; + } + case 0: + { + /* printf( "Command completed successfully\n" ); */ + break; + } + case 1: + { + printf ("Answer appears to be lower than the lowest search bound\n"); + break; + } + case 2: + { + printf ("Answer appears to be higher than the greatest search bound\n"); + break; + } + case 3: + { + printf ("P - Q NE 1\n"); + break; + } + } + + if (status) + { + return (double) ERROR_SIG; + } + else + { + return q; + } +} + +double +t_crt (double df, double q) +{ + int which, status; + double p, bound, t; + + which = FIND_CRITICAL_VALUE; + bound = 0.0; + p = 1.0 - q; + t = 0.0; + + cdft (&which, &p, &q, &t, &df, &status, &bound); + + switch (status) + { + case -1: + { + printf ("t_crt: Parameter 1 is out of range\n"); + break; + } + case -2: + { + printf ("t_crt: value of p (%f) is out of range\n", p); + break; + } + case -3: + { + printf ("t_crt: value of q (%f) is out of range\n", q); + break; + } + case -4: + { + printf ("t_crt: value of df (%f) is out of range\n", df); + break; + } + case -5: + { + printf ("t_crt: Parameter 5 is out of range\n"); + break; + } + case -6: + { + printf ("t_crt: Parameter 6 is out of range\n"); + break; + } + case -7: + { + printf ("t_crt: Parameter 7 is out of range\n"); + break; + } + case 0: + { + /* printf( "Command completed successfully\n" ); */ + break; + } + case 1: + { + printf ("t_crt: Answer appears to be lower than the lowest search bound\n"); + break; + } + case 2: + { + printf ("t_crt: Answer appears to be higher than the greatest search bound\n"); + break; + } + case 3: + { + printf ("t_crt: P - Q NE 1\n"); + break; + } + } + + if (status) + { + return (double) ERROR_SIG; + } + else + { + return t; + } +} + +double +t_sig (double t, double df) +{ + int which, status; + double p, q, bound; + + which = FIND_P; + q = 0.0; + p = 0.0; + bound = 0.0; + + cdft (&which, &p, &q, &t, &df, &status, &bound); + + switch (status) + { + case -1: + { + printf ("t-sig: Parameter 1 is out of range\n"); + break; + } + case -2: + { + printf ("t-sig: Parameter 2 is out of range\n"); + break; + } + case -3: + { + printf ("t-sig: Parameter 3 is out of range\n"); + break; + } + case -4: + { + printf ("t-sig: Parameter 4 is out of range\n"); + break; + } + case -5: + { + printf ("t-sig: Parameter 5 is out of range\n"); + break; + } + case -6: + { + printf ("t-sig: Parameter 6 is out of range\n"); + break; + } + case -7: + { + printf ("t-sig: Parameter 7 is out of range\n"); + break; + } + case 0: + { + /* printf( "Command completed successfully\n" ); */ + break; + } + case 1: + { + printf ("t-sig: Answer appears to be lower than the lowest search bound\n"); + break; + } + case 2: + { + printf ("t-sig: Answer appears to be higher than the greatest search bound\n"); + break; + } + case 3: + { + printf ("t-sig: P - Q NE 1\n"); + break; + } + } + + if (status) + { + return (double) ERROR_SIG; + } + else + { + return q; + } +} + +double +covariance (double x_sum, double x_n, double y_sum, double y_n, double ss) +{ + double tmp; + + tmp = x_sum * y_sum; + tmp = tmp / x_n; + tmp = ss - tmp; + tmp = (tmp / (x_n + y_n - 1.0)); + return tmp; +} + +double +pearson_r (double c_xy, double c_xx, double c_yy) +{ + return (c_xy / (sqrt (c_xx * c_yy))); +} + +void +print_t_groups (struct variable * grps, union value * g1, union value * g2, + double n1, double n2, double mean1, double mean2, + double sd1, double sd2, double se1, double se2, + double diff, double l_f, double l_p, + double p_t, double p_sig, double p_df, double p_sed, + double p_l, double p_h, + double s_t, double s_sig, double s_df, double s_sed, + double s_l, double s_h) +{ + + /* Display all this shit as SPSS 6.0 does (roughly) */ + printf ("\n\n Number \n"); + printf (" Variable of Cases Mean SD SE of Mean\n"); + printf ("-----------------------------------------------------------\n"); + printf (" %s %s\n\n", cmd.v_variables[cur_var]->name, cmd.v_variables[cur_var]->label); + printf ("%s %8.4f %8.0f %8.4f %8.3f %8.3f\n", + get_val_lab (grps, *g1, 0), g1->f, n1, mean1, sd1, se1); + printf ("%s %8.4f %8.0f %8.4f %8.3f %8.3f\n", + get_val_lab (grps, *g2, 0), g2->f, n2, mean2, sd2, se2); + printf ("-----------------------------------------------------------\n"); + printf ("\n Mean Difference = %8.4f\n", diff); + printf ("\n Levene's Test for Equality of Variances: F= %.3f P= %.3f\n", + l_f, l_p); + printf ("\n\n t-test for Equality of Means 95pc \n"); + printf ("Variances t-value df 2-Tail Sig SE of Diff CI for Diff \n"); + printf ("-----------------------------------------------------------------\n"); + printf ("Equal %8.2f %8.0f %8.3f %8.3f (%8.3f, %8.3f)\n", + p_t, p_df, p_sig, p_sed, p_l, p_h); + printf ("Unequal %8.2f %8.2f %8.3f %8.3f (%8.3f, %8.3f)\n", + s_t, s_df, s_sig, s_sed, s_l, s_h); + printf ("-----------------------------------------------------------------\n"); +} + +/* + Local Variables: + mode: c + End: +*/ diff --git a/src/tab.c b/src/tab.c new file mode 100644 index 00000000..412bb0ac --- /dev/null +++ b/src/tab.c @@ -0,0 +1,1383 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "format.h" +#include "magic.h" +#include "misc.h" +#include "output.h" +#include "pool.h" +#include "som.h" +#include "tab.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +extern struct som_table_class tab_table_class; + +#if DEBUGGING +#define DEFFIRST(NAME, LABEL) LABEL, +#define DEFTAB(NAME, LABEL) LABEL, +static const char *tab_names[] = + { +#include "tab.def" + }; +#undef DEFFIRST +#undef DEFTAB +#endif + +/* Creates a table with NC columns and NR rows. If REALLOCABLE is + nonzero then the table's size can be increased later; otherwise, + its size can only be reduced. */ +struct tab_table * +tab_create (int nc, int nr, int reallocable) +{ + void *(*alloc_func) (struct pool *, size_t); + + struct tab_table *t; + + { + struct pool *container = pool_create (); + t = pool_alloc (container, sizeof *t); + t->container = container; + } + + t->col_style = TAB_COL_NONE; + t->col_group = 0; + ls_null (&t->title); + t->flags = SOMF_NONE; + t->nr = nr; + t->nc = t->cf = nc; + t->l = t->r = t->t = t->b = 0; + + alloc_func = reallocable ? pool_malloc : pool_alloc; +#if GLOBAL_DEBUGGING + t->reallocable = reallocable; +#endif + + t->cc = alloc_func (t->container, nr * nc * sizeof *t->cc); + t->ct = alloc_func (t->container, nr * nc); + memset (t->ct, TAB_EMPTY, nc * nr); + + t->rh = alloc_func (t->container, nc * (nr + 1)); + memset (t->rh, 0, nc * (nr + 1)); + + t->hrh = alloc_func (t->container, sizeof *t->hrh * (nr + 1)); + memset (t->hrh, 0, sizeof *t->hrh * (nr + 1)); + + t->trh = alloc_func (t->container, nr + 1); + memset (t->trh, 0, nr + 1); + + t->rv = alloc_func (t->container, (nc + 1) * nr); + memset (t->rv, 0, (nc + 1) * nr); + + t->wrv = alloc_func (t->container, sizeof *t->wrv * (nc + 1)); + memset (t->wrv, 0, sizeof *t->wrv * (nc + 1)); + + t->trv = alloc_func (t->container, nc + 1); + memset (t->trv, 0, nc + 1); + + t->dim = NULL; + t->w = t->h = NULL; + t->col_ofs = t->row_ofs = 0; + + return t; +} + +/* Destroys table T. */ +void +tab_destroy (struct tab_table *t) +{ + assert (t != NULL); + pool_destroy (t->container); +} + +/* Sets the width and height of a table, in columns and rows, + respectively. Use only to reduce the size of a table, since it + does not change the amount of allocated memory. */ +void +tab_resize (struct tab_table *t, int nc, int nr) +{ + assert (t != NULL); + if (nc != -1) + { + assert (nc + t->col_ofs <= t->cf); + t->nc = nc + t->col_ofs; + } + if (nr != -1) + { + assert (nr + t->row_ofs <= t->nr); + t->nr = nr + t->row_ofs; + } +} + +/* Changes either or both dimensions of a table. Consider using the + above routine instead if it won't waste a lot of space. + + Changing the number of columns in a table is particularly expensive + in space and time. Avoid doing such. FIXME: In fact, transferring + of rules isn't even implemented yet. */ +void +tab_realloc (struct tab_table *t, int nc, int nr) +{ + int ro, co; + + assert (t != NULL); +#if GLOBAL_DEBUGGING + assert (t->reallocable); +#endif + ro = t->row_ofs; + co = t->col_ofs; + if (ro || co) + tab_offset (t, 0, 0); + + if (nc == -1) + nc = t->nc; + if (nr == -1) + nr = t->nr; + + assert (nc == t->nc); + + if (nc > t->cf) + { + int mr1 = min (nr, t->nr); + int mc1 = min (nc, t->nc); + + struct len_string *new_cc; + unsigned char *new_ct; + int r; + + new_cc = pool_malloc (t->container, nr * nc * sizeof *new_cc); + new_ct = pool_malloc (t->container, nr * nc); + for (r = 0; r < mr1; r++) + { + memcpy (&new_cc[r * nc], &t->cc[r * t->nc], mc1 * sizeof *t->cc); + memcpy (&new_ct[r * nc], &t->ct[r * t->nc], mc1); + memset (&new_ct[r * nc + t->nc], TAB_EMPTY, nc - t->nc); + } + pool_free (t->container, t->cc); + pool_free (t->container, t->ct); + t->cc = new_cc; + t->ct = new_ct; + t->cf = nc; + } + else if (nr != t->nr) + { + t->cc = pool_realloc (t->container, t->cc, nr * nc * sizeof *t->cc); + t->ct = pool_realloc (t->container, t->ct, nr * nc); + + t->rh = pool_realloc (t->container, t->rh, nc * (nr + 1)); + t->rv = pool_realloc (t->container, t->rv, (nc + 1) * nr); + t->trh = pool_realloc (t->container, t->trh, nr + 1); + t->hrh = pool_realloc (t->container, t->hrh, + sizeof *t->hrh * (nr + 1)); + + if (nr > t->nr) + { + memset (&t->rh[nc * (t->nr + 1)], 0, (nr - t->nr) * nc); + memset (&t->rv[(nc + 1) * t->nr], 0, (nr - t->nr) * (nc + 1)); + memset (&t->trh[t->nr + 1], 0, nr - t->nr); + } + } + + memset (&t->ct[nc * t->nr], TAB_EMPTY, nc * (nr - t->nr)); + + t->nr = nr; + t->nc = nc; + + if (ro || co) + tab_offset (t, co, ro); +} + +/* Sets the number of header rows on each side of TABLE to L on the + left, R on the right, T on the top, B on the bottom. Header rows + are repeated when a table is broken across multiple columns or + multiple pages. */ +void +tab_headers (struct tab_table *table, int l, int r, int t, int b) +{ + assert (table != NULL); + table->l = l; + table->r = r; + table->t = t; + table->b = b; +} + +/* Set up table T so that, when it is an appropriate size, it will be + displayed across the page in columns. + + STYLE is a TAB_COL_* constant. GROUP is the number of rows to take + as a unit. */ +void +tab_columns (struct tab_table *t, int style, int group) +{ + assert (t != NULL); + t->col_style = style; + t->col_group = group; +} + +/* Rules. */ + +/* Draws a vertical line to the left of cells at horizontal position X + from Y1 to Y2 inclusive in style STYLE, if style is not -1. */ +void +tab_vline (struct tab_table *t, int style, int x, int y1, int y2) +{ + int y; + + assert (t != NULL); +#if GLOBAL_DEBUGGING + if (x + t->col_ofs < 0 || x + t->col_ofs > t->nc + || y1 + t->row_ofs < 0 || y1 + t->row_ofs >= t->nr + || y2 + t->row_ofs < 0 || y2 + t->row_ofs >= t->nr) + { + printf (_("bad vline: x=%d+%d=%d y=(%d+%d=%d,%d+%d=%d) in " + "table size (%d,%d)\n"), + x, t->col_ofs, x + t->col_ofs, + y1, t->row_ofs, y1 + t->row_ofs, + y2, t->row_ofs, y2 + t->row_ofs, + t->nc, t->nr); + return; + } +#endif + + x += t->col_ofs; + y1 += t->row_ofs; + y2 += t->row_ofs; + + if (style != -1) + { + if ((style & TAL_SPACING) == 0) + for (y = y1; y <= y2; y++) + t->rv[x + (t->cf + 1) * y] = style; + t->trv[x] |= (1 << (style & ~TAL_SPACING)); + } +} + +/* Draws a horizontal line above cells at vertical position Y from X1 + to X2 inclusive in style STYLE, if style is not -1. */ +void +tab_hline (struct tab_table * t, int style, int x1, int x2, int y) +{ + int x; + + assert (t != NULL); +#if GLOBAL_DEBUGGING + if (x1 + t->col_ofs < 0 || x1 + t->col_ofs >= t->nc + || x2 + t->col_ofs < 0 || x2 + t->col_ofs >= t->nc + || y + t->row_ofs < 0 || y + t->row_ofs > t->nr) + { + printf (_("bad hline: x=(%d+%d=%d,%d+%d=%d) y=%d+%d=%d " + "in table size (%d,%d)\n"), + x1, t->col_ofs, x1 + t->col_ofs, + x2, t->col_ofs, x2 + t->col_ofs, + y, t->row_ofs, y + t->row_ofs, + t->nc, t->nr); + return; + } +#endif + + x1 += t->col_ofs; + x2 += t->col_ofs; + y += t->row_ofs; + + if (style != -1) + { + if ((style & TAL_SPACING) == 0) + for (x = x1; x <= x2; x++) + t->rh[x + t->cf * y] = style; + t->trh[y] |= (1 << (style & ~TAL_SPACING)); + } +} + +/* Draws a box around cells (X1,Y1)-(X2,Y2) inclusive with horizontal + lines of style F_H and vertical lines of style F_V. Fills the + interior of the box with horizontal lines of style I_H and vertical + lines of style I_V. Any of the line styles may be -1 to avoid + drawing those lines. This is distinct from 0, which draws a null + line. */ +void +tab_box (struct tab_table *t, int f_h, int f_v, int i_h, int i_v, + int x1, int y1, int x2, int y2) +{ + assert (t != NULL); +#if GLOBAL_DEBUGGING + if (x1 + t->col_ofs < 0 || x1 + t->col_ofs >= t->nc + || x2 + t->col_ofs < 0 || x2 + t->col_ofs >= t->nc + || y1 + t->row_ofs < 0 || y1 + t->row_ofs >= t->nr + || y2 + t->row_ofs < 0 || y2 + t->row_ofs >= t->nr) + { + printf (_("bad box: (%d+%d=%d,%d+%d=%d)-(%d+%d=%d,%d+%d=%d) " + "in table size (%d,%d)\n"), + x1, t->col_ofs, x1 + t->col_ofs, + y1, t->row_ofs, y1 + t->row_ofs, + x2, t->col_ofs, x2 + t->col_ofs, + y2, t->row_ofs, y2 + t->row_ofs, + t->nc, t->nr); + abort (); + } +#endif + + x1 += t->col_ofs; + x2 += t->col_ofs; + y1 += t->row_ofs; + y2 += t->row_ofs; + + if (f_h != -1) + { + int x; + if ((f_h & TAL_SPACING) == 0) + for (x = x1; x <= x2; x++) + { + t->rh[x + t->cf * y1] = f_h; + t->rh[x + t->cf * (y2 + 1)] = f_h; + } + t->trh[y1] |= (1 << (f_h & ~TAL_SPACING)); + t->trh[y2 + 1] |= (1 << (f_h & ~TAL_SPACING)); + } + if (f_v != -1) + { + int y; + if ((f_v & TAL_SPACING) == 0) + for (y = y1; y <= y2; y++) + { + t->rv[x1 + (t->cf + 1) * y] = f_v; + t->rv[(x2 + 1) + (t->cf + 1) * y] = f_v; + } + t->trv[x1] |= (1 << (f_v & ~TAL_SPACING)); + t->trv[x2 + 1] |= (1 << (f_v & ~TAL_SPACING)); + } + + if (i_h != -1) + { + int y; + + for (y = y1 + 1; y <= y2; y++) + { + int x; + + if ((i_h & TAL_SPACING) == 0) + for (x = x1; x <= x2; x++) + t->rh[x + t->cf * y] = i_h; + + t->trh[y] |= (1 << (i_h & ~TAL_SPACING)); + } + } + if (i_v != -1) + { + int x; + + for (x = x1 + 1; x <= x2; x++) + { + int y; + + if ((i_v & TAL_SPACING) == 0) + for (y = y1; y <= y2; y++) + t->rv[x + (t->cf + 1) * y] = i_v; + + t->trv[x] |= (1 << (i_v & ~TAL_SPACING)); + } + } +} + +/* Formats text TEXT and arguments ARGS as indicated in OPT and sets + the resultant string into S in TABLE's pool. */ +static void +text_format (struct tab_table *table, int opt, const char *text, va_list args, + struct len_string *s) +{ + int len; + + assert (table != NULL && text != NULL && s != NULL); + + if (opt & TAT_PRINTF) + { + char *temp_buf = local_alloc (1024); + + len = nvsprintf (temp_buf, text, args); + text = temp_buf; + } + else + len = strlen (text); + + ls_create_buffer (table->container, s, text, len); + + if (opt & TAT_PRINTF) + local_free (text); +} + +/* Set the title of table T to TITLE, which is formatted with printf + if FORMAT is nonzero. */ +void +tab_title (struct tab_table *t, int format, const char *title, ...) +{ + va_list args; + + assert (t != NULL && title != NULL); + va_start (args, title); + text_format (t, format ? TAT_PRINTF : TAT_NONE, title, args, &t->title); + va_end (args); +} + +/* Set DIM_FUNC as the dimension function for table T. */ +void +tab_dim (struct tab_table *t, tab_dim_func *dim_func) +{ + assert (t != NULL && t->dim == NULL); + t->dim = dim_func; +} + +/* Returns the natural width of column C in table T for driver D, that + is, the smallest width necessary to display all its cells without + wrapping. The width will be no larger than the page width minus + left and right rule widths. */ +int +tab_natural_width (struct tab_table *t, struct outp_driver *d, int c) +{ + int width; + + assert (t != NULL && c >= 0 && c < t->nc); + { + int r; + + for (width = r = 0; r < t->nr; r++) + { + struct outp_text text; + unsigned char opt = t->ct[c + r * t->cf]; + + if (opt & (TAB_JOIN | TAB_EMPTY)) + continue; + + text.s = t->cc[c + r * t->cf]; + assert (!ls_null_p (&text.s)); + text.options = OUTP_T_JUST_LEFT; + + d->class->text_metrics (d, &text); + if (text.h > width) + width = text.h; + } + } + + if (width == 0) + { + width = d->prop_em_width * 8; +#if GLOBAL_DEBUGGING + printf ("warning: table column %d contains no data.\n", c); +#endif + } + + { + const int clamp = d->width - t->wrv[0] - t->wrv[t->nc]; + + if (width > clamp) + width = clamp; + } + + return width; +} + +/* Returns the natural height of row R in table T for driver D, that + is, the minimum height necessary to display the information in the + cell at the widths set for each column. */ +int +tab_natural_height (struct tab_table *t, struct outp_driver *d, int r) +{ + int height; + + assert (t != NULL && r >= 0 && r < t->nr); + + { + int c; + + for (height = d->font_height, c = 0; c < t->nc; c++) + { + struct outp_text text; + unsigned char opt = t->ct[c + r * t->cf]; + + assert (t->w[c] != NOT_INT); + if (opt & (TAB_JOIN | TAB_EMPTY)) + continue; + + text.s = t->cc[c + r * t->cf]; + assert (!ls_null_p (&text.s)); + text.options = OUTP_T_HORZ | OUTP_T_JUST_LEFT; + text.h = t->w[c]; + d->class->text_metrics (d, &text); + + if (text.v > height) + height = text.v; + } + } + + return height; +} + +/* Callback function to set all columns and rows to their natural + dimensions. Not really meant to be called directly. */ +void +tab_natural_dimensions (struct tab_table *t, struct outp_driver *d) +{ + int i; + + assert (t != NULL); + + for (i = 0; i < t->nc; i++) + t->w[i] = tab_natural_width (t, d, i); + + for (i = 0; i < t->nr; i++) + t->h[i] = tab_natural_height (t, d, i); +} + + +/* Cells. */ + +/* Sets cell (C,R) in TABLE, with options OPT, to have a value taken + from V, displayed with format spec F. */ +void +tab_value (struct tab_table *table, int c, int r, unsigned char opt, + const union value *v, const struct fmt_spec *f) +{ + char *contents; + union value temp_val; + + assert (table != NULL && v != NULL && f != NULL); +#if GLOBAL_DEBUGGING + if (c + table->col_ofs < 0 || r + table->row_ofs < 0 + || c + table->col_ofs >= table->nc + || r + table->row_ofs >= table->nr) + { + printf ("tab_value(): bad cell (%d+%d=%d,%d+%d=%d) in table size " + "(%d,%d)\n", + c, table->col_ofs, c + table->col_ofs, + r, table->row_ofs, r + table->row_ofs, + table->nc, table->nr); + return; + } +#endif + + contents = pool_alloc (table->container, f->w); + ls_init (&table->cc[c + r * table->cf], contents, f->w); + table->ct[c + r * table->cf] = opt; + + if (formats[f->type].cat & FCAT_STRING) + { + temp_val.c = (char *) v->s; + v = &temp_val; + } + data_out (contents, f, v); +} + +/* Sets cell (C,R) in TABLE, with options OPT, to have value VAL + with NDEC decimal places. */ +void +tab_float (struct tab_table *table, int c, int r, unsigned char opt, + double val, int w, int d) +{ + char *contents; + char buf[40], *cp; + + struct fmt_spec f; + + assert (table != NULL && w <= 40); + + f.type = FMT_F; + f.w = w; + f.d = d; + +#if GLOBAL_DEBUGGING + if (c + table->col_ofs < 0 || r + table->row_ofs < 0 + || c + table->col_ofs >= table->nc + || r + table->row_ofs >= table->nr) + { + printf ("tab_float(): bad cell (%d+%d=%d,%d+%d=%d) in table size " + "(%d,%d)\n", + c, table->col_ofs, c + table->col_ofs, + r, table->row_ofs, r + table->row_ofs, + table->nc, table->nr); + return; + } +#endif + + data_out (buf, &f, (union value *) &val); + cp = buf; + while (isspace ((unsigned char) *cp) && cp < &buf[w]) + cp++; + f.w = w - (cp - buf); + + contents = pool_alloc (table->container, f.w); + ls_init (&table->cc[c + r * table->cf], contents, f.w); + table->ct[c + r * table->cf] = opt; + memcpy (contents, cp, f.w); +} + +/* Sets cell (C,R) in TABLE, with options OPT, to have text value + TEXT. */ +void +tab_text (struct tab_table *table, int c, int r, unsigned opt, const char *text, ...) +{ + va_list args; + + assert (table != NULL && text != NULL); +#if GLOBAL_DEBUGGING + if (c + table->col_ofs < 0 || r + table->row_ofs < 0 + || c + table->col_ofs >= table->nc + || r + table->row_ofs >= table->nr) + { + printf ("tab_text(): bad cell (%d+%d=%d,%d+%d=%d) in table size " + "(%d,%d)\n", + c, table->col_ofs, c + table->col_ofs, + r, table->row_ofs, r + table->row_ofs, + table->nc, table->nr); + return; + } +#endif + + va_start (args, text); + text_format (table, opt, text, args, &table->cc[c + r * table->cf]); + table->ct[c + r * table->cf] = opt; + va_end (args); +} + +/* Joins cells (X1,X2)-(Y1,Y2) inclusive in TABLE, and sets them with + options OPT to have text value TEXT. */ +void +tab_joint_text (struct tab_table *table, int x1, int y1, int x2, int y2, + unsigned opt, const char *text, ...) +{ + struct tab_joined_cell *j; + + assert (table != NULL && text != NULL); +#if GLOBAL_DEBUGGING + if (x1 + table->col_ofs < 0 || x1 + table->col_ofs >= table->nc + || y1 + table->row_ofs < 0 || y1 + table->row_ofs >= table->nr + || x2 < x1 || x2 + table->col_ofs >= table->nc + || y2 < y2 || y2 + table->row_ofs >= table->nr) + { + printf ("tab_joint_text(): bad cell " + "(%d+%d=%d,%d+%d=%d)-(%d+%d=%d,%d+%d=%d) in table size (%d,%d)\n", + x1, table->col_ofs, x1 + table->col_ofs, + y1, table->row_ofs, y1 + table->row_ofs, + x2, table->col_ofs, x2 + table->col_ofs, + y2, table->row_ofs, y2 + table->row_ofs, + table->nc, table->nr); + return; + } +#endif + + j = pool_alloc (table->container, sizeof *j); + j->hit = 0; + j->x1 = x1 + table->col_ofs; + j->y1 = y1 + table->row_ofs; + j->x2 = ++x2 + table->col_ofs; + j->y2 = ++y2 + table->row_ofs; + + { + va_list args; + + va_start (args, text); + text_format (table, opt, text, args, &j->contents); + va_end (args); + } + + opt |= TAB_JOIN; + + { + struct len_string *cc = &table->cc[x1 + y1 * table->cf]; + unsigned char *ct = &table->ct[x1 + y1 * table->cf]; + const int ofs = table->cf - (x2 - x1); + + int y; + + for (y = y1; y < y2; y++) + { + int x; + + for (x = x1; x < x2; x++) + { + ls_init (cc++, (char *) j, 0); + *ct++ = opt; + } + + cc += ofs; + ct += ofs; + } + } +} + +/* Sets cell (C,R) in TABLE, with options OPT, to contents STRING. */ +void +tab_raw (struct tab_table *table, int c, int r, unsigned opt, + struct len_string *string) +{ + assert (table != NULL && string != NULL); + +#if GLOBAL_DEBUGGING + if (c + table->col_ofs < 0 || r + table->row_ofs < 0 + || c + table->col_ofs >= table->nc + || r + table->row_ofs >= table->nr) + { + printf ("tab_float(): bad cell (%d+%d=%d,%d+%d=%d) in table size " + "(%d,%d)\n", + c, table->col_ofs, c + table->col_ofs, + r, table->row_ofs, r + table->row_ofs, + table->nc, table->nr); + return; + } +#endif + + table->cc[c + r * table->cf] = *string; + table->ct[c + r * table->cf] = opt; +} + +/* Miscellaneous. */ + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +nowrap_dim (struct tab_table *t, struct outp_driver *d) +{ + t->w[0] = tab_natural_width (t, d, 0); + t->h[0] = d->font_height; +} + +/* Sets the widths of all the columns and heights of all the rows in + table T for driver D. */ +static void +wrap_dim (struct tab_table *t, struct outp_driver *d) +{ + t->w[0] = tab_natural_width (t, d, 0); + t->h[0] = tab_natural_height (t, d, 0); +} + +/* Outputs text BUF as a table with a single cell having cell options + OPTIONS, which is a combination of the TAB_* and TAT_* + constants. */ +void +tab_output_text (int options, const char *buf, ...) +{ + struct tab_table *t = tab_create (1, 1, 0); + + assert (buf != NULL); + if (options & TAT_PRINTF) + { + va_list args; + char *temp_buf = local_alloc (4096); + + va_start (args, buf); + nvsprintf (temp_buf, buf, args); + buf = temp_buf; + va_end (args); + } + + if (options & TAT_FIX) + { + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + { + if (!d->page_open) + d->class->open_page (d); + + d->class->text_set_font_by_name (d, "FIXED"); + } + } + + tab_text (t, 0, 0, options &~ TAT_PRINTF, buf); + tab_flags (t, SOMF_NO_TITLE | SOMF_NO_SPACING); + if (options & TAT_NOWRAP) + tab_dim (t, nowrap_dim); + else + tab_dim (t, wrap_dim); + tab_submit (t); + + if (options & TAT_FIX) + { + struct outp_driver *d; + + for (d = outp_drivers (NULL); d; d = outp_drivers (d)) + d->class->text_set_font_by_name (d, "PROP"); + } + + if (options & TAT_PRINTF) + local_free (buf); +} + +/* Set table flags to FLAGS. */ +void +tab_flags (struct tab_table *t, unsigned flags) +{ + assert (t != NULL); + t->flags = flags; +} + +/* Easy, type-safe way to submit a tab table to som. */ +void +tab_submit (struct tab_table *t) +{ + struct som_table s; + + assert (t != NULL); + s.class = &tab_table_class; + s.ext = t; + som_submit (&s); + tab_destroy (t); +} + +/* Editing. */ + +/* Set table row and column offsets for all functions that affect + cells or rules. */ +void +tab_offset (struct tab_table *t, int col, int row) +{ + int diff = 0; + + assert (t != NULL); +#if GLOBAL_DEBUGGING + if (row < -1 || row >= t->nr) + { + printf ("tab_offset(): row=%d in %d-row table\n", row, t->nr); + abort (); + } + if (col < -1 || col >= t->nc) + { + printf ("tab_offset(): col=%d in %d-column table\n", col, t->nc); + abort (); + } +#endif + + if (row != -1) + diff += (row - t->row_ofs) * t->cf, t->row_ofs = row; + if (col != -1) + diff += (col - t->col_ofs), t->col_ofs = col; + + t->cc += diff; + t->ct += diff; +} + +/* Increment the row offset by one. If the table is too small, + increase its size. */ +void +tab_next_row (struct tab_table *t) +{ + assert (t != NULL); + t->cc += t->cf; + t->ct += t->cf; + if (++t->row_ofs >= t->nr) + tab_realloc (t, -1, t->nr * 4 / 3); +} + +static struct tab_table *t; +static struct outp_driver *d; +int tab_hit; + +/* Set the current table to TABLE. */ +static void +tabi_table (struct som_table *table) +{ + assert (table != NULL); + t = table->ext; + tab_offset (t, 0, 0); + + assert (t->w == NULL && t->h == NULL); + t->w = pool_alloc (t->container, sizeof *t->w * t->nc); + t->h = pool_alloc (t->container, sizeof *t->h * t->nr); +} + +/* Set the current output device to DRIVER. */ +static void +tabi_driver (struct outp_driver *driver) +{ + int i; + + assert (driver != NULL); + d = driver; + + /* Figure out sizes of rules. */ + for (t->hr_tot = i = 0; i <= t->nr; i++) + t->hr_tot += t->hrh[i] = d->horiz_line_spacing[t->trh[i]]; + for (t->vr_tot = i = 0; i <= t->nc; i++) + t->vr_tot += t->wrv[i] = d->vert_line_spacing[t->trv[i]]; + +#if GLOBAL_DEBUGGING + for (i = 0; i < t->nr; i++) + t->h[i] = -1; + for (i = 0; i < t->nc; i++) + t->w[i] = -1; +#endif + + assert (t->dim != NULL); + t->dim (t, d); + +#if GLOBAL_DEBUGGING + { + int error = 0; + + for (i = 0; i < t->nr; i++) + { + if (t->h[i] == -1) + { + printf ("Table row %d height not initialized.\n", i); + error = 1; + } + assert (t->h[i] > 0); + } + + for (i = 0; i < t->nc; i++) + { + if (t->w[i] == -1) + { + printf ("Table column %d width not initialized.\n", i); + error = 1; + } + assert (t->w[i] > 0); + } + } +#endif + + /* Add up header sizes. */ + for (i = 0, t->wl = t->wrv[0]; i < t->l; i++) + t->wl += t->w[i] + t->wrv[i + 1]; + for (i = 0, t->ht = t->hrh[0]; i < t->t; i++) + t->ht += t->h[i] + t->hrh[i + 1]; + for (i = t->nc - t->r, t->wr = t->wrv[i]; i < t->nc; i++) + t->wr += t->w[i] + t->wrv[i + 1]; + for (i = t->nr - t->b, t->hb = t->hrh[i]; i < t->nr; i++) + t->hb += t->h[i] + t->hrh[i + 1]; + + /* Title. */ + if (!(t->flags & SOMF_NO_TITLE)) + t->ht += d->font_height; +} + +/* Return the number of columns and rows in the table into N_COLUMNS + and N_ROWS, respectively. */ +static void +tabi_count (int *n_columns, int *n_rows) +{ + assert (n_columns != NULL && n_rows != NULL); + *n_columns = t->nc; + *n_rows = t->nr; +} + +static void tabi_cumulate (int cumtype, int start, int *end, int max, int *actual); + +/* Return the horizontal and vertical size of the entire table, + including headers, for the current output device, into HORIZ and + VERT. */ +static void +tabi_area (int *horiz, int *vert) +{ + assert (horiz != NULL && vert != NULL); + + { + int w, c; + + for (c = t->l + 1, w = t->wl + t->wr + t->w[t->l]; + c < t->nc - t->r; c++) + w += t->w[c] + t->wrv[c]; + *horiz = w; + } + + { + int h, r; + for (r = t->t + 1, h = t->ht + t->hb + t->h[t->t]; + r < t->nr - t->b; r++) + h += t->h[r] + t->hrh[r]; + *vert = h; + } +} + +/* Return the column style for this table into STYLE. */ +static void +tabi_columns (int *style) +{ + assert (style != NULL); + *style = t->col_style; +} + +/* Return the number of header rows/columns on the left, right, top, + and bottom sides into HL, HR, HT, and HB, respectively. */ +static void +tabi_headers (int *hl, int *hr, int *ht, int *hb) +{ + assert (hl != NULL && hr != NULL && ht != NULL && hb != NULL); + *hl = t->l; + *hr = t->r; + *ht = t->t; + *hb = t->b; +} + +/* Determines the number of rows or columns (including appropriate + headers), depending on CUMTYPE, that will fit into the space + specified. Takes rows/columns starting at index START and attempts + to fill up available space MAX. Returns in END the index of the + last row/column plus one; returns in ACTUAL the actual amount of + space the selected rows/columns (including appropriate headers) + filled. */ +static void +tabi_cumulate (int cumtype, int start, int *end, int max, int *actual) +{ + int n; + int *d; + int *r; + int total; + + assert (end != NULL && (cumtype == SOM_ROWS || cumtype == SOM_COLUMNS)); + if (cumtype == SOM_ROWS) + { + assert (start >= 0 && start < t->nr); + n = t->nr - t->b; + d = &t->h[start]; + r = &t->hrh[start + 1]; + total = t->ht + t->hb; + } else { + assert (start >= 0 && start < t->nc); + n = t->nc - t->r; + d = &t->w[start]; + r = &t->wrv[start + 1]; + total = t->wl + t->wr; + } + + total += *d++; + if (total > max) + { + if (end) + *end = start; + if (actual) + *actual = 0; + return; + } + + { + int x; + + for (x = start + 1; x < n; x++) + { + int amt = *d++ + *r++; + + total += amt; + if (total > max) + { + total -= amt; + break; + } + } + + if (end) + *end = x; + + if (actual) + *actual = total; + } +} + +/* Return flags set for the current table into FLAGS. */ +static void +tabi_flags (unsigned *flags) +{ + assert (flags != NULL); + *flags = t->flags; +} + +/* Render title for current table, with major index X and minor index + Y. Y may be zero, or X and Y may be zero, but X should be nonzero + if Y is nonzero. */ +static void +tabi_title (int x, int y) +{ + char buf[1024]; + char *cp; + + if (t->flags & SOMF_NO_TITLE) + return; + + cp = spprintf (buf, "%d.%d", table_num, subtable_num); + if (x && y) + cp = spprintf (cp, "(%d:%d)", x, y); + else if (x) + cp = spprintf (cp, "(%d)", x); + if (cur_proc) + cp = spprintf (cp, " %s", cur_proc); + cp = stpcpy (cp, ". "); + if (!ls_empty_p (&t->title)) + { + memcpy (cp, ls_value (&t->title), ls_length (&t->title)); + cp += ls_length (&t->title); + } + *cp = 0; + + { + struct outp_text text; + + text.options = OUTP_T_JUST_LEFT | OUTP_T_HORZ | OUTP_T_VERT; + ls_init (&text.s, buf, cp - buf); + text.h = d->width; + text.v = d->font_height; + text.x = 0; + text.y = d->cp_y; + d->class->text_draw (d, &text); + } +} + +static int render_strip (int x, int y, int r, int c1, int c2, int r1, int r2); + +/* Execute BODY for each value of X from A to B exclusive. */ +#define UNROLL_LOOP(X, A, B, BODY) \ + do \ + { \ + for (X = A; X < B; X++) \ + { \ + BODY \ + } \ + } \ + while (0) + +/* Execute PREP, then BODY for each specified value of X: A1...A2, B1...B2, + C1...C2, in each case not including the second value. */ +#define UNROLL_3_LOOPS(X, A1, A2, B1, B2, C1, C2, BODY) \ + do \ + { \ + UNROLL_LOOP (X, A1, A2, BODY); \ + UNROLL_LOOP (X, B1, B2, BODY); \ + UNROLL_LOOP (X, C1, C2, BODY); \ + } \ + while (0) + +/* Draws the table region in rectangle (X1,Y1)-(X2,Y2), where column + X2 and row Y2 are not included in the rectangle, at the current + position on the current output device. Draws headers as well. */ +static void +tabi_render (int x1, int y1, int x2, int y2) +{ + int y, r; + + tab_hit++; + y = d->cp_y; + if (!(t->flags & SOMF_NO_TITLE)) + y += d->font_height; + UNROLL_3_LOOPS (r, 0, t->t * 2 + 1, y1 * 2 + 1, y2 * 2, + (t->nr - t->b) * 2, t->nr * 2 + 1, + + int x = d->cp_x; + x += render_strip (x, y, r, 0, t->l * 2 + 1, y1, y2); + x += render_strip (x, y, r, x1 * 2 + 1, x2 * 2, y1, y2); + x += render_strip (x, y, r, (t->nc - t->r) * 2, + t->nc * 2 + 1, y1, y2); + y += (r & 1) ? t->h[r / 2] : t->hrh[r / 2]; + ); +} + +struct som_table_class tab_table_class = + { + tabi_table, + tabi_driver, + + tabi_count, + tabi_area, + NULL, + NULL, + tabi_columns, + NULL, + tabi_headers, + NULL, + tabi_cumulate, + tabi_flags, + + NULL, + NULL, + + tabi_title, + tabi_render, + }; + +/* Render contiguous strip consisting of columns C1...C2, exclusive, + on row R, at location (X,Y). Return width of the strip thus + rendered. + + Renders joined cells, even those outside the strip, within the + rendering region (C1,R1)-(C2,R2). + + For the purposes of counting rows and columns in this function + only, horizontal rules are considered rows and vertical rules are + considered columns. + + FIXME: Doesn't use r1? Huh? */ +static int +render_strip (int x, int y, int r, int c1, int c2, int r1 unused, int r2) +{ + int x_origin = x; + + /* Horizontal rules. */ + if ((r & 1) == 0) + { + int hrh = t->hrh[r / 2]; + int c; + + for (c = c1; c < c2; c++) + { + if (c & 1) + { + int style = t->rh[(c / 2) + (r / 2 * t->cf)]; + + if (style != TAL_0) + { + const struct color clr = {0, 0, 0, 0}; + struct rect rct; + + rct.x1 = x; + rct.y1 = y; + rct.x2 = x + t->w[c / 2]; + rct.y2 = y + hrh; + d->class->line_horz (d, &rct, &clr, style); + } + x += t->w[c / 2]; + } else { + const struct color clr = {0, 0, 0, 0}; + struct rect rct; + struct outp_styles s; + + rct.x1 = x; + rct.y1 = y; + rct.x2 = x + t->wrv[c / 2]; + rct.y2 = y + hrh; + + s.t = r > 0 ? t->rv[(c / 2) + (t->cf + 1) * (r / 2 - 1)] : 0; + s.b = r < 2 * t->nr ? t->rv[(c / 2) + (t->cf + 1) * (r / 2)] : 0; + s.l = c > 0 ? t->rh[(c / 2 - 1) + t->cf * (r / 2)] : 0; + s.r = c < 2 * t->nc ? t->rh[(c / 2) + t->cf * (r / 2)] : 0; + + if (s.t | s.b | s.l | s.r) + d->class->line_intersection (d, &rct, &clr, &s); + + x += t->wrv[c / 2]; + } + } + } else { + int c; + + for (c = c1; c < c2; c++) + { + if (c & 1) + { + const int index = (c / 2) + (r / 2 * t->cf); + + if (!(t->ct[index] & TAB_JOIN)) + { + struct outp_text text; + + text.options = ((t->ct[index] & OUTP_T_JUST_MASK) + | OUTP_T_HORZ | OUTP_T_VERT); + if ((t->ct[index] & TAB_EMPTY) == 0) + { + text.s = t->cc[index]; + assert (!ls_null_p (&text.s)); + text.h = t->w[c / 2]; + text.v = t->h[r / 2]; + text.x = x; + text.y = y; + d->class->text_draw (d, &text); + } + } else { + struct tab_joined_cell *j = + (struct tab_joined_cell *) ls_value (&t->cc[index]); + + if (j->hit != tab_hit) + { + j->hit = tab_hit; + + if (j->x1 == c / 2 && j->y1 == r / 2 + && j->x2 <= c2 && j->y2 <= r2) + { + struct outp_text text; + + text.options = ((t->ct[index] & OUTP_T_JUST_MASK) + | OUTP_T_HORZ | OUTP_T_VERT); + text.s = j->contents; + text.x = x; + text.y = y; + + { + int c; + + for (c = j->x1, text.h = -t->wrv[j->x2]; + c < j->x2; c++) + text.h += t->w[c] + t->wrv[c + 1]; + } + + { + int r; + + for (r = j->y1, text.v = -t->hrh[j->y2]; + r < j->y2; r++) + text.v += t->h[r] + t->hrh[r + 1]; + } + d->class->text_draw (d, &text); + } + } + } + x += t->w[c / 2]; + } else { + int style = t->rv[(c / 2) + (r / 2 * (t->cf + 1))]; + + if (style != TAL_0) + { + const struct color clr = {0, 0, 0, 0}; + struct rect rct; + + rct.x1 = x; + rct.y1 = y; + rct.x2 = x + t->wrv[c / 2]; + rct.y2 = y + t->h[r / 2]; + d->class->line_vert (d, &rct, &clr, style); + } + x += t->wrv[c / 2]; + } + } + } + + return x - x_origin; +} + diff --git a/src/tab.h b/src/tab.h new file mode 100644 index 00000000..37e045c9 --- /dev/null +++ b/src/tab.h @@ -0,0 +1,195 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !tab_h +#define tab_h 1 + +#include +#include "str.h" + +/* Cell options. */ +enum + { + TAB_NONE = 0, + + /* Must match output.h: OUTP_T_JUST_*. */ + TAB_ALIGN_MASK = 03, /* Alignment mask. */ + TAB_RIGHT = 00, /* Right justify. */ + TAB_LEFT = 01, /* Left justify. */ + TAB_CENTER = 02, /* Center. */ + + /* Oddball cell types. */ + TAB_JOIN = 010, /* Joined cell. */ + TAB_EMPTY = 020 /* Empty cell. */ + }; + +/* Line styles. These must match output.h:OUTP_L_*. */ +enum + { + TAL_0 = 0, /* No line. */ + TAL_1 = 1, /* Single line. */ + TAL_2 = 2, /* Double line. */ + TAL_3 = 3, /* Special line of driver-defined style. */ + TAL_COUNT, /* Number of line styles. */ + + TAL_SPACING = 0200 /* Don't draw the line, just reserve space. */ + }; + +/* Column styles. Must correspond to SOM_COL_*. */ +enum + { + TAB_COL_NONE, /* No columns. */ + TAB_COL_DOWN /* Columns down first. */ + }; + +/* Joined cell. */ +struct tab_joined_cell + { + int x1, y1; + int x2, y2; + int hit; + struct len_string contents; + }; + +struct outp_driver; +struct tab_table; +typedef void tab_dim_func (struct tab_table *, struct outp_driver *); + +/* A table. */ +struct tab_table + { + struct pool *container; + + /* Contents. */ + int col_style; /* Columns: One of TAB_COL_*. */ + int col_group; /* Number of rows per column group. */ + struct len_string title; /* Table title. */ + unsigned flags; /* SOMF_*. */ + int nc, nr; /* Number of columns, rows. */ + int cf; /* Column factor for indexing purposes. */ + int l, r, t, b; /* Number of header rows on each side. */ + struct len_string *cc; /* Cell contents; len_string *[nr][nc]. */ + unsigned char *ct; /* Cell types; unsigned char[nr][nc]. */ + unsigned char *rh; /* Horiz rules; unsigned char[nr+1][nc]. */ + unsigned char *trh; /* Types of horiz rules; [nr+1]. */ + unsigned char *rv; /* Vert rules; unsigned char[nr][nc+1]. */ + unsigned char *trv; /* Types of vert rules; [nc+1]. */ + tab_dim_func *dim; /* Calculates cell widths and heights. */ + + /* Calculated during output. */ + int *w; /* Column widths; [nc]. */ + int *h; /* Row heights; [nr]. */ + int *hrh; /* Heights of horizontal rules; [nr+1]. */ + int *wrv; /* Widths of vertical rules; [nc+1]. */ + int wl, wr, ht, hb; /* Width/height of header rows/columns. */ + int hr_tot, vr_tot; /* Hrules total height, vrules total width. */ + + /* Editing info. */ + int col_ofs, row_ofs; /* X and Y offsets. */ +#if GLOBAL_DEBUGGING + int reallocable; /* Can table be reallocated? */ +#endif + }; + +extern int tab_hit; + +/* Number of rows in TABLE. */ +#define tab_nr(TABLE) ((TABLE)->nr) + +/* Number of columns in TABLE. */ +#define tab_nc(TABLE) ((TABLE)->nc) + +/* Number of left header columns in TABLE. */ +#define tab_l(TABLE) ((TABLE)->l) + +/* Number of right header columns in TABLE. */ +#define tab_r(TABLE) ((TABLE)->r) + +/* Number of top header rows in TABLE. */ +#define tab_t(TABLE) ((TABLE)->t) + +/* Number of bottom header rows in TABLE. */ +#define tab_b(TABLE) ((TABLE)->b) + +/* Tables. */ +struct tab_table *tab_create (int nc, int nr, int reallocable); +void tab_destroy (struct tab_table *); +void tab_resize (struct tab_table *, int nc, int nr); +void tab_realloc (struct tab_table *, int nc, int nr); +void tab_headers (struct tab_table *, int l, int r, int t, int b); +void tab_columns (struct tab_table *, int style, int group); +void tab_title (struct tab_table *, int format, const char *, ...); +void tab_flags (struct tab_table *, unsigned); +void tab_submit (struct tab_table *); + +/* Dimensioning. */ +tab_dim_func tab_natural_dimensions; +int tab_natural_width (struct tab_table *t, struct outp_driver *d, int c); +int tab_natural_height (struct tab_table *t, struct outp_driver *d, int r); +void tab_dim (struct tab_table *, tab_dim_func *); + +/* Rules. */ +void tab_hline (struct tab_table *, int style, int x1, int x2, int y); +void tab_vline (struct tab_table *, int style, int x, int y1, int y2); +void tab_box (struct tab_table *, int f_h, int f_v, int i_h, int i_v, + int x1, int y1, int x2, int y2); + +/* Text options, passed in the `opt' argument. */ +enum + { + TAT_NONE = 0, /* No options. */ + TAT_PRINTF = 0x0100, /* Format the text string with sprintf. */ + TAT_TITLE = 0x0204, /* Title attributes. */ + TAT_FIX = 0x0400, /* Use fixed-pitch font. */ + TAT_NOWRAP = 0x0800 /* No text wrap (tab_output_text() only). */ + }; + +/* Cells. */ +struct fmt_spec; +union value; +void tab_value (struct tab_table *, int c, int r, unsigned char opt, + const union value *, const struct fmt_spec *); +void tab_float (struct tab_table *, int c, int r, unsigned char opt, + double v, int w, int d); +void tab_text (struct tab_table *, int c, int r, unsigned opt, + const char *, ...) + __attribute__ ((format (printf, 5, 6))); +void tab_joint_text (struct tab_table *, int x1, int y1, int x2, int y2, + unsigned opt, const char *, ...) + __attribute__ ((format (printf, 7, 8))); + +/* Cell low-level access. */ +#define tab_alloc(TABLE, AMT) pool_alloc ((TABLE)->container, (AMT)) +void tab_raw (struct tab_table *, int c, int r, unsigned opt, + struct len_string *); + +/* Editing. */ +void tab_offset (struct tab_table *, int col, int row); +void tab_next_row (struct tab_table *); + +/* Current row/column offset. */ +#define tab_row(TABLE) ((TABLE)->row_ofs) +#define tab_col(TABLE) ((TABLE)->col_ofs) + +/* Simple output. */ +void tab_output_text (int options, const char *string, ...) + __attribute__ ((format (printf, 2, 3))); + +#endif /* tab_h */ + diff --git a/src/temporary.c b/src/temporary.c new file mode 100644 index 00000000..316fd649 --- /dev/null +++ b/src/temporary.c @@ -0,0 +1,333 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "do-ifP.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +int temporary; +struct dictionary *temp_dict; +int temp_trns; + +#if 0 +/* Displays all the value labels in TREE, with label S. */ +void +display_tree (char *s, avl_tree *tree) +{ + value_label *iter; + avl_traverser *trav = NULL; + + printf("%s tree:\n", s); + fflush(stdout); + while ((iter = avl_traverse (tree, &trav)) != NULL) + printf (" %g: %s\n", iter->v.f, iter->s); +} +#endif + +/* Parses the TEMPORARY command. */ +int +cmd_temporary (void) +{ + lex_match_id ("TEMPORARY"); + + /* TEMPORARY is not allowed inside DO IF or LOOP. */ + if (ctl_stack) + { + msg (SE, _("This command is not valid inside DO IF or LOOP.")); + return CMD_FAILURE; + } + + /* TEMPORARY can only appear once! */ + if (temporary) + { + msg (SE, _("This command may only appear once between " + "procedures and procedure-like commands.")); + return CMD_FAILURE; + } + + /* Everything is temporary, even if we think it'll last forever. + Especially then. */ + temporary = 1; + temp_dict = save_dictionary (); + if (f_trns == n_trns) + temp_trns = -1; + else + temp_trns = n_trns; + debug_printf (("TEMPORARY: temp_trns=%d\n", temp_trns)); + + return lex_end_of_command (); +} + +/* Copies a variable structure. */ +void +copy_variable (struct variable *dest, const struct variable *src) +{ + int i, n; + + assert (dest != src); + dest->type = src->type; + dest->left = src->left; + dest->width = src->width; + dest->fv = src->fv; + dest->nv = src->nv; + dest->miss_type = src->miss_type; + + switch (src->miss_type) + { + case MISSING_NONE: + n = 0; + break; + case MISSING_1: + n = 1; + break; + case MISSING_2: + case MISSING_RANGE: + n = 2; + break; + case MISSING_3: + case MISSING_RANGE_1: + n = 3; + break; + default: + assert (0); + break; + } + + for (i = 0; i < n; i++) + dest->missing[i] = src->missing[i]; + dest->print = src->print; + dest->write = src->write; + + dest->val_lab = copy_value_labels (src->val_lab); + dest->label = src->label ? xstrdup (src->label) : NULL; +} + +/* Returns a newly created empty dictionary. The file label and + documents are copied from default_dict if COPY is nonzero. */ +struct dictionary * +new_dictionary (int copy) +{ + struct dictionary *d = xmalloc (sizeof *d); + + d->var = NULL; + d->var_by_name = avl_create (NULL, cmp_variable, NULL); + d->nvar = 0; + + d->N = 0; + + d->nval = 0; + + d->n_splits = 0; + d->splits = NULL; + + if (default_dict.label && copy) + d->label = xstrdup (default_dict.label); + else + d->label = NULL; + + if (default_dict.n_documents && copy) + { + d->n_documents = default_dict.n_documents; + if (d->n_documents) + { + d->documents = malloc (default_dict.n_documents * 80); + memcpy (d->documents, default_dict.documents, + default_dict.n_documents * 80); + } + } + else + { + d->n_documents = 0; + d->documents = NULL; + } + + d->weight_index = -1; + d->weight_var[0] = 0; + + d->filter_var[0] = 0; + + return d; +} + +/* Copies the current dictionary info into a newly allocated + dictionary structure, which is returned. */ +struct dictionary * +save_dictionary (void) +{ + /* Dictionary being created. */ + struct dictionary *d; + + int i; + + d = xmalloc (sizeof *d); + + /* First the easy stuff. */ + *d = default_dict; + d->label = default_dict.label ? xstrdup (default_dict.label) : NULL; + if (default_dict.n_documents) + { + d->documents = malloc (default_dict.n_documents * 80); + memcpy (d->documents, default_dict.documents, + default_dict.n_documents * 80); + } + else d->documents = NULL; + + /* Then the variables. */ + d->var_by_name = avl_create (NULL, cmp_variable, NULL); + d->var = xmalloc (default_dict.nvar * sizeof *d->var); + for (i = 0; i < default_dict.nvar; i++) + { + d->var[i] = xmalloc (sizeof *d->var[i]); + copy_variable (d->var[i], default_dict.var[i]); + strcpy (d->var[i]->name, default_dict.var[i]->name); + d->var[i]->index = i; + avl_force_insert (d->var_by_name, d->var[i]); + } + + /* Then the SPLIT FILE variables. */ + if (default_dict.splits) + { + int i; + + d->n_splits = default_dict.n_splits; + d->splits = xmalloc ((default_dict.n_splits + 1) * sizeof *d->splits); + for (i = 0; i < default_dict.n_splits; i++) + d->splits[i] = d->var[default_dict.splits[i]->index]; + d->splits[default_dict.n_splits] = NULL; + } + else + { + d->n_splits = 0; + d->splits = NULL; + } + + return d; +} + +/* Copies dictionary D into the active file dictionary. Deletes + dictionary D. */ +void +restore_dictionary (struct dictionary * d) +{ + int i; + + /* 1. Delete the current dictionary. */ + default_dict.n_splits = 0; + free (default_dict.splits); + default_dict.splits = NULL; + + avl_destroy (default_dict.var_by_name, NULL); + default_dict.var_by_name = NULL; + + for (i = 0; i < default_dict.nvar; i++) + { + clear_variable (&default_dict, default_dict.var[i]); + free (default_dict.var[i]); + } + + free (default_dict.var); + free (default_dict.label); + free (default_dict.documents); + + /* 2. Copy dictionary D into the active file dictionary. */ +#if __CHECKER__ + { + size_t offset; + + offset = offsetof (struct dictionary, filter_var) + sizeof d->filter_var; + strncpy (d->weight_var, d->weight_var, 9); + strncpy (d->filter_var, d->filter_var, 9); + memset (&((char *) d)[offset], '*', sizeof *d - offset); + } +#endif + default_dict = *d; + if (!default_dict.var_by_name) + { + default_dict.var_by_name = avl_create (NULL, cmp_variable, NULL); + + for (i = 0; i < default_dict.nvar; i++) + avl_force_insert (default_dict.var_by_name, default_dict.var[i]); + } + + /* 3. Destroy dictionary D. */ + free (d); +} + +/* Destroys dictionary D. */ +void +free_dictionary (struct dictionary * d) +{ + int i; + + d->n_splits = 0; + free (d->splits); + d->splits = NULL; + + if (d->var_by_name) + avl_destroy (d->var_by_name, NULL); + + for (i = 0; i < d->nvar; i++) + { + struct variable *v = d->var[i]; + + if (v->val_lab) + { + avl_destroy (v->val_lab, free_val_lab); + v->val_lab = NULL; + } + if (v->label) + { + free (v->label); + v->label = NULL; + } + free (d->var[i]); + } + free (d->var); + + free (d->label); + free (d->documents); + + free (d); +} + +/* Cancels the temporary transformation, if any. */ +void +cancel_temporary (void) +{ + if (temporary) + { + if (temp_dict) + free_dictionary (temp_dict); + temporary = 0; + temp_trns = 0; + } +} diff --git a/src/title.c b/src/title.c new file mode 100644 index 00000000..cea04c63 --- /dev/null +++ b/src/title.c @@ -0,0 +1,179 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "main.h" +#include "output.h" +#include "var.h" +#include "version.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +static int get_title (const char *cmd, char **title); + +int +cmd_title (void) +{ + return get_title ("TITLE", &outp_title); +} + +int +cmd_subtitle (void) +{ + return get_title ("SUBTITLE", &outp_subtitle); +} + +static int +get_title (const char *cmd, char **title) +{ + int c; + + c = lex_look_ahead (); + debug_printf ((_("%s before: %s\n"), cmd, *title ? *title : _(""))); + if (c == '"' || c == '\'') + { + lex_get (); + if (!lex_force_string ()) + return CMD_FAILURE; + if (*title) + free (*title); + *title = xstrdup (ds_value (&tokstr)); + lex_get (); + if (token != '.') + { + msg (SE, _("%s: `.' expected after string."), cmd); + return CMD_FAILURE; + } + } + else + { + char *cp; + + if (*title) + free (*title); + *title = xstrdup (lex_rest_of_line (NULL)); + for (cp = *title; *cp; cp++) + *cp = toupper ((unsigned char) (*cp)); + token = '.'; + } + debug_printf ((_("%s after: %s\n"), cmd, *title)); + return CMD_SUCCESS; +} + +/* Performs the FILE LABEL command. */ +int +cmd_file_label (void) +{ + char *label; + + label = lex_rest_of_line (NULL); + while (isspace ((unsigned char) *label)) + label++; + + free (default_dict.label); + default_dict.label = xstrdup (label); + if (strlen (default_dict.label) > 60) + default_dict.label[60] = 0; + token = '.'; + + return CMD_SUCCESS; +} + +/* Add LINE as a line of document information to default_dict, + indented by INDENT spaces. */ +static void +add_document_line (const char *line, int indent) +{ + char *doc; + + default_dict.n_documents++; + default_dict.documents = xrealloc (default_dict.documents, + 80 * default_dict.n_documents); + doc = &default_dict.documents[80 * (default_dict.n_documents - 1)]; + memset (doc, ' ', indent); + st_bare_pad_copy (&doc[indent], line, 80 - indent); +} + +/* Performs the DOCUMENT command. */ +int +cmd_document (void) +{ + /* Add a few header lines for reference. */ + { + char buf[256]; + struct tm *tmp = localtime (&last_vfm_invocation); + + if (default_dict.n_documents) + add_document_line ("", 0); + + sprintf (buf, _("Document entered %s %02d:%02d:%02d by %s (%s):"), + curdate, tmp->tm_hour, tmp->tm_min, tmp->tm_sec, version, + host_system); + add_document_line (buf, 1); + } + + for (;;) + { + int had_dot; + char *line; + + line = lex_rest_of_line (&had_dot); + while (isspace ((unsigned char) *line)) + line++; + + if (had_dot) + { + char *cp = strchr (line, 0); + *cp++ = '.'; + *cp = 0; + } + + add_document_line (line, 3); + + lex_get_line (); + if (had_dot) + break; + } + + token = '.'; + return CMD_SUCCESS; +} + +/* Performs the DROP DOCUMENTS command. */ +int +cmd_drop_documents (void) +{ + lex_match_id ("DROP"); + lex_match_id ("DOCUMENTS"); + + free (default_dict.documents); + default_dict.documents = NULL; + default_dict.n_documents = 0; + + return lex_end_of_command (); +} diff --git a/src/val-labs.c b/src/val-labs.c new file mode 100644 index 00000000..ae9ac296 --- /dev/null +++ b/src/val-labs.c @@ -0,0 +1,306 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +/* Declarations. */ + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* Variable list. */ +static struct variable **v; + +/* Number of variables. */ +static int nv; + +static int do_value_labels (int); +static int verify_val_labs (int erase); +static int get_label (void); + +#if DEBUGGING +static void debug_print (void); +#endif + +/* Stubs. */ + +static void +init (void) +{ + v = NULL; +} + +static void +done (void) +{ + free (v); +} + +int +cmd_value_labels (void) +{ + int code; + init (); + lex_match_id ("VALUE"); + lex_match_id ("LABELS"); + code = do_value_labels (1); + done (); + return code; +} + +int +cmd_add_value_labels (void) +{ + int code; + lex_match_id ("ADD"); + lex_match_id ("VALUE"); + lex_match_id ("LABELS"); + code = do_value_labels (0); + done (); + return code; +} + +/* Do it. */ + +static int +do_value_labels (int erase) +{ + lex_match ('/'); + + while (token != '.') + { + parse_variables (NULL, &v, &nv, PV_SAME_TYPE); + if (!verify_val_labs (erase)) + return CMD_PART_SUCCESS_MAYBE; + while (token != '/' && token != '.') + if (!get_label ()) + return CMD_PART_SUCCESS_MAYBE; + + if (token != '/') + break; + lex_get (); + + free (v); + v = NULL; + } + + if (token != '.') + { + lex_error (NULL); + return CMD_TRAILING_GARBAGE; + } + +#if DEBUGGING + debug_print (); +#endif + return CMD_SUCCESS; +} + +static int +verify_val_labs (int erase) +{ + int i; + + if (!nv) + return 1; + + for (i = 0; i < nv; i++) + { + struct variable *vp = v[i]; + + if (vp->type == ALPHA && vp->width > 8) + { + msg (SE, _("It is not possible to assign value labels to long " + "string variables such as %s."), vp->name); + return 0; + } + + if (erase && v[i]->val_lab) + { + avl_destroy (vp->val_lab, free_val_lab); + vp->val_lab = NULL; + } + } + return 1; +} + +/* Parse all the labels for a particular set of variables and add the + specified labels to those variables. */ +static int +get_label (void) +{ + int i; + + /* Make sure there's some variables. */ + if (!nv) + { + if (token != T_STRING && token != T_NUM) + return 0; + lex_get (); + return 1; + } + + /* Parse all the labels and add them to the variables. */ + do + { + struct value_label *label; + + /* Allocate label. */ + label = xmalloc (sizeof *label); +#if __CHECKER__ + memset (&label->v, 0, sizeof label->v); +#endif + label->ref_count = nv; + + /* Set label->v. */ + if (v[0]->type == ALPHA) + { + if (token != T_STRING) + { + msg (SE, _("String expected for value.")); + return 0; + } + st_bare_pad_copy (label->v.s, ds_value (&tokstr), MAX_SHORT_STRING); + } + else + { + if (token != T_NUM) + { + msg (SE, _("Number expected for value.")); + return 0; + } + if (!lex_integer_p ()) + msg (SW, _("Value label `%g' is not integer."), tokval); + label->v.f = tokval; + } + + /* Set label->s. */ + lex_get (); + if (!lex_force_string ()) + return 0; + if (ds_length (&tokstr) > 60) + { + msg (SW, _("Truncating value label to 60 characters.")); + ds_truncate (&tokstr, 60); + } + label->s = xstrdup (ds_value (&tokstr)); + + for (i = 0; i < nv; i++) + { + if (!v[i]->val_lab) + v[i]->val_lab = avl_create (NULL, val_lab_cmp, + (void *) (v[i]->width)); + + { + struct value_label *old; + + old = avl_replace (v[i]->val_lab, label); + if (old) + free_value_label (old); + } + } + + lex_get (); + } + while (token != '/' && token != '.'); + + return 1; +} + +#if DEBUGGING +static void +debug_print () +{ + int i; + + puts (_("Value labels:")); + for (i = 0; i < nvar; i++) + { + AVLtraverser *t = NULL; + struct value_label *val; + + printf (" %s\n", var[i]->name); + if (var[i]->val_lab) + if (var[i]->type == NUMERIC) + for (val = avltrav (var[i]->val_lab, &t); + val; val = avltrav (var[i]->val_lab, &t)) + printf (" %g: `%s'\n", val->v.f, val->s); + else + for (val = avltrav (var[i]->val_lab, &t); + val; val = avltrav (var[i]->val_lab, &t)) + printf (" `%.8s': `%s'\n", val->v.s, val->s); + else + printf (_(" (no value labels)\n")); + } +} +#endif /* DEBUGGING */ + +/* Compares two value labels and returns a strcmp()-type result. */ +int +val_lab_cmp (const void *a, const void *b, void *param) +{ + if ((int) param) + return strncmp (((struct value_label *) a)->v.s, + ((struct value_label *) b)->v.s, + (int) param); + else + { + int temp = (((struct value_label *) a)->v.f + - ((struct value_label *) b)->v.f); + if (temp > 0) + return 1; + else if (temp < 0) + return -1; + else + return 0; + } +} + +/* Callback function to increment the reference count for a value + label. */ +void * +inc_ref_count (void *pv, void *param unused) +{ + ((struct value_label *) pv)->ref_count++; + return pv; +} + +/* Copy the avl tree of value labels and return a pointer to the + copy. */ +avl_tree * +copy_value_labels (avl_tree *src) +{ + avl_tree *dest; + + if (src == NULL) + return NULL; + dest = avl_copy (NULL, src, inc_ref_count); + + return dest; +} diff --git a/src/var-labs.c b/src/var-labs.c new file mode 100644 index 00000000..b573a4e8 --- /dev/null +++ b/src/var-labs.c @@ -0,0 +1,100 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +static void debug_print (void); +#endif + +int +cmd_variable_labels (void) +{ + struct variable **v; + int nv; + + int i; + + lex_match_id ("VARIABLE"); + lex_match_id ("LABELS"); + lex_match ('/'); + do + { + parse_variables (NULL, &v, &nv, PV_NONE); + + if (token != T_STRING) + { + msg (SE, _("String expected for variable label.")); + free (v); + return CMD_PART_SUCCESS_MAYBE; + } + if (ds_length (&tokstr) > 120) + { + msg (SW, _("Truncating variable label to 120 characters.")); + ds_truncate (&tokstr, 120); + } + for (i = 0; i < nv; i++) + { + if (v[i]->label) + free (v[i]->label); + v[i]->label = xstrdup (ds_value (&tokstr)); + } + + lex_get (); + while (token == '/') + lex_get (); + free (v); + } + while (token != '.'); +#if DEBUGGING + debug_print (); +#endif + return CMD_SUCCESS; +} + +#if DEBUGGING +static void +debug_print (void) +{ + int i; + + printf (_("Variable labels:\n")); + for (i = 0; i < nvar; i++) + { + printf (" %8s: ", var[i]->name); + if (var[i]->label) + printf ("`%s'", var[i]->label); + else + printf (_("(no variable label)")); + printf ("\n"); + } +} +#endif /* DEBUGGING */ diff --git a/src/var.h b/src/var.h new file mode 100644 index 00000000..38f0d74a --- /dev/null +++ b/src/var.h @@ -0,0 +1,535 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !var_h +#define var_h 1 + +#include "format.h" + +/* Values. */ + +/* Definition of the max length of a short string value, generally + eight characters. */ +#define MAX_SHORT_STRING ((SIZEOF_DOUBLE)>=8 ? ((SIZEOF_DOUBLE)+1)/2*2 : 8) +#define MIN_LONG_STRING (MAX_SHORT_STRING+1) + +/* FYI: It is a bad situation if sizeof(flt64) < MAX_SHORT_STRING: + then short string missing values can be truncated in system files + because there's only room for as many characters as can fit in a + flt64. */ +#if MAX_SHORT_STRING > 8 +#error MAX_SHORT_STRING must be less than 8. +#endif + +/* Special values. */ +#define SYSMIS (-DBL_MAX) +#define LOWEST second_lowest_value +#define HIGHEST DBL_MAX + +/* Describes one value, which is either a floating-point number or a + short string. */ +union value + { + /* A numeric value. */ + double f; + + /* A short-string value. */ + unsigned char s[MAX_SHORT_STRING]; + + /* This member is used by data-in.c to return a string result, + since it may need to return a long string. As currently + implemented, it's a pointer to a static internal buffer in + data-in.c. + + Also used by evaluate_expression() to return a string result. + As currently implemented, it's a pointer to a dynamic buffer in + the appropriate expression. + + Also used by the AGGREGATE procedure in handling string + values. */ + unsigned char *c; + + /* Sometimes we insert value's in a hash table. */ + unsigned long hash[SIZEOF_DOUBLE / SIZEOF_LONG]; + }; + +/* Describes one value label. */ +struct value_label + { + union value v; /* The value being labeled. */ + char *s; /* Pointer to malloc()'d label. */ + int ref_count; /* Reference count. */ + }; + +/* Frequency tables. */ + +/* Frequency table entry. */ +struct freq + { + union value v; /* The value. */ + double c; /* The number of occurrences of the value. */ + }; + +/* Types of frequency tables. */ +enum + { + FRQM_GENERAL, + FRQM_INTEGER + }; + +/* Entire frequency table. */ +struct freq_tab + { + int mode; /* FRQM_GENERAL or FRQM_INTEGER. */ + + /* General mode. */ + struct avl_tree *tree; /* Undifferentiated data. */ + + /* Integer mode. */ + double *vector; /* Frequencies proper. */ + int min, max; /* The boundaries of the table. */ + double out_of_range; /* Sum of weights of out-of-range values. */ + double sysmis; /* Sum of weights of SYSMIS values. */ + + /* All modes. */ + struct freq *valid; /* Valid freqs. */ + int n_valid; /* Number of total freqs. */ + + struct freq *missing; /* Missing freqs. */ + int n_missing; /* Number of missing freqs. */ + + /* Statistics. */ + double total_cases; /* Sum of weights of all cases. */ + double valid_cases; /* Sum of weights of valid cases. */ + }; + +/* A complete set of 3 frequency tables. */ +struct freq_tab_set + { + struct freq_tab miss; /* Includes user-missing values. */ + struct freq_tab no_miss; /* Excludes user-missing values. */ + struct freq_tab sel; /* Identical to either miss or no_miss. */ + }; + +/* Procedures' private per-variable data. */ + +/* Structure name suffixes for private data: + _proc: for a procedure (i.e., LIST -> list_proc). + _trns: for a transformation (i.e., COMPUTE -> compute_trns. + _pgm: for an input program (i.e., DATA LIST -> data_list_pgm). */ + +/* CROSSTABS private data. */ +struct crosstab_proc + { + /* Integer mode only. */ + int min; /* Minimum value. */ + int max; /* Maximum value + 1. */ + int count; /* max - min. */ + }; + +/* FREQUENCIES private data. */ +enum + { + frq_mean = 0, frq_semean, frq_median, frq_mode, frq_stddev, frq_variance, + frq_kurt, frq_sekurt, frq_skew, frq_seskew, frq_range, frq_min, frq_max, + frq_sum, frq_n_stats + }; + +struct frequencies_proc + { + /* General mode. */ + struct freq_tab tab; /* Frequencies table to use. */ + + /* Percentiles. */ + int n_groups; /* Number of groups. */ + double *groups; /* Groups. */ + + /* Statistics. */ + double stat[frq_n_stats]; + }; + +/* LIST private data. */ +struct list_proc + { + int newline; /* Whether a new line begins here. */ + int width; /* Field width. */ + int vert; /* Whether to print the varname vertically. */ + }; + +/* DESCRIPTIVES private data. Note that the DESCRIPTIVES procedure also + has a transformation, descriptives_trns. */ +enum + { + /* As these are used as bit indexes, there must be 32 or fewer. + Be very careful in adjusting these, see the structure below + and the table in descriptives.q. */ + dsc_mean = 0, dsc_semean, dsc_stddev, dsc_variance, dsc_kurt, + dsc_sekurt, dsc_skew, dsc_seskew, dsc_range, dsc_min, + dsc_max, dsc_sum, dsc_n_stats + }; + +struct descriptives_proc + { + /* Miscellaneous. */ + int dup; /* Finds duplicates in list of + variables. */ + char zname[10]; /* Name for z-score variable. */ + + /* Counts. */ + double valid, miss; /* Valid, missing--general. */ + + /* Mean, moments about the mean. */ + double X_bar, M2, M3, M4; + double min, max; + + /* Statistics. */ + double stats[dsc_n_stats]; /* Everything glommed together. */ + }; + +/* GET private data. */ +struct get_proc + { + int fv, nv; /* First, last, # of values. */ + }; + +/* Sort order. */ +enum + { + SRT_ASCEND, /* A, B, C, ..., X, Y, Z. */ + SRT_DESCEND /* Z, Y, X, ..., C, B, A. */ + }; + +/* SORT CASES private data. */ +struct sort_cases_proc + { + int order; /* SRT_ASCEND or SRT_DESCEND. */ + }; + +/* MODIFY VARS private data. */ +struct modify_vars_proc + { + char new_name[9]; /* Variable's new name. */ + int drop_this_var; /* 0=keep this var, 1=drop this var. */ + struct variable *next; /* Next in linked list. */ + }; + +/* MEANS private data. */ +struct means_proc + { + double min, max; /* Range for integer mode. */ + }; + +/* Different types of variables for MATRIX DATA procedure. Order is + important: these are used for sort keys. */ +enum + { + MXD_SPLIT, /* SPLIT FILE variables. */ + MXD_ROWTYPE, /* ROWTYPE_. */ + MXD_FACTOR, /* Factor variables. */ + MXD_VARNAME, /* VARNAME_. */ + MXD_CONTINUOUS, /* Continuous variables. */ + + MXD_COUNT + }; + +/* MATRIX DATA private data. */ +struct matrix_data_proc + { + int vartype; /* Variable type. */ + int subtype; /* Subtype. */ + }; + +/* MATCH FILES private data. */ +struct match_files_proc + { + struct variable *master; /* Corresponding master file variable. */ + }; + + +/* Script variables. */ + +/* Variable type. */ +enum + { + NUMERIC, /* A numeric variable. */ + ALPHA /* A string variable. (STRING is pre-empted by lexer.h) */ + }; + +/* Types of missing values. Order is significant, see + mis-val.c:parse_numeric(), sfm-read.c:sfm_read_dictionary() + sfm-write.c:sfm_write_dictionary(), + sysfile-info.c:cmd_sysfile_info(), mis-val.c:copy_missing_values(), + pfm-read.c:read_variables(), pfm-write.c:write_variables(), + apply-dict.c:cmd_apply_dictionary(), and more (?). */ +enum + { + MISSING_NONE, /* No user-missing values. */ + MISSING_1, /* One user-missing value. */ + MISSING_2, /* Two user-missing values. */ + MISSING_3, /* Three user-missing values. */ + MISSING_RANGE, /* [a,b]. */ + MISSING_LOW, /* (-inf,a]. */ + MISSING_HIGH, /* (a,+inf]. */ + MISSING_RANGE_1, /* [a,b], c. */ + MISSING_LOW_1, /* (-inf,a], b. */ + MISSING_HIGH_1, /* (a,+inf), b. */ + MISSING_COUNT + }; + +/* A variable's dictionary entry. Note: don't reorder name[] from the + first element; a pointer to `variable' should be a pointer to + member `name'.*/ +struct variable + { + /* Required by parse_variables() to be in this order. */ + char name[9]; /* As a string. */ + int index; /* Index into its dictionary's var[]. */ + int type; /* NUMERIC or ALPHA. */ + int foo; /* Used for temporary storage. */ + + /* Also important but parse_variables() doesn't need it. Still, + check before reordering. */ + int width; /* Size of string variables in chars. */ + int fv, nv; /* Index into `value's, number of values. */ + int left; /* 0=do not LEAVE, 1=LEAVE. */ + + /* Missing values. */ + int miss_type; /* One of the MISSING_* constants. */ + union value missing[3]; /* User-missing value. */ + + /* Display formats. */ + struct fmt_spec print; /* Default format for PRINT. */ + struct fmt_spec write; /* Default format for WRITE. */ + + /* Labels. */ + struct avl_tree *val_lab; /* Avltree of value_label structures. */ + char *label; /* Variable label. */ + + /* Per-procedure info. */ + struct get_proc get; + union + { + struct crosstab_proc crs; + struct descriptives_proc dsc; + struct frequencies_proc frq; + struct list_proc lst; + struct means_proc mns; + struct sort_cases_proc srt; + struct modify_vars_proc mfv; + struct matrix_data_proc mxd; + struct match_files_proc mtf; + } + p; + }; + +/* Cases. */ + +/* A single case. (This doesn't need to be a struct anymore, but it + remains so for hysterical raisins.) */ +struct ccase + { + union value data[1]; + }; + +/* Dictionary. */ + +/* Complete dictionary state. */ +struct dictionary + { + struct variable **var; /* Variable descriptions. */ + struct avl_tree *var_by_name; /* Variables arranged by name. */ + int nvar; /* Number of variables. */ + + int N; /* Current case limit (N command). */ + int nval; /* Number of value structures per case. */ + + int n_splits; /* Number of SPLIT FILE variables. */ + struct variable **splits; /* List of SPLIT FILE vars. */ + + char *label; /* File label. */ + + int n_documents; /* Number of lines of documents. */ + char *documents; /* Documents; 80*n_documents bytes in size. */ + + int weight_index; /* `value' index of $WEIGHT, or -1 if none. + Call update_weighting() before using! */ + char weight_var[9]; /* Name of WEIGHT variable. */ + + char filter_var[9]; /* Name of FILTER variable. */ + /* Do not make another field the last field! or see + temporary.c:restore_dictionary() before doing so! */ + }; + +/* This is the active file dictionary. */ +extern struct dictionary default_dict; + +/* Transformation state. */ + +/* Default file handle for DATA LIST, REREAD, REPEATING DATA + commands. */ +extern struct file_handle *default_handle; + +/* PROCESS IF expression. */ +extern struct expression *process_if_expr; + +/* TEMPORARY support. */ + +/* 1=TEMPORARY has been executed at some point. */ +extern int temporary; + +/* If temporary!=0, the saved dictionary. */ +extern struct dictionary *temp_dict; + +/* If temporary!=0, index into t_trns[] (declared far below) that + gives the point at which data should be written out. -1 means that + the data shouldn't be changed since all transformations are + temporary. */ +extern int temp_trns; + +/* If FILTER is active, whether it was executed before or after + TEMPORARY. */ +extern int FILTER_before_TEMPORARY; + +void cancel_temporary (void); + +/* Functions. */ + +int is_varname (const char *); +int is_dict_varname (const struct dictionary *, const char *); + +/* Flags for passing to fill_all_vars(). */ +enum + { + FV_NONE = 0, /* No flags. */ + FV_NO_SYSTEM = 001, /* Don't include system variables. */ + FV_NO_SCRATCH = 002 /* Don't include scratch variables. */ + }; + +void fill_all_vars (struct variable ***, int *, int flags); + +int val_lab_cmp (const void *, const void *, void *); +char *get_val_lab (const struct variable *, union value, int); +void free_val_lab (void *, void *); +void free_value_label (struct value_label *); +struct avl_tree *copy_value_labels (struct avl_tree *); + +void dump_split_vars (const struct ccase *); + +int is_num_user_missing (double, const struct variable *); +int is_str_user_missing (const unsigned char[], const struct variable *); +int is_missing (const union value *, const struct variable *); +int is_system_missing (const union value *, const struct variable *); +int is_user_missing (const union value *, const struct variable *); +void copy_missing_values (struct variable *dest, const struct variable *src); + +int cmp_variable (const void *, const void *, void *); + +#if GLOBAL_DEBUGGING +struct variable *force_create_variable (struct dictionary *, const char *name, + int type, int width); +struct variable *force_dup_variable (struct dictionary *, + const struct variable *src, + const char *name); +#else +#define force_create_variable(A, B, C, D) \ + create_variable (A, B, C, D) +#define force_dup_variable(A, B, C) \ + dup_variable (A, B, C) +#endif + +struct variable *create_variable (struct dictionary *, const char *name, + int type, int width); +void delete_variable (struct dictionary *, struct variable *v); +struct variable *find_variable (const char *name); +struct variable *find_dict_variable (const struct dictionary *, + const char *name); +void init_variable (struct dictionary *, struct variable *, const char *name, + int type, int width); +void replace_variable (struct variable *, const char *name, + int type, int width); +void clear_variable (struct dictionary *, struct variable *); +void rename_variable (struct dictionary *, struct variable *v, + const char *new_name); +void discard_variables (void); +void clear_default_dict (void); +void copy_variable (struct variable *dest, const struct variable *src); +struct variable *dup_variable (struct dictionary *dict, + const struct variable *src, const char *name); + +struct variable *update_weighting (struct dictionary *); +void stop_weighting (struct dictionary *); + +struct dictionary *save_dictionary (void); +void restore_dictionary (struct dictionary *); +void free_dictionary (struct dictionary *); +struct dictionary *new_dictionary (int copy); + +/* Transformations. */ + +/* Header for all transformations. */ +struct trns_header + { + /* Index into t_trns[]. */ + int index; + + /* Transformation proc. */ + int (*proc) (struct trns_header *, struct ccase *); + + /* Garbage collector proc. */ + void (*free) (struct trns_header *); + }; + +/* Array of transformations */ +extern struct trns_header **t_trns; + +/* Number of transformations, maximum number in array currently. */ +extern int n_trns, m_trns; + +/* Index of first transformation that is really a transformation. Any + transformations before this belong to INPUT PROGRAM. */ +extern int f_trns; + +void add_transformation (struct trns_header *trns); +void cancel_transformations (void); + +/* Variable parsers. */ + +/* Only parse_variables() supports options other than PV_APPEND, + PV_SINGLE. */ +enum + { + PV_NONE = 0, /* No options. */ + PV_SINGLE = 0001, /* Restrict to a single varname or TO use. */ + PV_DUPLICATE = 0002, /* Don't merge duplicates. */ + PV_APPEND = 0004, /* Append to existing list. */ + PV_NO_DUPLICATE = 0010, /* Error on duplicates. */ + PV_NUMERIC = 0020, /* Vars must be numeric. */ + PV_STRING = 0040, /* Vars must be string. */ + PV_SAME_TYPE = 00100, /* All vars must be the same type. */ + PV_NO_SCRATCH = 00200 /* Disallow scratch variables. */ + }; + +struct variable *parse_variable (void); +struct variable *parse_dict_variable (struct dictionary *); +int parse_variables (struct dictionary *dict, struct variable ***v, + int *nv, int pv_opts); +int parse_DATA_LIST_vars (char ***names, int *nnames, int pv_opts); +int parse_mixed_vars (char ***names, int *nnames, int pv_opts); + +#endif /* !var_h */ diff --git a/src/vars-atr.c b/src/vars-atr.c new file mode 100644 index 00000000..3f4ea7fd --- /dev/null +++ b/src/vars-atr.c @@ -0,0 +1,570 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "approx.h" +#include "avl.h" +#include "command.h" +#include "do-ifP.h" +#include "expr.h" +#include "file-handle.h" +#include "inpt-pgm.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vector.h" +#include "vfm.h" + +#undef DEBUGGING +/*#define DEBUGGING 1*/ +#include "debug-print.h" + +#if DEBUGGING +/* Dumps one variable to standard output. */ +void +dump_one_var_node (void * pnode, void *param, int level) +{ + variable *node = pnode; + int i; + + for (i = 0; i < level - 1; i++) + printf (" "); + if (node == NULL) + printf ("NULL_TREE\n"); + else + printf ("%p=>%s\n", node, node->name ? node->name : ""); +} + +/* Dumps a tree of the variables to standard output. */ +void +dump_var_tree (void) +{ + printf (_("Vartree:\n")); + avl_walk_inorder (default_dict.var_by_name, dump_one_var_node, NULL); +} +#endif + +/* Clear the default dictionary. Note: This is probably not what you + want to do. Use discard_variables() instead. */ +void +clear_default_dict (void) +{ + int i; + + for (i = 0; i < default_dict.nvar; i++) + { + clear_variable (&default_dict, default_dict.var[i]); + free (default_dict.var[i]); + } + + assert (default_dict.splits == NULL); + + default_dict.nvar = 0; + default_dict.N = 0; + default_dict.nval = 0; + default_handle = inline_file; + stop_weighting (&default_dict); +} + +/* Discards all the current state in preparation for a data-input + command like DATA LIST or GET. */ +void +discard_variables (void) +{ + clear_default_dict (); + + n_lag = 0; + + if (vfm_source) + { + vfm_source->destroy_source (); + vfm_source = NULL; + } + + cancel_transformations (); + + ctl_stack = NULL; + + free (vec); + vec = NULL; + nvec = 0; + + expr_free (process_if_expr); + process_if_expr = NULL; + + cancel_temporary (); + + pgm_state = STATE_INIT; +} + +/* Find and return the variable in default_dict having name NAME, or + NULL if no such variable exists in default_dict. */ +struct variable * +find_variable (const char *name) +{ + return avl_find (default_dict.var_by_name, (struct variable *) name); +} + +/* Find and return the variable in dictionary D having name NAME, or + NULL if no such variable exists in D. */ +struct variable * +find_dict_variable (const struct dictionary *d, const char *name) +{ + return avl_find (d->var_by_name, (struct variable *) name); +} + +/* Creates a variable named NAME in dictionary DICT having type TYPE + (ALPHA or NUMERIC) and, if type==ALPHA, width WIDTH. Returns a + pointer to the newly created variable if successful. On failure + (which indicates that a variable having the specified name already + exists), returns NULL. */ +struct variable * +create_variable (struct dictionary *dict, const char *name, + int type, int width) +{ + if (find_dict_variable (dict, name)) + return NULL; + + { + struct variable *new_var; + + dict->var = xrealloc (dict->var, (dict->nvar + 1) * sizeof *dict->var); + new_var = dict->var[dict->nvar] = xmalloc (sizeof *new_var); + + new_var->index = dict->nvar; + dict->nvar++; + + init_variable (dict, new_var, name, type, width); + + return new_var; + } +} + +#if GLOBAL_DEBUGGING +/* For situations in which we know that there are no variables with an + identical name in the dictionary. */ +struct variable * +force_create_variable (struct dictionary *dict, const char *name, + int type, int width) +{ + struct variable *new_var = create_variable (dict, name, type, width); + assert (new_var != NULL); + return new_var; +} + +/* For situations in which we know that there are no variables with an + identical name in the dictionary. */ +struct variable * +force_dup_variable (struct dictionary *dict, const struct variable *src, + const char *name) +{ + struct variable *new_var = dup_variable (dict, src, name); + assert (new_var != NULL); + return new_var; +} +#endif + +/* Delete variable V from DICT. It should only be used when there are + guaranteed to be absolutely NO REFERENCES to it, for instance in + the very same function that created it. */ +void +delete_variable (struct dictionary *dict, struct variable *v) +{ + int i; + + clear_variable (dict, v); + dict->nvar--; + for (i = v->index; i < dict->nvar; i++) + { + dict->var[i] = dict->var[i + 1]; + dict->var[i]->index = i; + } + free (v); +} + +/* Initialize fields in variable V inside dictionary D with name NAME, + type TYPE, and width WIDTH. Initializes some other fields too. */ +static inline void +common_init_stuff (struct dictionary *dict, struct variable *v, + const char *name, int type, int width) +{ + if (v->name != name) + /* Avoid problems with overlap. */ + strcpy (v->name, name); + + avl_force_insert (dict->var_by_name, v); + + v->type = type; + v->left = name[0] == '#'; + v->width = type == NUMERIC ? 0 : width; + v->miss_type = MISSING_NONE; + if (v->type == NUMERIC) + { + v->print.type = FMT_F; + v->print.w = 8; + v->print.d = 2; + } + else + { + v->print.type = FMT_A; + v->print.w = v->width; + v->print.d = 0; + } + v->write = v->print; +} + +/* Initialize (for the first time) a variable V in dictionary DICT + with name NAME, type TYPE, and width WIDTH. */ +void +init_variable (struct dictionary *dict, struct variable *v, const char *name, + int type, int width) +{ + common_init_stuff (dict, v, name, type, width); + v->nv = type == NUMERIC ? 1 : DIV_RND_UP (width, 8); + v->fv = dict->nval; + dict->nval += v->nv; + v->label = NULL; + v->val_lab = NULL; + v->get.fv = -1; + + if (vfm_source == &input_program_source + || vfm_source == &file_type_source) + { + size_t nbytes = DIV_RND_UP (v->fv + 1, 4); + unsigned val = 0; + + if (inp_init_size < nbytes) + { + inp_init = xrealloc (inp_init, nbytes); + memset (&inp_init[inp_init_size], 0, nbytes - inp_init_size); + inp_init_size = nbytes; + } + + if (v->type == ALPHA) + val |= INP_STRING; + if (v->left) + val |= INP_LEFT; + inp_init[v->fv / 4] |= val << ((unsigned) (v->fv) % 4 * 2); + } +} + +/* Replace variable V in default_dict with a different variable having + name NAME, type TYPE, and width WIDTH. */ +void +replace_variable (struct variable *v, const char *name, int type, int width) +{ + int nv; + + assert (v && name && (type == NUMERIC || type == ALPHA) && width >= 0 + && (type == ALPHA || width == 0)); + clear_variable (&default_dict, v); + common_init_stuff (&default_dict, v, name, type, width); + + nv = (type == NUMERIC) ? 1 : DIV_RND_UP (width, 8); + if (nv > v->nv) + { + v->fv = v->nv = 0; + v->fv = default_dict.nval; + default_dict.nval += nv; + } + v->nv = nv; +} + +/* Changes the name of variable V in dictionary DICT to name NEW_NAME. + NEW_NAME must be known not to already exist in dictionary DICT. */ +void +rename_variable (struct dictionary * dict, struct variable *v, + const char *new_name) +{ + assert (dict && dict->var_by_name && v && new_name); + avl_delete (dict->var_by_name, v); + strncpy (v->name, new_name, 9); + avl_force_insert (dict->var_by_name, v); +} + +/* Delete the contents of variable V within dictionary DICT. Does not + remove the variable from the vector of variables in the dictionary. + Use with caution. */ +void +clear_variable (struct dictionary *dict, struct variable *v) +{ + assert (dict && v); + +#if DEBUGGING + printf (_("clearing variable %d:%s %s\n"), v->index, v->name, + (dict == &default_dict ? _("in default dictionary") + : _("in auxiliary dictionary"))); + if (dict->var_by_name != NULL) + dump_var_tree (); +#endif + + if (dict->var_by_name != NULL) + avl_force_delete (dict->var_by_name, v); + + if (v->val_lab) + { + avl_destroy (v->val_lab, free_val_lab); + v->val_lab = NULL; + } + + if (v->label) + { + free (v->label); + v->label = NULL; + } + + if (dict->splits) + { + struct variable **iter, **trailer; + + for (trailer = iter = dict->splits; *iter; iter++) + if (*iter != v) + *trailer++ = *iter; + else + dict->n_splits--; + + *trailer = NULL; + + if (dict->n_splits == 0) + { + free (dict->splits); + dict->splits = NULL; + } + } + +#if DEBUGGING + if (dict->var_by_name != NULL) + dump_var_tree (); +#endif +} + +/* Creates a new variable in dictionary DICT, whose properties are + copied from variable SRC, and returns a pointer to the new variable + of name NAME, if successful. If unsuccessful (which only happens + if a variable of the same name NAME exists in DICT), returns + NULL. */ +struct variable * +dup_variable (struct dictionary *dict, const struct variable *src, + const char *name) +{ + if (find_dict_variable (dict, name)) + return NULL; + + { + struct variable *new_var; + + dict->var = xrealloc (dict->var, (dict->nvar + 1) * sizeof *dict->var); + new_var = dict->var[dict->nvar] = xmalloc (sizeof *new_var); + + new_var->index = dict->nvar; + new_var->foo = -1; + new_var->get.fv = -1; + new_var->get.nv = -1; + dict->nvar++; + + copy_variable (new_var, src); + + assert (new_var->nv >= 0); + new_var->fv = dict->nval; + dict->nval += new_var->nv; + + strcpy (new_var->name, name); + avl_force_insert (dict->var_by_name, new_var); + + return new_var; + } +} + + +/* Decrements the reference count for value label V. Destroys the + value label if the reference count reaches zero. */ +void +free_value_label (struct value_label * v) +{ + assert (v->ref_count >= 1); + if (--v->ref_count == 0) + { + free (v->s); + free (v); + } +} + +/* Frees value label P. PARAM is ignored. Used as a callback with + avl_destroy(). */ +void +free_val_lab (void *p, void *param unused) +{ + free_value_label ((struct value_label *) p); +} + +/* Returns a value label corresponding to VAL in variable V padded to + length N. If N==0 then no padding is performed, and NULL is + returned if no label exists. (Normally a string of spaces is + returned in this case.) */ +char * +get_val_lab (const struct variable *v, union value val, int n) +{ + static char *buf; + static int bufsize; + struct value_label template, *find; + + if (bufsize < n) + { + buf = xrealloc (buf, n + 1); + bufsize = n; + } + if (n) + buf[0] = 0; + template.v = val; + find = NULL; + if (v->val_lab) + find = avl_find (v->val_lab, &template); + if (find) + { + if (n) + { + st_pad_copy (buf, find->s, n + 1); + return buf; + } + else + return find->s; + } + else + { + if (n) + { + memset (buf, ' ', n); + buf[n] = '\0'; + return buf; + } + else + return NULL; + } +} + +/* Return nonzero only if X is a user-missing value for numeric + variable V. */ +inline int +is_num_user_missing (double x, const struct variable *v) +{ + switch (v->miss_type) + { + case MISSING_NONE: + return 0; + case MISSING_1: + return approx_eq (x, v->missing[0].f); + case MISSING_2: + return (approx_eq (x, v->missing[0].f) + || approx_eq (x, v->missing[1].f)); + case MISSING_3: + return (approx_eq (x, v->missing[0].f) + || approx_eq (x, v->missing[1].f) + || approx_eq (x, v->missing[2].f)); + case MISSING_RANGE: + return (approx_ge (x, v->missing[0].f) + && approx_le (x, v->missing[1].f)); + case MISSING_LOW: + return approx_le (x, v->missing[0].f); + case MISSING_HIGH: + return approx_ge (x, v->missing[0].f); + case MISSING_RANGE_1: + return ((approx_ge (x, v->missing[0].f) + && approx_le (x, v->missing[1].f)) + || approx_eq (x, v->missing[2].f)); + case MISSING_LOW_1: + return (approx_le (x, v->missing[0].f) + || approx_eq (x, v->missing[1].f)); + case MISSING_HIGH_1: + return (approx_ge (x, v->missing[0].f) + || approx_eq (x, v->missing[1].f)); + default: + assert (0); + } + abort (); +} + +/* Return nonzero only if string S is a user-missing variable for + string variable V. */ +inline int +is_str_user_missing (const unsigned char s[], const struct variable *v) +{ + switch (v->miss_type) + { + case MISSING_NONE: + return 0; + case MISSING_1: + return !strncmp (s, v->missing[0].s, v->width); + case MISSING_2: + return (!strncmp (s, v->missing[0].s, v->width) + || !strncmp (s, v->missing[1].s, v->width)); + case MISSING_3: + return (!strncmp (s, v->missing[0].s, v->width) + || !strncmp (s, v->missing[1].s, v->width) + || !strncmp (s, v->missing[2].s, v->width)); + default: + assert (0); + } + abort (); +} + +/* Return nonzero only if value VAL is system-missing for variable + V. */ +int +is_system_missing (const union value *val, const struct variable *v) +{ + return v->type == NUMERIC && val->f == SYSMIS; +} + +/* Return nonzero only if value VAL is system- or user-missing for + variable V. */ +int +is_missing (const union value *val, const struct variable *v) +{ + switch (v->type) + { + case NUMERIC: + if (val->f == SYSMIS) + return 1; + return is_num_user_missing (val->f, v); + case ALPHA: + return is_str_user_missing (val->s, v); + default: + assert (0); + } + abort (); +} + +/* Return nonzero only if value VAL is user-missing for variable V. */ +int +is_user_missing (const union value *val, const struct variable *v) +{ + switch (v->type) + { + case NUMERIC: + return is_num_user_missing (val->f, v); + case ALPHA: + return is_str_user_missing (val->s, v); + default: + assert (0); + } + abort (); +} diff --git a/src/vars-prs.c b/src/vars-prs.c new file mode 100644 index 00000000..f12ebf4c --- /dev/null +++ b/src/vars-prs.c @@ -0,0 +1,529 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include "alloc.h" +#include "avl.h" +#include "bitvector.h" +#include "error.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" + +/* Allocates an array at *V to contain all the variables in + default_dict. If FV_NO_SYSTEM is set in FLAGS then system + variables will not be included. If FV_NO_SCRATCH is set in FLAGS + then scratch variables will not be included. *C is set to the + number of variables in *V. */ +void +fill_all_vars (struct variable ***varlist, int *c, int flags) +{ + int i; + + *varlist = xmalloc (default_dict.nvar * sizeof **varlist); + if (flags == FV_NONE) + { + *c = default_dict.nvar; + for (i = 0; i < default_dict.nvar; i++) + (*varlist)[i] = default_dict.var[i]; + } + else + { + *c = 0; + + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + + if ((flags & FV_NO_SYSTEM) && v->name[0] == '$') + continue; + if ((flags & FV_NO_SCRATCH) && v->name[0] == '#') + continue; + + (*varlist)[*c] = v; + (*c)++; + } + + if (*c != default_dict.nvar) + *varlist = xrealloc (*varlist, *c * sizeof **varlist); + } +} + +int +is_varname (const char *s) +{ + return avl_find (default_dict.var_by_name, (struct variable *) s) != 0; +} + +int +is_dict_varname (const struct dictionary *dict, const char *s) +{ + return avl_find (dict->var_by_name, (struct variable *) s) != 0; +} + +struct variable * +parse_variable (void) +{ + struct variable *vp; + + if (token != T_ID) + { + lex_error ("expecting variable name"); + return NULL; + } + vp = find_variable (tokid); + if (!vp) + msg (SE, _("%s is not declared as a variable."), tokid); + lex_get (); + return vp; +} + +struct variable * +parse_dict_variable (struct dictionary * dict) +{ + struct variable *vp; + + if (token != T_ID) + { + lex_error ("expecting variable name"); + return NULL; + } + + vp = avl_find (dict->var_by_name, (struct variable *) tokid); + if (!vp) + msg (SE, _("%s is not a variable name."), tokid); + lex_get (); + + return vp; +} + +/* Returns the dictionary class of an identifier based on its + first letter: `X' if is an ordinary identifier, `$' if it + designates a system variable, `#' if it designates a scratch + variable. */ +#define id_dict(C) \ + ((C) == '$' ? '$' : ((C) == '#' ? '#' : 'X')) + +/* FIXME: One interesting variation in the case of PV_APPEND would be + to keep the bitmap, reducing time required to an actual O(n log n) + instead of having to reproduce the bitmap *every* *single* *time*. + Later though. (Another idea would be to keep a marker bit in each + variable.) */ +/* Note that if parse_variables() returns 0, *v is free()'d. + Conversely, if parse_variables() returns non-zero, then *nv is + nonzero and *v is non-NULL. */ +int +parse_variables (struct dictionary * dict, struct variable *** v, int *nv, int pv_opts) +{ + int i; + int nbytes; + unsigned char *bits; + + struct variable *v1, *v2; + int count, mv; + int scratch; /* Dictionary we're reading from. */ + int delayed_fail = 0; + + if (dict == NULL) + dict = &default_dict; + + if (!(pv_opts & PV_APPEND)) + { + *v = NULL; + *nv = 0; + mv = 0; + } + else + mv = *nv; + +#if GLOBAL_DEBUGGING + { + int corrupt = 0; + int i; + + for (i = 0; i < dict->nvar; i++) + if (dict->var[i]->index != i) + { + printf ("%s index corruption: variable %s\n", + dict == &default_dict ? "default_dict" : "aux dict", + dict->var[i]->name); + corrupt = 1; + } + + assert (!corrupt); + } +#endif + + nbytes = DIV_RND_UP (dict->nvar, 8); + if (!(pv_opts & PV_DUPLICATE)) + { + bits = local_alloc (nbytes); + memset (bits, 0, nbytes); + for (i = 0; i < *nv; i++) + SET_BIT (bits, (*v)[i]->index); + } + + do + { + if (lex_match (T_ALL)) + { + v1 = dict->var[0]; + v2 = dict->var[dict->nvar - 1]; + count = dict->nvar; + scratch = id_dict ('X'); + } + else + { + v1 = parse_dict_variable (dict); + if (!v1) + goto fail; + + if (lex_match (T_TO)) + { + v2 = parse_dict_variable (dict); + if (!v2) + { + lex_error ("expecting variable name"); + goto fail; + } + + count = v2->index - v1->index + 1; + if (count < 1) + { + msg (SE, _("%s TO %s is not valid syntax since %s " + "precedes %s in the dictionary."), + v1->name, v2->name, v2->name, v1->name); + goto fail; + } + + scratch = id_dict (v1->name[0]); + if (scratch != id_dict (v2->name[0])) + { + msg (SE, _("When using the TO keyword to specify several " + "variables, both variables must be from " + "the same variable dictionaries, of either " + "ordinary, scratch, or system variables. " + "%s and %s are from different dictionaries."), + v1->name, v2->name); + goto fail; + } + } + else + { + v2 = v1; + count = 1; + scratch = id_dict (v1->name[0]); + } + if (scratch == id_dict ('#') && (pv_opts & PV_NO_SCRATCH)) + { + msg (SE, _("Scratch variables (such as %s) are not allowed " + "here."), v1->name); + goto fail; + } + } + + if (*nv + count > mv) + { + mv += ROUND_UP (count, 16); + *v = xrealloc (*v, mv * sizeof **v); + } + + for (i = v1->index; i <= v2->index; i++) + { + struct variable *add = dict->var[i]; + + /* Skip over other dictionaries. */ + if (scratch != id_dict (add->name[0])) + continue; + + if ((pv_opts & PV_NUMERIC) && add->type != NUMERIC) + { + delayed_fail = 1; + msg (SW, _("%s is not a numeric variable. It will not be " + "included in the variable list."), add->name); + } + else if ((pv_opts & PV_STRING) && add->type != ALPHA) + { + delayed_fail = 1; + msg (SE, _("%s is not a string variable. It will not be " + "included in the variable list."), add->name); + } + else if ((pv_opts & PV_SAME_TYPE) && *nv && add->type != (*v)[0]->type) + { + delayed_fail = 1; + msg (SE, _("%s and %s are not the same type. All variables in " + "this variable list must be of the same type. %s " + "will be omitted from list."), + (*v)[0]->name, add->name, add->name); + } + else if ((pv_opts & PV_NO_DUPLICATE) && TEST_BIT (bits, add->index)) + { + delayed_fail = 1; + msg (SE, _("Variable %s appears twice in variable list."), + add->name); + } + else if ((pv_opts & PV_DUPLICATE) || !TEST_BIT (bits, add->index)) + { + (*v)[(*nv)++] = dict->var[i]; + if (!(pv_opts & PV_DUPLICATE)) + SET_BIT (bits, add->index); + } + } + + if (pv_opts & PV_SINGLE) + { + if (delayed_fail) + goto fail; + else + return 1; + } + lex_match (','); + } + while ((token == T_ID && is_dict_varname (dict, tokid)) || token == T_ALL); + + if (!(pv_opts & PV_DUPLICATE)) + local_free (bits); + if (!nv) + goto fail; + return 1; + +fail: + free (*v); + *v = NULL; + *nv = 0; + if (!(pv_opts & PV_DUPLICATE)) + local_free (bits); + return 0; +} + +static int +extract_num (char *s, char *r, int *n, int *d) +{ + char *cp; + + /* Find first digit. */ + cp = s + strlen (s) - 1; + while (isdigit ((unsigned char) *cp) && cp > s) + cp--; + cp++; + + /* Extract root. */ + strncpy (r, s, cp - s); + r[cp - s] = 0; + + /* Count initial zeros. */ + *n = *d = 0; + while (*cp == '0') + { + (*d)++; + cp++; + } + + /* Extract value. */ + while (isdigit ((unsigned char) *cp)) + { + (*d)++; + *n = (*n * 10) + (*cp - '0'); + cp++; + } + + /* Sanity check. */ + if (*n == 0 && *d == 0) + { + msg (SE, _("incorrect use of TO convention")); + return 0; + } + return 1; +} + +/* Parses a list of variable names according to the DATA LIST version + of the TO convention. */ +int +parse_DATA_LIST_vars (char ***names, int *nnames, int pv_opts) +{ + int n1, n2; + int d1, d2; + int n; + int nvar, mvar; + char *name1, *name2; + char *root1, *root2; + int success = 0; + + if (pv_opts & PV_APPEND) + nvar = mvar = *nnames; + else + { + nvar = mvar = 0; + *names = NULL; + } + + name1 = xmalloc (36); + name2 = &name1[1 * 9]; + root1 = &name1[2 * 9]; + root2 = &name1[3 * 9]; + do + { + if (token != T_ID) + { + lex_error ("expecting variable name"); + goto fail; + } + if (tokid[0] == '#' && (pv_opts & PV_NO_SCRATCH)) + { + msg (SE, _("Scratch variables not allowed here.")); + goto fail; + } + strcpy (name1, tokid); + lex_get (); + if (token == T_TO) + { + lex_get (); + if (token != T_ID) + { + lex_error ("expecting variable name"); + goto fail; + } + strcpy (name2, tokid); + lex_get (); + + if (!extract_num (name1, root1, &n1, &d1) + || !extract_num (name2, root2, &n2, &d2)) + goto fail; + + if (strcmp (root1, root2)) + { + msg (SE, _("Prefixes don't match in use of TO convention.")); + goto fail; + } + if (n1 > n2) + { + msg (SE, _("Bad bounds in use of TO convention.")); + goto fail; + } + if (d2 > d1) + d2 = d1; + + if (mvar < nvar + (n2 - n1 + 1)) + { + mvar += ROUND_UP (n2 - n1 + 1, 16); + *names = xrealloc (*names, mvar * sizeof **names); + } + + for (n = n1; n <= n2; n++) + { + (*names)[nvar] = xmalloc (9); + sprintf ((*names)[nvar], "%s%0*d", root1, d1, n); + nvar++; + } + } + else + { + if (nvar >= mvar) + { + mvar += 16; + *names = xrealloc (*names, mvar * sizeof **names); + } + (*names)[nvar++] = xstrdup (name1); + } + + lex_match (','); + + if (pv_opts & PV_SINGLE) + break; + } + while (token == T_ID); + success = 1; + +fail: + *nnames = nvar; + free (name1); + if (!success) + { + int i; + for (i = 0; i < nvar; i++) + free ((*names)[i]); + free (*names); + *names = NULL; + *nnames = 0; + } + return success; +} + +/* Parses a list of variables where some of the variables may be + existing and the rest are to be created. Same args as + parse_variables(). */ +int +parse_mixed_vars (char ***names, int *nnames, int pv_opts) +{ + int i; + + if (!(pv_opts & PV_APPEND)) + { + *names = NULL; + *nnames = 0; + } + while (token == T_ID || token == T_ALL) + { + if (token == T_ALL || is_varname (tokid)) + { + struct variable **v; + int nv; + + if (!parse_variables (NULL, &v, &nv, PV_NONE)) + goto fail; + *names = xrealloc (*names, (*nnames + nv) * sizeof **names); + for (i = 0; i < nv; i++) + (*names)[*nnames + i] = xstrdup (v[i]->name); + free (v); + *nnames += nv; + } + else if (!parse_DATA_LIST_vars (names, nnames, PV_APPEND)) + goto fail; + } + return 1; + +fail: + for (i = 0; i < *nnames; i++) + free ((*names)[*nnames]); + free (names); + *names = NULL; + *nnames = 0; + return 0; +} diff --git a/src/vector.c b/src/vector.c new file mode 100644 index 00000000..acaa0787 --- /dev/null +++ b/src/vector.c @@ -0,0 +1,230 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "alloc.h" +#include "cases.h" +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "misc.h" +#include "str.h" +#include "var.h" +#include "vector.h" + +/* Vectors created on VECTOR. */ +struct vector *vec; + +/* Number of vectors in vec. */ +int nvec; + +int +cmd_vector (void) +{ + /* Just to be different, points to a set of null terminated strings + containing the names of the vectors to be created. The list + itself is terminated by a empty string. So a list of three + elements, A B C, would look like this: "A\0B\0C\0\0". */ + char *vecnames; + + /* vecnames iterators. */ + char *cp, *cp2; + + /* Maximum allocated position for vecnames, plus one position. */ + char *endp = NULL; + + /* Variables on list (long form only). */ + struct variable **v = NULL; + int nv; + + lex_match_id ("VECTOR"); + + cp = vecnames = xmalloc (256); + endp = &vecnames[256]; + do + { + /* Get the name(s) of the new vector(s). */ + if (!lex_force_id ()) + return CMD_FAILURE; + while (token == T_ID) + { + if (cp + 16 > endp) + { + char *old_vecnames = vecnames; + vecnames = xrealloc (vecnames, endp - vecnames + 256); + cp = (cp - old_vecnames) + vecnames; + endp = (endp - old_vecnames) + vecnames + 256; + } + + for (cp2 = cp; cp2 < cp; cp2 += strlen (cp)) + if (!strcmp (cp2, tokid)) + { + msg (SE, _("Vector name %s is given twice."), tokid); + goto fail; + } + + if (find_vector (tokid)) + { + msg (SE, _("There is already a vector with name %s."), tokid); + goto fail; + } + + cp = stpcpy (cp, tokid) + 1; + lex_get (); + lex_match (','); + } + *cp++ = 0; + + /* Now that we have the names it's time to check for the short + or long forms. */ + if (lex_match ('=')) + { + /* Long form. */ + + if (strchr (vecnames, '\0')[1]) + { + /* There's more than one vector name. */ + msg (SE, _("A slash must be used to separate each vector " + "specification when using the long form. Commands " + "such as VECTOR A,B=Q1 TO Q20 are not supported.")); + goto fail; + } + + if (!parse_variables (NULL, &v, &nv, PV_SAME_TYPE | PV_DUPLICATE)) + goto fail; + + vec = xrealloc (vec, sizeof *vec * (nvec + 1)); + vec[nvec].index = nvec; + strcpy (vec[nvec].name, vecnames); + vec[nvec].v = v; + vec[nvec].nv = nv; + nvec++; + v = NULL; /* prevent block from being freed on error */ + } + else if (lex_match ('(')) + { + int i; + + /* Maximum number of digits in a number to add to the base + vecname. */ + int ndig; + + /* Name of an individual variable to be created. */ + char name[9]; + + if (!lex_force_int ()) + return CMD_FAILURE; + nv = lex_integer (); + lex_get (); + if (nv <= 0) + { + msg (SE, _("Vectors must have at least one element.")); + goto fail; + } + if (!lex_force_match (')')) + goto fail; + + /* First check that all the generated variable names are 8 + characters or shorter. */ + ndig = intlog10 (nv); + for (cp = vecnames; *cp;) + { + int len = strlen (cp); + if (len + ndig > 8) + { + msg (SE, _("%s%d is too long for a variable name."), cp, nv); + goto fail; + } + cp += len + 1; + } + + /* Next check that none of the variables exist. */ + for (cp = vecnames; *cp;) + { + for (i = 0; i < nv; i++) + { + sprintf (name, "%s%d", cp, i + 1); + if (is_varname (name)) + { + msg (SE, _("There is already a variable named %s."), name); + goto fail; + } + } + cp += strlen (cp) + 1; + } + + /* Finally create the variables and vectors. */ + vec = xrealloc (vec, sizeof *vec * (nvec + nv)); + for (cp = vecnames; *cp;) + { + vec[nvec].index = nvec; + strcpy (vec[nvec].name, cp); + vec[nvec].v = xmalloc (sizeof *vec[nvec].v * nv); + vec[nvec].nv = nv; + for (i = 0; i < nv; i++) + { + sprintf (name, "%s%d", cp, i + 1); + vec[nvec].v[i] = force_create_variable (&default_dict, name, + NUMERIC, 0); + envector (vec[nvec].v[i]); + } + nvec++; + cp += strlen (cp) + 1; + } + } + else + { + msg (SE, _("The syntax for this command does not match " + "the expected syntax for either the long form " + "or the short form of VECTOR.")); + goto fail; + } + + free (vecnames); + vecnames = NULL; + } + while (lex_match ('/')); + + if (token != '.') + { + lex_error (_("expecting end of command")); + goto fail; + } + return CMD_SUCCESS; + +fail: + free (vecnames); + free (v); + return CMD_PART_SUCCESS_MAYBE; +} + +/* Returns a pointer to the vector with name NAME, or NULL on + failure. */ +struct vector * +find_vector (const char *name) +{ + int i; + + for (i = 0; i < nvec; i++) + if (!strcmp (vec[i].name, name)) + return &vec[i]; + return NULL; +} diff --git a/src/vector.h b/src/vector.h new file mode 100644 index 00000000..c75f569f --- /dev/null +++ b/src/vector.h @@ -0,0 +1,37 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !vector_h +#define vector_h 1 + +/* Represents a vector as created by the VECTOR transformation. */ +struct vector + { + int index; /* Index into vec[]. */ + char name[9]; /* Name. */ + struct variable **v; /* Vector of variables. */ + int nv; /* Number of variables. */ + }; + +extern struct vector *vec; +extern int nvec; + +struct vector *find_vector (const char *name); + +#endif /* !vector_h */ diff --git a/src/version.h b/src/version.h new file mode 100644 index 00000000..c7912d75 --- /dev/null +++ b/src/version.h @@ -0,0 +1,51 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !version_h +#define version_h 1 + +/* "A.B.C" */ +extern const char bare_version[]; + +/* "GNU PSPP A.B.C" */ +extern const char version[]; + +/* "GNU PSPP version A.B (date), Copyright (C) XXXX Free Software + Foundation, Inc." */ +extern const char stat_version[]; + +/* Canonical name of host system type. */ +extern const char host_system[]; + +/* Canonical name of build system type. */ +extern const char build_system[]; + +/* Configuration path at build time. */ +extern const char default_config_path[]; + +/* Include path. */ +extern const char include_path[]; + +/* Font path. */ +extern const char groff_font_path[]; + +/* Locale directory. */ +extern const char locale_dir[]; + +#endif /* !version_h */ diff --git a/src/vfm.c b/src/vfm.c new file mode 100644 index 00000000..333851d6 --- /dev/null +++ b/src/vfm.c @@ -0,0 +1,1297 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* AIX requires this to be the first thing in the file. */ +#include +#if __GNUC__ +#define alloca __builtin_alloca +#else +#if HAVE_ALLOCA_H +#include +#else +#ifdef _AIX +#pragma alloca +#else +#ifndef alloca /* predefined by HP cc +Olibcalls */ +char *alloca (); +#endif +#endif +#endif +#endif + +#include +#include +#include +#include +#if HAVE_UNISTD_H +#include /* Required by SunOS4. */ +#endif +#include "alloc.h" +#include "approx.h" +#include "do-ifP.h" +#include "error.h" +#include "expr.h" +#include "misc.h" +#include "random.h" +#include "som.h" +#include "str.h" +#include "tab.h" +#include "var.h" +#include "vector.h" +#include "vfm.h" +#include "vfmP.h" + +/* + Virtual File Manager (vfm): + + vfm is used to process data files. It uses the model that data is + read from one stream (the data source), then written to another + (the data sink). The data source is then deleted and the data sink + becomes the data source for the next procedure. */ + +#undef DEBUGGING +/*#define DEBUGGING 1 */ +#include "debug-print.h" + +/* This is used to read from the active file. */ +struct case_stream *vfm_source; + +/* `value' indexes to initialize to particular values for certain cases. */ +struct long_vec reinit_sysmis; /* SYSMIS for every case. */ +struct long_vec reinit_blanks; /* Blanks for every case. */ +struct long_vec init_zero; /* Zero for first case only. */ +struct long_vec init_blanks; /* Blanks for first case only. */ + +/* This is used to write to the replacement active file. */ +struct case_stream *vfm_sink; + +/* Information about the data source. */ +struct stream_info vfm_source_info; + +/* Information about the data sink. */ +struct stream_info vfm_sink_info; + +/* Filter variable and `value' index. */ +static struct variable *filter_var; +static int filter_index; + +#define FILTERED \ + (filter_index != -1 \ + && (temp_case->data[filter_index].f == 0.0 \ + || temp_case->data[filter_index].f == SYSMIS \ + || is_num_user_missing (temp_case->data[filter_index].f, \ + filter_var))) + +/* Nonzero if the case needs to have values deleted before being + stored, zero otherwise. */ +int compaction_necessary; + +/* Number of values after compaction, or the same as + vfm_sink_info.nval, if compaction is not necessary. */ +int compaction_nval; + +/* Temporary case buffer with enough room for `compaction_nval' + `value's. */ +struct ccase *compaction_case; + +/* Within a session, when paging is turned on, it is never turned back + off. This policy might be too aggressive. */ +static int paging = 0; + +/* Time at which vfm was last invoked. */ +time_t last_vfm_invocation; + +/* Functions called during procedure processing. */ +static int (*proc_func) (struct ccase *); /* Called for each case. */ +static int (*virt_proc_func) (struct ccase *); /* From SPLIT_FILE_procfunc. */ +static void (*begin_func) (void); /* Called at beginning of a series. */ +static void (*virt_begin_func) (void); /* Called by SPLIT_FILE_procfunc. */ +static void (*end_func) (void); /* Called after end of a series. */ +int (*write_case) (void); + +/* Number of cases passed to proc_func(). */ +static int case_count; + +/* Lag queue. */ +int n_lag; /* Number of cases to lag. */ +static int lag_count; /* Number of cases in lag_queue so far. */ +static int lag_head; /* Index where next case will be added. */ +static struct ccase **lag_queue; /* Array of n_lag ccase * elements. */ + +static void open_active_file (void); +static void close_active_file (void); +static int SPLIT_FILE_procfunc (struct ccase *); +static void finish_compaction (void); +static void lag_case (void); +static int procedure_write_case (void); + +/* Public functions. */ + +/* Reads all the cases from the active file, transforms them by the + active set of transformations, calls PROCFUNC with CURCASE set to + the case and CASENUM set to the case number, and writes them to a + new active file. + + Divides the active file into zero or more series of one or more + cases each. BEGINFUNC is called before each series. ENDFUNC is + called after each series. */ +void +procedure (void (*beginfunc) (void), + int (*procfunc) (struct ccase *curcase), + void (*endfunc) (void)) +{ + end_func = endfunc; + write_case = procedure_write_case; + + if (default_dict.n_splits && procfunc != NULL) + { + virt_proc_func = procfunc; + proc_func = SPLIT_FILE_procfunc; + + virt_begin_func = beginfunc; + begin_func = NULL; + } else { + begin_func = beginfunc; + proc_func = procfunc; + } + + last_vfm_invocation = time (NULL); + + open_active_file (); + vfm_source->read (); + close_active_file (); +} + +/* Active file processing support. Subtly different semantics from + procedure(). */ + +static int process_active_file_write_case (void); + +/* The casefunc might want us to stop calling it. */ +static int not_canceled; + +/* Reads all the cases from the active file and passes them one-by-one + to CASEFUNC in temp_case. Before any cases are passed, calls + BEGINFUNC. After all the cases have been passed, calls ENDFUNC. + BEGINFUNC, CASEFUNC, and ENDFUNC can write temp_case to the output + file by calling process_active_file_output_case(). + + process_active_file() ignores TEMPORARY, SPLIT FILE, and N. */ +void +process_active_file (void (*beginfunc) (void), + int (*casefunc) (struct ccase *curcase), + void (*endfunc) (void)) +{ + proc_func = casefunc; + write_case = process_active_file_write_case; + not_canceled = 1; + + open_active_file (); + beginfunc (); + + /* There doesn't necessarily need to be an active file. */ + if (vfm_source) + vfm_source->read (); + + endfunc (); + close_active_file (); +} + +/* Pass the current case to casefunc. */ +static int +process_active_file_write_case (void) +{ + /* Index of current transformation. */ + int cur_trns; + + for (cur_trns = f_trns ; cur_trns != temp_trns; ) + { + int code; + + code = t_trns[cur_trns]->proc (t_trns[cur_trns], temp_case); + switch (code) + { + case -1: + /* Next transformation. */ + cur_trns++; + break; + case -2: + /* Delete this case. */ + goto done; + default: + /* Go to that transformation. */ + cur_trns = code; + break; + } + } + + if (n_lag) + lag_case (); + + /* Call the procedure if FILTER and PROCESS IF don't prohibit it. */ + if (not_canceled + && !FILTERED + && (process_if_expr == NULL || + expr_evaluate (process_if_expr, temp_case, NULL) == 1.0)) + not_canceled = proc_func (temp_case); + + case_count++; + + done: + { + long *lp; + + /* This case is finished. Initialize the variables for the next case. */ + for (lp = reinit_sysmis.vec; *lp != -1;) + temp_case->data[*lp++].f = SYSMIS; + for (lp = reinit_blanks.vec; *lp != -1;) + memset (temp_case->data[*lp++].s, ' ', MAX_SHORT_STRING); + } + + return 1; +} + +/* Write temp_case to the active file. */ +void +process_active_file_output_case (void) +{ + vfm_sink_info.ncases++; + vfm_sink->write (); +} + +/* Opening the active file. */ + +/* It might be usefully noted that the following several functions are + given in the order that they are called by open_active_file(). */ + +/* Prepare to write to the replacement active file. */ +static void +prepare_for_writing (void) +{ + /* FIXME: If ALL the conditions listed below hold true, then the + replacement active file is guaranteed to be identical to the + original active file: + + 1. TEMPORARY was the first transformation, OR, there were no + transformations at all. + + 2. Input is not coming from an input program. + + 3. Compaction is not necessary. + + So, in this case, we shouldn't have to replace the active + file--it's just a waste of time and space. */ + + vfm_sink_info.ncases = 0; + vfm_sink_info.nval = default_dict.nval; + vfm_sink_info.case_size = (sizeof (struct ccase) + + (default_dict.nval - 1) * sizeof (union value)); + + if (vfm_sink == NULL) + { + if (vfm_sink_info.case_size * vfm_source_info.ncases > MAX_WORKSPACE + && !paging) + { + msg (MW, _("Workspace overflow predicted. Max workspace is " + "currently set to %d KB (%d cases at %d bytes each). " + "Paging active file to disk."), + MAX_WORKSPACE / 1024, MAX_WORKSPACE / vfm_sink_info.case_size, + vfm_sink_info.case_size); + + paging = 1; + } + + vfm_sink = paging ? &vfm_disk_stream : &vfm_memory_stream; + } +} + +/* Arrange for compacting the output cases for storage. */ +static void +arrange_compaction (void) +{ + int count_values = 0; + + { + int i; + + /* Count up the number of `value's that will be output. */ + for (i = 0; i < temp_dict->nvar; i++) + if (temp_dict->var[i]->name[0] != '#') + { + assert (temp_dict->var[i]->nv > 0); + count_values += temp_dict->var[i]->nv; + } + assert (temporary == 2 || count_values <= temp_dict->nval); + } + + /* Compaction is only necessary if the number of `value's to output + differs from the number already present. */ + compaction_nval = count_values; + compaction_necessary = temporary == 2 || count_values != temp_dict->nval; + + if (vfm_sink->init) + vfm_sink->init (); +} + +/* Prepares the temporary case and compaction case. */ +static void +make_temp_case (void) +{ + temp_case = xmalloc (vfm_sink_info.case_size); + + if (compaction_necessary) + compaction_case = xmalloc (sizeof (struct ccase) + + sizeof (union value) * (compaction_nval - 1)); + +#if __CHECKER__ + /* Initialize the unused trailing parts of string variables to avoid + spurious warnings from Checker. */ + { + int i; + + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + + if (v->type == ALPHA && v->width % 8 != 0) + memcpy (&temp_case->data[v->fv + v->nv - 1] + .s[v->width % 8], _("!ERROR!"), 8 - v->width % 8); + } + } +#endif +} + +#if DEBUGGING +/* Returns the name of the variable that owns the index CCASE_INDEX + into ccase. */ +static const char * +index_to_varname (int ccase_index) +{ + int i; + + for (i = 0; i < default_dict.nvar; i++) + { + variable *v = default_dict.var[i]; + + if (ccase_index >= v->fv && ccase_index < v->fv + v->nv) + return default_dict.var[i]->name; + } + return _(""); +} +#endif + +/* Initializes temp_case from the vectors that say which `value's need + to be initialized just once, and which ones need to be + re-initialized before every case. */ +static void +vector_initialization (void) +{ + int i; + long *lp; + + /* Just once. */ + for (i = 0; i < init_zero.n; i++) + temp_case->data[init_zero.vec[i]].f = 0.0; + for (i = 0; i < init_blanks.n; i++) + memset (temp_case->data[init_blanks.vec[i]].s, ' ', MAX_SHORT_STRING); + + /* These vectors need to be repeatedly accessed, so we add a + sentinel to (hopefully) improve speed. */ + vec_insert (&reinit_sysmis, -1); + vec_insert (&reinit_blanks, -1); + + for (lp = reinit_sysmis.vec; *lp != -1;) + temp_case->data[*lp++].f = SYSMIS; + for (lp = reinit_blanks.vec; *lp != -1;) + memset (temp_case->data[*lp++].s, ' ', MAX_SHORT_STRING); + +#if DEBUGGING + printf ("vfm: init_zero="); + for (i = 0; i < init_zero.n; i++) + printf ("%s%s", i ? "," : "", index_to_varname (init_zero.vec[i])); + printf (" init_blanks="); + for (i = 0; i < init_blanks.n; i++) + printf ("%s%s", i ? "," : "", index_to_varname (init_blanks.vec[i])); + printf (" reinit_sysmis="); + for (lp = reinit_sysmis.vec; *lp != -1; lp++) + printf ("%s%s", lp != reinit_sysmis.vec ? "," : "", + index_to_varname (*lp)); + printf (" reinit_blanks="); + for (lp = reinit_blanks.vec; *lp != -1; lp++) + printf ("%s%s", lp != reinit_blanks.vec ? "," : "", + index_to_varname (*lp)); + printf ("\n"); +#endif +} + +/* Sets filter_index to an appropriate value. */ +static void +setup_filter (void) +{ + filter_index = -1; + + if (default_dict.filter_var[0]) + { + struct variable *fv = find_variable (default_dict.filter_var); + + if (fv == NULL || fv->type == ALPHA) + default_dict.filter_var[0] = 0; + else + { + filter_index = fv->index; + filter_var = fv; + } + } +} + +/* Sets all the lag-related variables based on value of n_lag. */ +static void +setup_lag (void) +{ + int i; + + if (n_lag == 0) + return; + + lag_count = 0; + lag_head = 0; + lag_queue = xmalloc (n_lag * sizeof *lag_queue); + for (i = 0; i < n_lag; i++) + lag_queue[i] = xmalloc (temp_dict->nval * sizeof **lag_queue); +} + +/* There is a lot of potential confusion in the vfm and related + routines over the number of `value's at each stage of the process. + Here is each nval count, with explanation, as set up by + open_active_file(): + + vfm_source_info.nval: Number of `value's in the cases returned by + the source stream. This value turns out not to be very useful, but + we maintain it anyway. + + vfm_sink_info.nval: Number of `value's in the cases after all + transformations have been performed. Never less than + vfm_source_info.nval. + + temp_dict->nval: Number of `value's in the cases after the + transformations leading up to TEMPORARY have been performed. If + TEMPORARY was not specified, this is equal to vfm_sink_info.nval. + Never less than vfm_sink_info.nval. + + compaction_nval: Number of `value's in the cases after the + transformations leading up to TEMPORARY have been performed and the + case has been compacted by compact_case(), if compaction is + necessary. This the number of `value's in the cases saved by the + sink stream. (However, note that the cases passed to the sink + stream have not yet been compacted. It is the responsibility of + the data sink to call compact_case().) This may be less than, + greater than, or equal to vfm_source_info.nval. `compaction' + becomes the new value of default_dict.nval after the procedure is + completed. + + default_dict.nval: This is often an alias for temp_dict->nval. As + such it can really have no separate existence until the procedure + is complete. For this reason it should *not* be referenced inside + the execution of a procedure. */ +/* Makes all preparations for reading from the data source and writing + to the data sink. */ +static void +open_active_file (void) +{ + /* Sometimes we want to refer to the dictionary that applies to the + data actually written to the sink. This is either temp_dict or + default_dict. However, if TEMPORARY is not on, then temp_dict + does not apply. So, we can set temp_dict to default_dict in this + case. */ + if (!temporary) + { + temp_trns = n_trns; + temp_dict = &default_dict; + } + + /* No cases passed to the procedure yet. */ + case_count = 0; + + /* The rest. */ + prepare_for_writing (); + arrange_compaction (); + make_temp_case (); + vector_initialization (); + setup_randomize (); + discard_ctl_stack (); + setup_filter (); + setup_lag (); + + /* Debug output. */ + debug_printf (("vfm: reading from %s source, writing to %s sink.\n", + vfm_source->name, vfm_sink->name)); + debug_printf (("vfm: vfm_source_info.nval=%d, vfm_sink_info.nval=%d, " + "temp_dict->nval=%d, compaction_nval=%d, " + "default_dict.nval=%d\n", + vfm_source_info.nval, vfm_sink_info.nval, temp_dict->nval, + compaction_nval, default_dict.nval)); +} + +/* Closes the active file. */ +static void +close_active_file (void) +{ + /* Close the current case group. */ + if (case_count && end_func != NULL) + end_func (); + + /* Stop lagging (catch up?). */ + if (n_lag) + { + int i; + + for (i = 0; i < n_lag; i++) + free (lag_queue[i]); + free (lag_queue); + n_lag = 0; + } + + /* Assume the dictionary from right before TEMPORARY, if any. Turn + off TEMPORARY. */ + if (temporary) + { + restore_dictionary (temp_dict); + temp_dict = NULL; + } + + /* The default dictionary assumes the compacted data size. */ + default_dict.nval = compaction_nval; + + /* Old data sink --> New data source. */ + if (vfm_source && vfm_source->destroy_source) + vfm_source->destroy_source (); + + vfm_source = vfm_sink; + vfm_source_info.ncases = vfm_sink_info.ncases; + vfm_source_info.nval = compaction_nval; + vfm_source_info.case_size = (sizeof (struct ccase) + + (compaction_nval - 1) * sizeof (union value)); + if (vfm_source->mode) + vfm_source->mode (); + + /* Old data sink is gone now. */ + vfm_sink = NULL; + + /* Finish compaction. */ + if (compaction_necessary) + finish_compaction (); + cancel_temporary (); + + /* Free temporary cases. */ + free (temp_case); + temp_case = NULL; + + free (compaction_case); + compaction_case = NULL; + + /* Cancel PROCESS IF. */ + expr_free (process_if_expr); + process_if_expr = NULL; + + /* Cancel FILTER if temporary. */ + if (filter_index != -1 && !FILTER_before_TEMPORARY) + default_dict.filter_var[0] = 0; + + /* Cancel transformations. */ + cancel_transformations (); + + /* Clear value-initialization vectors. */ + vec_clear (&init_zero); + vec_clear (&init_blanks); + vec_clear (&reinit_sysmis); + vec_clear (&reinit_blanks); + + /* Turn off case limiter. */ + default_dict.N = 0; + + /* Clear VECTOR vectors. */ + { + int i; + + for (i = 0; i < nvec; i++) + free (vec[i].v); + free (vec); + vec = NULL; + nvec = 0; + } + + debug_printf (("vfm: procedure complete\n\n")); +} + +/* Disk case stream. */ + +/* Associated files. */ +FILE *disk_source_file; +FILE *disk_sink_file; + +/* Initializes the disk sink. */ +static void +disk_stream_init (void) +{ + disk_sink_file = tmpfile (); + if (!disk_sink_file) + { + msg (ME, _("An error occurred attempting to create a temporary " + "file for use as the active file: %s."), + strerror (errno)); + err_failure (); + } +} + +/* Reads all cases from the disk source and passes them one by one to + write_case(). */ +static void +disk_stream_read (void) +{ + int i; + + for (i = 0; i < vfm_source_info.ncases; i++) + { + if (!fread (temp_case, vfm_source_info.case_size, 1, disk_source_file)) + { + msg (ME, _("An error occurred while attempting to read from " + "a temporary file created for the active file: %s."), + strerror (errno)); + err_failure (); + return; + } + + if (!write_case ()) + return; + } +} + +/* Writes temp_case to the disk sink. */ +static void +disk_stream_write (void) +{ + union value *src_case; + + if (compaction_necessary) + { + compact_case (compaction_case, temp_case); + src_case = (union value *) compaction_case; + } + else src_case = (union value *) temp_case; + + if (fwrite (src_case, sizeof *src_case * compaction_nval, 1, + disk_sink_file) != 1) + { + msg (ME, _("An error occurred while attempting to write to a " + "temporary file used as the active file: %s."), + strerror (errno)); + err_failure (); + } +} + +/* Switches the stream from a sink to a source. */ +static void +disk_stream_mode (void) +{ + /* Rewind the sink. */ + if (fseek (disk_sink_file, 0, SEEK_SET) != 0) + { + msg (ME, _("An error occurred while attempting to rewind a " + "temporary file used as the active file: %s."), + strerror (errno)); + err_failure (); + } + + /* Sink --> source variables. */ + disk_source_file = disk_sink_file; +} + +/* Destroys the source's internal data. */ +static void +disk_stream_destroy_source (void) +{ + if (disk_source_file) + { + fclose (disk_source_file); + disk_source_file = NULL; + } +} + +/* Destroys the sink's internal data. */ +static void +disk_stream_destroy_sink (void) +{ + if (disk_sink_file) + { + fclose (disk_sink_file); + disk_sink_file = NULL; + } +} + +/* Disk stream. */ +struct case_stream vfm_disk_stream = + { + disk_stream_init, + disk_stream_read, + disk_stream_write, + disk_stream_mode, + disk_stream_destroy_source, + disk_stream_destroy_sink, + "disk", + }; + +/* Memory case stream. */ + +/* List of cases stored in the stream. */ +struct case_list *memory_source_cases; +struct case_list *memory_sink_cases; + +/* Current case. */ +struct case_list *memory_sink_iter; + +/* Maximum number of cases. */ +int memory_sink_max_cases; + +/* Initializes the memory stream variables for writing. */ +static void +memory_stream_init (void) +{ + memory_sink_cases = NULL; + memory_sink_iter = NULL; + + assert (compaction_nval); + memory_sink_max_cases = MAX_WORKSPACE / (sizeof (union value) * compaction_nval); +} + +/* Reads the case stream from memory and passes it to write_case(). */ +static void +memory_stream_read (void) +{ + while (memory_source_cases != NULL) + { + memcpy (temp_case, &memory_source_cases->c, vfm_source_info.case_size); + + { + struct case_list *current = memory_source_cases; + memory_source_cases = memory_source_cases->next; + free (current); + } + + if (!write_case ()) + return; + } +} + +/* Writes temp_case to the memory stream. */ +static void +memory_stream_write (void) +{ + struct case_list *new_case = malloc (sizeof (struct case_list) + + ((compaction_nval - 1) + * sizeof (union value))); + + /* If we've got memory to spare then add it to the linked list. */ + if (vfm_sink_info.ncases <= memory_sink_max_cases && new_case != NULL) + { + if (compaction_necessary) + compact_case (&new_case->c, temp_case); + else + memcpy (&new_case->c, temp_case, sizeof (union value) * compaction_nval); + + /* Append case to linked list. */ + if (memory_sink_cases) + memory_sink_iter = memory_sink_iter->next = new_case; + else + memory_sink_iter = memory_sink_cases = new_case; + } + else + { + /* Out of memory. Write the active file to disk. */ + struct case_list *cur, *next; + + /* Notify the user. */ + if (!new_case) + msg (MW, _("Virtual memory exhausted. Paging active file " + "to disk.")); + else + msg (MW, _("Workspace limit of %d KB (%d cases at %d bytes each) " + "overflowed. Paging active file to disk."), + MAX_WORKSPACE / 1024, memory_sink_max_cases, + compaction_nval * sizeof (union value)); + + free (new_case); + + /* Switch to a disk sink. */ + vfm_sink = &vfm_disk_stream; + vfm_sink->init (); + paging = 1; + + /* Terminate the list. */ + if (memory_sink_iter) + memory_sink_iter->next = NULL; + + /* Write the cases to disk and destroy them. We can't call + vfm->sink->write() because of compaction. */ + for (cur = memory_sink_cases; cur; cur = next) + { + next = cur->next; + if (fwrite (cur->c.data, sizeof (union value) * compaction_nval, 1, + disk_sink_file) != 1) + { + msg (ME, _("An error occurred while attempting to " + "write to a temporary file created as the " + "active file, while paging to disk: %s."), + strerror (errno)); + err_failure (); + } + free (cur); + } + + /* Write the current case to disk. */ + vfm_sink->write (); + } +} + +/* If the data is stored in memory, causes it to be written to disk. + To be called only *between* procedure()s, not within them. */ +void +page_to_disk (void) +{ + if (vfm_source == &vfm_memory_stream) + { + /* Switch to a disk sink. */ + vfm_sink = &vfm_disk_stream; + vfm_sink->init (); + paging = 1; + + /* Write the cases to disk and destroy them. We can't call + vfm->sink->write() because of compaction. */ + { + struct case_list *cur, *next; + + for (cur = memory_source_cases; cur; cur = next) + { + next = cur->next; + if (fwrite (cur->c.data, sizeof *cur->c.data * compaction_nval, 1, + disk_sink_file) != 1) + { + msg (ME, _("An error occurred while attempting to " + "write to a temporary file created as the " + "active file, while paging to disk: %s."), + strerror (errno)); + err_failure (); + } + free (cur); + } + } + + vfm_source = &vfm_disk_stream; + vfm_source->mode (); + + vfm_sink = NULL; + } +} + +/* Switch the memory stream from sink to source mode. */ +static void +memory_stream_mode (void) +{ + /* Terminate the list. */ + if (memory_sink_iter) + memory_sink_iter->next = NULL; + + /* Sink --> source variables. */ + memory_source_cases = memory_sink_cases; + memory_sink_cases = NULL; +} + +/* Destroy all memory source data. */ +static void +memory_stream_destroy_source (void) +{ + struct case_list *cur, *next; + + for (cur = memory_source_cases; cur; cur = next) + { + next = cur->next; + free (cur); + } + memory_source_cases = NULL; +} + +/* Destroy all memory sink data. */ +static void +memory_stream_destroy_sink (void) +{ + struct case_list *cur, *next; + + for (cur = memory_sink_cases; cur; cur = next) + { + next = cur->next; + free (cur); + } + memory_sink_cases = NULL; +} + +/* Memory stream. */ +struct case_stream vfm_memory_stream = + { + memory_stream_init, + memory_stream_read, + memory_stream_write, + memory_stream_mode, + memory_stream_destroy_source, + memory_stream_destroy_sink, + "memory", + }; + +#undef DEBUGGING +#include "debug-print.h" + +/* Add temp_case to the lag queue. */ +static void +lag_case (void) +{ + if (lag_count < n_lag) + lag_count++; + memcpy (lag_queue[lag_head], temp_case, sizeof (union value) * temp_dict->nval); + if (++lag_head >= n_lag) + lag_head = 0; +} + +/* Returns a pointer to the lagged case from N_BEFORE cases before the + current one, or NULL if there haven't been that many cases yet. */ +struct ccase * +lagged_case (int n_before) +{ + assert (n_before <= n_lag); + if (n_before > lag_count) + return NULL; + + { + int index = lag_head - n_before; + if (index < 0) + index += n_lag; + return lag_queue[index]; + } +} + +/* Transforms temp_case and writes it to the replacement active file + if advisable. Returns nonzero if more cases can be accepted, zero + otherwise. Do not call this function again after it has returned + zero once. */ +int +procedure_write_case (void) +{ + /* Index of current transformation. */ + int cur_trns; + + /* Return value: whether it's reasonable to write any more cases. */ + int more_cases = 1; + + debug_printf ((_("transform: "))); + + cur_trns = f_trns; + for (;;) + { + /* Output the case if this is temp_trns. */ + if (cur_trns == temp_trns) + { + debug_printf (("REC")); + + if (n_lag) + lag_case (); + + vfm_sink_info.ncases++; + vfm_sink->write (); + + if (default_dict.N) + more_cases = vfm_sink_info.ncases < default_dict.N; + } + + /* Are we done? */ + if (cur_trns >= n_trns) + break; + + debug_printf (("$%d", cur_trns)); + + /* Decide which transformation should come next. */ + { + int code; + + code = t_trns[cur_trns]->proc (t_trns[cur_trns], temp_case); + switch (code) + { + case -1: + /* Next transformation. */ + cur_trns++; + break; + case -2: + /* Delete this case. */ + goto done; + default: + /* Go to that transformation. */ + cur_trns = code; + break; + } + } + } + + /* Call the beginning of group function. */ + if (!case_count && begin_func != NULL) + begin_func (); + + /* Call the procedure if there is one and FILTER and PROCESS IF + don't prohibit it. */ + if (proc_func != NULL + && !FILTERED + && (process_if_expr == NULL || + expr_evaluate (process_if_expr, temp_case, NULL) == 1.0)) + proc_func (temp_case); + + case_count++; + +done: + debug_putc ('\n', stdout); + + { + long *lp; + + /* This case is finished. Initialize the variables for the next case. */ + for (lp = reinit_sysmis.vec; *lp != -1;) + temp_case->data[*lp++].f = SYSMIS; + for (lp = reinit_blanks.vec; *lp != -1;) + memset (temp_case->data[*lp++].s, ' ', MAX_SHORT_STRING); + } + + /* Return previously determined value. */ + return more_cases; +} + +/* Appends TRNS to t_trns[], the list of all transformations to be + performed on data as it is read from the active file. */ +void +add_transformation (struct trns_header * trns) +{ + if (n_trns >= m_trns) + { + m_trns += 16; + t_trns = xrealloc (t_trns, sizeof *t_trns * m_trns); + } + t_trns[n_trns] = trns; + trns->index = n_trns++; +} + +/* Cancels all active transformations, including any transformations + created by the input program. */ +void +cancel_transformations (void) +{ + int i; + for (i = 0; i < n_trns; i++) + { + if (t_trns[i]->free) + t_trns[i]->free (t_trns[i]); + free (t_trns[i]); + } + n_trns = f_trns = 0; + if (m_trns > 32) + { + free (t_trns); + m_trns = 0; + } +} + +/* Dumps out the values of all the split variables for the case C. */ +static void +dump_splits (struct ccase *c) +{ + struct variable **iter; + struct tab_table *t; + int i; + + t = tab_create (3, default_dict.n_splits + 1, 0); + tab_dim (t, tab_natural_dimensions); + tab_vline (t, TAL_1 | TAL_SPACING, 1, 0, default_dict.n_splits); + tab_vline (t, TAL_1 | TAL_SPACING, 2, 0, default_dict.n_splits); + tab_text (t, 0, 0, TAB_NONE, _("Variable")); + tab_text (t, 1, 0, TAB_LEFT, _("Value")); + tab_text (t, 2, 0, TAB_LEFT, _("Label")); + for (iter = default_dict.splits, i = 0; *iter; iter++, i++) + { + struct variable *v = *iter; + char temp_buf[80]; + char *val_lab; + + assert (v->type == NUMERIC || v->type == ALPHA); + tab_text (t, 0, i + 1, TAB_LEFT | TAT_PRINTF, "%s", v->name); + + { + union value val = c->data[v->fv]; + if (v->type == ALPHA) + val.c = c->data[v->fv].s; + data_out (temp_buf, &v->print, &val); + } + + temp_buf[v->print.w] = 0; + tab_text (t, 1, i + 1, TAT_PRINTF, "%.*s", v->print.w, temp_buf); + + val_lab = get_val_lab (v, c->data[v->fv], 0); + if (val_lab) + tab_text (t, 2, i + 1, TAB_LEFT, val_lab); + } + tab_flags (t, SOMF_NO_TITLE); + tab_submit (t); +} + +/* This procfunc is substituted for the user-supplied procfunc when + SPLIT FILE is active. This function forms a wrapper around that + procfunc by dividing the input into series. */ +static int +SPLIT_FILE_procfunc (struct ccase *c) +{ + static struct ccase *prev_case; + struct variable **iter; + + /* The first case always begins a new series. We also need to + preserve the values of the case for later comparison. */ + if (case_count == 0) + { + if (prev_case) + free (prev_case); + prev_case = xmalloc (vfm_sink_info.case_size); + memcpy (prev_case, c, vfm_sink_info.case_size); + + dump_splits (c); + if (virt_begin_func != NULL) + virt_begin_func (); + + return virt_proc_func (c); + } + + /* Compare the value of each SPLIT FILE variable to the values on + the previous case. */ + for (iter = default_dict.splits; *iter; iter++) + { + struct variable *v = *iter; + + switch (v->type) + { + case NUMERIC: + if (approx_ne (c->data[v->fv].f, prev_case->data[v->fv].f)) + goto not_equal; + break; + case ALPHA: + if (memcmp (c->data[v->fv].s, prev_case->data[v->fv].s, v->width)) + goto not_equal; + break; + default: + assert (0); + } + } + return virt_proc_func (c); + +not_equal: + /* The values of the SPLIT FILE variable are different from the + values on the previous case. That means that it's time to begin + a new series. */ + if (end_func != NULL) + end_func (); + dump_splits (c); + if (virt_begin_func != NULL) + virt_begin_func (); + memcpy (prev_case, c, vfm_sink_info.case_size); + return virt_proc_func (c); +} + +/* Case compaction. */ + +/* Copies case SRC to case DEST, compacting it in the process. */ +void +compact_case (struct ccase *dest, const struct ccase *src) +{ + int i; + int nval = 0; + + assert (compaction_necessary); + + if (temporary == 2) + { + if (dest != compaction_case) + memcpy (dest, compaction_case, sizeof (union value) * compaction_nval); + return; + } + + /* Copy all the variables except the scratch variables from SRC to + DEST. */ + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + + if (v->name[0] == '#') + continue; + + if (v->type == NUMERIC) + dest->data[nval++] = src->data[v->fv]; + else + { + int w = DIV_RND_UP (v->width, sizeof (union value)); + + memcpy (&dest->data[nval], &src->data[v->fv], w * sizeof (union value)); + nval += w; + } + } +} + +/* Reassigns `fv' for each variable. Deletes scratch variables. */ +static void +finish_compaction (void) +{ + int copy_index = 0; + int nval = 0; + int i; + + for (i = 0; i < default_dict.nvar; i++) + { + struct variable *v = default_dict.var[i]; + + if (v->name[0] == '#') + { + clear_variable (&default_dict, v); + free (v); + continue; + } + + v->fv = nval; + if (v->type == NUMERIC) + nval++; + else + nval += DIV_RND_UP (v->width, sizeof (union value)); + + default_dict.var[copy_index++] = v; + } + if (copy_index != default_dict.nvar) + { + default_dict.var = xrealloc (default_dict.var, + sizeof *default_dict.var * copy_index); + default_dict.nvar = copy_index; + } +} + + diff --git a/src/vfm.h b/src/vfm.h new file mode 100644 index 00000000..b2a1e6ef --- /dev/null +++ b/src/vfm.h @@ -0,0 +1,100 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !vfm_h +#define vfm_h 1 + +#include "cases.h" +#include + +/* This is the time at which vfm was last invoked. */ +extern time_t last_vfm_invocation; + +/* This is the case that is to be filled in by input programs. */ +extern struct ccase *temp_case; + +/* `value' indexes to initialize to particular values for certain cases. */ +extern struct long_vec reinit_sysmis; /* SYSMIS for every case. */ +extern struct long_vec reinit_blanks; /* Blanks for every case. */ +extern struct long_vec init_zero; /* Zero for first case only. */ +extern struct long_vec init_blanks; /* Blanks for first case only. */ + +/* A case stream: either a source or a sink, depending on context. */ +struct case_stream + { + /* Initializes sink. */ + void (*init) (void); + + /* Reads all the cases and passes them to WRITE_CASE. */ + void (*read) (void); + + /* Writes a single case, temp_case. */ + void (*write) (void); + + /* Switches mode from sink to source. */ + void (*mode) (void); + + /* Discards source's internal data. */ + void (*destroy_source) (void); + + /* Discards sink's internal data. */ + void (*destroy_sink) (void); + + /* Identifying name for the stream. */ + const char *name; + }; + +/* This is used to read from the active file. */ +extern struct case_stream *vfm_source; + +/* This is used to write to the replacement active file. */ +extern struct case_stream *vfm_sink; + +/* General data streams. */ +extern struct case_stream vfm_memory_stream; +extern struct case_stream vfm_disk_stream; +extern struct case_stream sort_stream; +extern struct case_stream flip_stream; + +/* Streams that are only sources. */ +extern struct case_stream data_list_source; +extern struct case_stream input_program_source; +extern struct case_stream file_type_source; +extern struct case_stream get_source; +extern struct case_stream import_source; +extern struct case_stream matrix_data_source; + +/* Number of cases to lag. */ +extern int n_lag; + +extern int (*write_case) (void); + +void procedure (void (*beginfunc) (void), + int (*procfunc) (struct ccase *curcase), + void (*endfunc) (void)); +struct ccase *lagged_case (int n_before); +void compact_case (struct ccase *dest, const struct ccase *src); +void page_to_disk (void); + +void process_active_file (void (*beginfunc) (void), + int (*casefunc) (struct ccase *curcase), + void (*endfunc) (void)); +void process_active_file_output_case (void); + +#endif /* !vfm_h */ diff --git a/src/vfmP.h b/src/vfmP.h new file mode 100644 index 00000000..6454da89 --- /dev/null +++ b/src/vfmP.h @@ -0,0 +1,72 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#if !vfmP_h +#define vfmP_h 1 + +#include "var.h" + +/* Linked list of cases. */ +struct case_list + { + struct case_list *next; + struct ccase c; + }; + +/* Describes a data stream, either a source or a sink. */ +struct stream_info + { + int case_size; /* Size of one case in bytes. */ + int ncases; /* Number of cases. */ + int nval; /* Number of `value' elements per case. */ + }; + +/* Information about the data source. */ +extern struct stream_info vfm_source_info; + +/* Information about the data sink. */ +extern struct stream_info vfm_sink_info; + +/* Memory case stream. */ + +/* List of cases stored in the stream. */ +extern struct case_list *memory_source_cases; +extern struct case_list *memory_sink_cases; + +/* Current case. */ +extern struct case_list *memory_sink_iter; + +/* Maximum number of cases. */ +extern int memory_sink_max_cases; + +/* Nonzero if the case needs to have values deleted before being + stored, zero otherwise. */ +extern int compaction_necessary; + +/* Number of values after compaction, or the same as + vfm_sink_info.nval, if compaction is not necessary. */ +extern int compaction_nval; + +/* Temporary case buffer with enough room for `compaction_nval' + `value's. */ +extern struct ccase *compaction_case; + +void compact_case (struct ccase *dest, const struct ccase *src); + +#endif /* !vfmP_h */ diff --git a/src/weight.c b/src/weight.c new file mode 100644 index 00000000..1d7fe9eb --- /dev/null +++ b/src/weight.c @@ -0,0 +1,121 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997-9, 2000 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include "command.h" +#include "error.h" +#include "lexer.h" +#include "str.h" +#include "var.h" + +/* Notes: + + If the weighting variable is deleted somehow (for instance by + end-of-scope of TEMPORARY), weighting must be canceled. + + Scratch vars may not be used for weighting. */ + +/* WEIGHT transformation. */ +struct weight_trns + { + struct trns_header h; + int src; /* `value' index of weighting variable. */ + int dest; /* `value' index of $WEIGHT. */ + }; + +int +cmd_weight (void) +{ + lex_match_id ("WEIGHT"); + + if (lex_match_id ("OFF")) + default_dict.weight_var[0] = 0; + else + { + struct variable *v; + + lex_match (T_BY); + v = parse_variable (); + if (!v) + return CMD_FAILURE; + if (v->type == ALPHA) + { + msg (SE, _("The weighting variable must be numeric.")); + return CMD_FAILURE; + } + if (v->name[0] == '#') + { + msg (SE, _("The weighting variable may not be scratch.")); + return CMD_FAILURE; + } + + strcpy (default_dict.weight_var, v->name); + } + + return lex_end_of_command (); +} + +#if 0 /* FIXME: dead code. */ +static int +weight_trns_proc (any_trns * pt, ccase * c) +{ + weight_trns *t = (weight_trns *) pt; + + c->data[t->dest].f = c->data[t->src].f; + return -1; +} +#endif + +/* Global functions. */ + +/* Sets the weight_index member of dictionary D to an appropriate + value for the value of weight_var, and returns the weighting + variable if any or NULL if none. */ +struct variable * +update_weighting (struct dictionary * d) +{ + if (d->weight_var[0]) + { + struct variable *v = find_dict_variable (d, d->weight_var); + if (v && v->type == NUMERIC) + { + d->weight_index = v->fv; + return v; + } + else + { +#if GLOBAL_DEBUGGING + printf (_("bad weighting variable, canceling\n")); +#endif + d->weight_var[0] = 0; + } + } + + d->weight_index = -1; + return NULL; +} + +/* Turns off case weighting for dictionary D. */ +void +stop_weighting (struct dictionary * d) +{ + d->weight_var[0] = 0; +} diff --git a/stamp-h.in b/stamp-h.in new file mode 100644 index 00000000..9788f702 --- /dev/null +++ b/stamp-h.in @@ -0,0 +1 @@ +timestamp diff --git a/sysdeps/ChangeLog b/sysdeps/ChangeLog new file mode 100644 index 00000000..74e6766d --- /dev/null +++ b/sysdeps/ChangeLog @@ -0,0 +1,9 @@ +Sun Aug 9 11:17:39 1998 Ben Pfaff + + * README: New file. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/sysdeps/README b/sysdeps/README new file mode 100644 index 00000000..5a4ede64 --- /dev/null +++ b/sysdeps/README @@ -0,0 +1,8 @@ +-*- text -*- + +The files in this directory were at one time useful for compiling PSPP +under Borland C++ 5.0 for Windows. They may or may not be useful any +longer. They are provided without any assurance that they are up to +date. Use at your own risk. + +-blp diff --git a/sysdeps/borlandc5.0/ChangeLog b/sysdeps/borlandc5.0/ChangeLog new file mode 100644 index 00000000..0beaf5b3 --- /dev/null +++ b/sysdeps/borlandc5.0/ChangeLog @@ -0,0 +1,60 @@ +Sun Aug 9 11:15:17 1998 Ben Pfaff + + * pspp.iwz.in: Update name of sm-gnu-head.bmp. + + * sm-gnu-head.bmp: Renamed sm-gnu-hd.bmp. + +Fri Dec 5 23:01:44 1997 Ben Pfaff + + * fiasco.ico: Renamed pspp.ico. + + * fiasco.ide: Renamed pspp.ide. + + * fiasco.iwz.in: Renamed pspp.iwz.in. + +Wed Aug 20 12:52:43 1997 Ben Pfaff + + * fiasco.iwz.in: Updated. + +Sat Aug 16 11:02:38 1997 Ben Pfaff + + * mk-bc5-dist: No longer run from toplevel Makefile. + + * unix2dos.pl: Moved here from the top level. + + * pref.h: Removed. + +Thu Aug 14 22:19:46 1997 Ben Pfaff + + * fiasco.iwz.in: Revised. + + * pref.h: Updated from pref.h.orig. + + * fiasco.ide: Updated. + +Sun Aug 3 11:50:23 1997 Ben Pfaff + + * fiasco.ico: New file, icon for Fiasco. + + * fiasco.iwz.in: New file, InstallShield template for Fiasco. + + * setup1.bmp: New file, Bitmap displayed during installation. + + * sm-gnu-head.bmp: New file, small GNU head from + www.gnu.org converted to BMP format. + +Thu Jul 17 02:20:09 1997 Ben Pfaff + + * New directory for Windows support via Borland C++ 5.0. + + * bc5-con32s.c: Combines _read.c and _write from the old + sysdeps/borlandc4.0 directory. + + * config.h, libintl.h, pref.h, version.c: Standard files adapted + to Borland C++ 5.0. + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/sysdeps/borlandc5.0/bc5-con32s.c b/sysdeps/borlandc5.0/bc5-con32s.c new file mode 100644 index 00000000..ec55ab84 --- /dev/null +++ b/sysdeps/borlandc5.0/bc5-con32s.c @@ -0,0 +1,95 @@ +/* con32s - emulates console under Windows. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* This replaces a few of the Borland C++ library functions. It does + not use any of the runtime library header files, so you do not need + the runtime library source in order to compile it. */ + +#include +#include +#include + +/* 1=It is necessary to emulate the console window. */ +int _emu_console; + +/* Exported by con32s.c. */ +extern int _blp_console_read (void *buf, unsigned len); + +/* Exported by Borland runtime library. */ +extern long _handles[]; +extern int __IOerror (int); +extern int __NTerror (void); + +/* Replaces Borland library function. */ +int +_rtl_read (int fd, void *buf, unsigned len) +{ + DWORD nread; + + if ((unsigned) fd >= _nfile) + return __IOerror (ERROR_INVALID_HANDLE); + + /* Redirect stdin to the faked console window. */ + if (_emu_console && fd < 3) + return _blp_console_read (buf, len); + + if (ReadFile ((HANDLE) _handles[fd], buf, (DWORD) len, &nread, NULL) != 1) + return __NTerror (); + else + return (int) nread; +} + +/* Replaces Borland library function. */ +int +_rtl_write (int fd, const void *buf, unsigned int len) +{ + DWORD written; + + if ((unsigned) fd >= _nfile) + return __IOerror (ERROR_INVALID_HANDLE); + + /* Redirect stdout, stderr to the faked console window. */ + if (_emu_console && fd < 3) + return _blp_console_write (buf, len); + + if (WriteFile ((HANDLE) _handles[fd], (PVOID) buf, (DWORD) len, &written, + NULL) != 1) + return __NTerror (); + else + return (int) written; +} + +void +determine_os (void) +{ +#pragma startup determine_os 64 + DWORD nButtons; + + /* Try out a random console function. If it fails then we must not + have a console. + + Believe it or not, this seems to be the only way to determine + reliably whether we're running under 3.1. If you know a better + way, let me know. */ + if (GetNumberOfConsoleMouseButtons (&nButtons)) + _emu_console = 0; + else + _emu_console = 1; +} + diff --git a/sysdeps/borlandc5.0/config.h b/sysdeps/borlandc5.0/config.h new file mode 100644 index 00000000..a90e84ce --- /dev/null +++ b/sysdeps/borlandc5.0/config.h @@ -0,0 +1,303 @@ +/* config.h.in. Generated automatically from configure.in by autoheader. */ +/* Special definitions, to process by autoheader. + Copyright (C) 1997 Free Software Foundation. */ + +/* Definitions for byte order, according to significance of bytes, from low + addresses to high addresses. The value is what you get by putting '4' + in the most significant byte, '3' in the second most significant byte, + '2' in the second least significant byte, and '1' in the least + significant byte. These definitions never need to be modified. */ +#define BIG 4321 /* 68k */ +#define LITTLE 1234 /* i[3456]86 */ +#define UNKNOWN 0000 /* Endianness must be determined at runtime. */ + +/* Definitions for floating-point representation. */ +#define FPREP_IEEE754 754 /* The usual IEEE-754 format. */ +#define FPREP_UNKNOWN 666 /* Triggers an error at compile time. */ + +/* We want prototypes for all the GNU extensions. */ +#define _GNU_SOURCE 1 + +/* The concatenation of the strings "GNU ", and PACKAGE. */ +#define GNU_PACKAGE "GNU PSPP" + +/* Define to the name of the distribution. */ +#define PACKAGE "PSPP" + +/* Define to 1 if ANSI function prototypes are usable. */ +#define PROTOTYPES 1 + +/* Define to the version of the distribution. */ +#define VERSION "0.1.0" + +/* Define if using alloca.c. */ +#undef C_ALLOCA + +/* Define to empty if the keyword does not work. */ +#undef const + +/* Define to one of _getb67, GETB67, getb67 for Cray-2 and Cray-YMP systems. + This function is required for alloca.c support on those systems. */ +#define CRAY_STACKSEG_END + +/* Define if you have alloca, as a function or macro. */ +#undef HAVE_ALLOCA + +/* Define if you have and it should be used (not on Ultrix). */ +#undef HAVE_ALLOCA_H + +/* Define if you don't have vprintf but do have _doprnt. */ +#undef HAVE_DOPRNT + +/* Define if you have a working `mmap' system call. */ +#undef HAVE_MMAP + +/* Define if you have the vprintf function. */ +#define HAVE_VPRINTF 1 + +/* Define as __inline if that's what the C compiler calls it. */ +#define inline + +/* Define to `long' if doesn't define. */ +#undef off_t + +/* Define if you need to in order for stat and other things to work. */ +#undef _POSIX_SOURCE + +/* Define to `unsigned' if doesn't define. */ +#undef size_t + +/* If using the C implementation of alloca, define if you know the + direction of stack growth for your system; otherwise it will be + automatically deduced at run-time. + STACK_DIRECTION > 0 => grows toward higher addresses + STACK_DIRECTION < 0 => grows toward lower addresses + STACK_DIRECTION = 0 => direction of growth unknown + */ +#undef STACK_DIRECTION + +/* Define if the `S_IS*' macros in do not work properly. */ +#undef STAT_MACROS_BROKEN + +/* Define if you have the ANSI C header files. */ +#define STDC_HEADERS 1 + +/* Define if you can safely include both and . */ +#undef TIME_WITH_SYS_TIME + +/* Define if your declares struct tm. */ +#undef TM_IN_SYS_TIME + +/* Define if sprintf() returns the number of characters written to + the destination string, excluding the null terminator. */ +#define HAVE_GOOD_SPRINTF 1 + +/* Define endianness of computer here as BIG or LITTLE, if known. + If not known, define as UNKNOWN. */ +#define ENDIAN LITTLE + +/* Define as floating-point representation of this computer. For + i386, m68k, and other common chips, this is FPREP_IEEE754. */ +#define FPREP FPREP_IEEE754 + +/* Number of digits in longest `long' value, including sign. This is + usually 11, for 32-bit `long's, or 19, for 64-bit `long's. */ +#define INT_DIGITS 11 + +/* Define if you have the history library (-lhistory). */ +#undef HAVE_LIBHISTORY + +/* Define if you have the termcap library (-ltermcap). */ +#undef HAVE_LIBTERMCAP + +/* Define if your locale.h file contains LC_MESSAGES. */ +#define HAVE_LC_MESSAGES 1 + +/* Define to 1 if NLS is requested. */ +#undef ENABLE_NLS + +/* Define as 1 if you have catgets and don't want to use GNU gettext. */ +#undef HAVE_CATGETS + +/* Define as 1 if you have gettext and don't want to use GNU gettext. */ +#undef HAVE_GETTEXT + +/* Define as 1 if you have the stpcpy function. */ +#define HAVE_STPCPY 1 + +/* The number of bytes in a double. */ +#define SIZEOF_DOUBLE 8 + +/* The number of bytes in a float. */ +#define SIZEOF_FLOAT 4 + +/* The number of bytes in a int. */ +#define SIZEOF_INT 4 + +/* The number of bytes in a long. */ +#define SIZEOF_LONG 4 + +/* The number of bytes in a long double. */ +#define SIZEOF_LONG_DOUBLE 12 + +/* The number of bytes in a long long. */ +#define SIZEOF_LONG_LONG + +/* The number of bytes in a short. */ +#define SIZEOF_SHORT 2 + +/* Define if you have the __argz_count function. */ +#undef HAVE___ARGZ_COUNT + +/* Define if you have the __argz_next function. */ +#undef HAVE___ARGZ_NEXT + +/* Define if you have the __argz_stringify function. */ +#undef HAVE___ARGZ_STRINGIFY + +/* Define if you have the __setfpucw function. */ +#undef HAVE___SETFPUCW + +/* Define if you have the dcgettext function. */ +#undef HAVE_DCGETTEXT + +/* Define if you have the finite function. */ +#undef HAVE_FINITE + +/* Define if you have the getcwd function. */ +#undef HAVE_GETCWD + +/* Define if you have the getdelim function. */ +#undef HAVE_GETDELIM + +/* Define if you have the gethostname function. */ +#undef HAVE_GETHOSTNAME + +/* Define if you have the getline function. */ +#undef HAVE_GETLINE + +/* Define if you have the getpagesize function. */ +#undef HAVE_GETPAGESIZE + +/* Define if you have the getpid function. */ +#define HAVE_GETPID 1 + +/* Define if you have the isinf function. */ +#undef HAVE_ISINF + +/* Define if you have the isnan function. */ +#undef HAVE_ISNAN + +/* Define if you have the memchr function. */ +#define HAVE_MEMCHR 1 + +/* Define if you have the memmem function. */ +#define HAVE_MEMMEM 0 + +/* Define if you have the memmove function. */ +#define HAVE_MEMMOVE 1 + +/* Define if you have the memset function. */ +#define HAVE_MEMSET 1 + +/* Define if you have the munmap function. */ +#undef HAVE_MUNMAP + +/* Define if you have the putenv function. */ +#define HAVE_PUTENV 1 + +/* Define if you have the setenv function. */ +#undef HAVE_SETENV + +/* Define if you have the setlocale function. */ +#define HAVE_SETLOCALE 1 + +/* Define if you have the stpcpy function. */ +#define HAVE_STPCPY 1 + +/* Define if you have the strcasecmp function. */ +#undef HAVE_STRCASECMP + +/* Define if you have the strchr function. */ +#undef HAVE_STRCHR + +/* Define if you have the strerror function. */ +#define HAVE_STRERROR 1 + +/* Define if you have the strncasecmp function. */ +#undef HAVE_STRNCASECMP + +/* Define if you have the strpbrk function. */ +#define HAVE_STRPBRK 1 + +/* Define if you have the strstr function. */ +#define HAVE_STRSTR 1 + +/* Define if you have the strtod function. */ +#define HAVE_STRTOD 1 + +/* Define if you have the strtol function. */ +#define HAVE_STRTOL 1 + +/* Define if you have the strtoul function. */ +#define HAVE_STRTOUL 1 + +/* Define if you have the header file. */ +#undef HAVE_ARGZ_H + +/* Define if you have the header file. */ +#undef HAVE_FPU_CONTROL_H + +/* Define if you have the header file. */ +#define HAVE_LIMITS_H 1 + +/* Define if you have the header file. */ +#define HAVE_LOCALE_H 1 + +/* Define if you have the header file. */ +#define HAVE_MALLOC_H 1 + +/* Define if you have the header file. */ +#define HAVE_MEMORY_H 1 + +/* Define if you have the header file. */ +#undef HAVE_NL_TYPES_H + +/* Define if you have the header file. */ +#undef HAVE_READLINE_HISTORY_H + +/* Define if you have the header file. */ +#undef HAVE_READLINE_READLINE_H + +/* Define if you have the header file. */ +#define HAVE_STRING_H 1 + +/* Define if you have the header file. */ +#undef HAVE_SYS_TIME_H + +/* Define if you have the header file. */ +#define HAVE_SYS_TYPES_H 1 + +/* Define if you have the header file. */ +#undef HAVE_TERMCAP_H + +/* Define if you have the header file. */ +#undef HAVE_UNISTD_H + +/* Define if you have the header file. */ +#define HAVE_VALUES_H 1 + +/* Define if you have the i library (-li). */ +#undef HAVE_LIBI + +/* Define if you have the m library (-lm). */ +#undef HAVE_LIBM + +/* Define if you have the readline library (-lreadline). */ +#undef HAVE_LIBREADLINE + +#include + +/* Local Variables: */ +/* mode:c */ +/* End: */ diff --git a/sysdeps/borlandc5.0/libintl.h b/sysdeps/borlandc5.0/libintl.h new file mode 100644 index 00000000..67dbe228 --- /dev/null +++ b/sysdeps/borlandc5.0/libintl.h @@ -0,0 +1,20 @@ +/* PSPP - computes sample statistics. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +/* Nothing needed here. */ diff --git a/sysdeps/borlandc5.0/mk-bc5-dist b/sysdeps/borlandc5.0/mk-bc5-dist new file mode 100755 index 00000000..fc6e9012 --- /dev/null +++ b/sysdeps/borlandc5.0/mk-bc5-dist @@ -0,0 +1,69 @@ +#! /bin/sh -e + +# This script makes a source distribution for compilation under +# Borland C++ 5.0. It also produces a .iwz file for use with +# InstallShield Express. + +if test "$1" = ""; then + echo "usage: $0 \'DOS-path-to-PSPP-source\' \'DOS-path-to-Borland-C++-5.0-root\'" +fi + +test -f src/q2c.c || (echo "Not in PSPP source directory" && exit 1) + +make distdir + +DOSROOT="$1" +VERSION=`sed -ne 's/^.*\[//;s/].*$//;/^[0-9]*\.[0-9]*\.[0-9]*$/p' < configure.in` +BC5ROOT=`pwd`/pspp-$VERSION-bc5 +DISTROOT=`pwd` + +rm -rf $BC5ROOT +cp -r pspp-$VERSION $BC5ROOT +rm -f $DISTROOT/manualfiles.tmp +rm -f $DISTROOT/testsfiles.tmp + +cd $BC5ROOT/doc +texi2html -number -monolithic FAQ.texi + +mkdir $BC5ROOT/manual +cd $BC5ROOT/manual +texi2html -menu -number -split_node ../doc/pspp.texi +cp pspp_toc.html index.html + +n_manual=0 +for d in *; do + n_manual=`expr $n_manual + 1` + echo "Group5File$n_manual=${DOSROOT}\\MANUAL\\$d" >> $DISTROOT/manualfiles.tmp +done + +cd $BC5ROOT/tests +n_tests=0 +for d in *; do + n_tests=`expr $n_tests + 1` + echo "Group3File$n_tests=${DOSROOT}\\TESTS\\$d" >> $DISTROOT/testsfiles.tmp +done + +SEDDOSROOT=`echo "$1" | sed 's/\\\\/\\\\\\\\/'` +echo "s%@BASEDIR@%$SEDDOSROOT%g" > $DISTROOT/bc5.sed +SEDBC5BASEDIR=`echo "$2" | sed 's/\\\\/\\\\\\\\/'` +echo "s%@BC5BASEDIR@%$SEDBC5BASEDIR%g" >> $DISTROOT/bc5.sed +echo "s%@MANUALCOUNT@%$n_manual%g" >> $DISTROOT/bc5.sed +echo "s%@TESTSCOUNT@%$n_tests%g" >> $DISTROOT/bc5.sed + +IN=$BC5ROOT/sysdeps/borlandc5.0/pspp.iwz.in +OUT=$BC5ROOT/pspp.iwz +sed -n -f $DISTROOT/bc5.sed -e '1,/^Group3Dir/p' < $IN > $OUT +cat $DISTROOT/testsfiles.tmp >> $OUT +sed -n -f $DISTROOT/bc5.sed -e '/^Group4Size/,/^Group5Dir/p' < $IN >> $OUT +cat $DISTROOT/manualfiles.tmp < $IN >> $OUT +sed -n -f $DISTROOT/bc5.sed -e '/^Group5Size/,$p' < $IN >> $OUT + +cp $BC5ROOT/sysdeps/borlandc5.0/pspp.ide $BC5ROOT/pspp.ide +cp $BC5ROOT/pref.h.orig $BC5ROOT/sysdeps/borlandc5.0/pref.h + +rm $DISTROOT/manualfiles.tmp +rm $DISTROOT/testsfiles.tmp +rm $DISTROOT/bc5.sed + +find $BC5ROOT -type f | xargs perl $DISTROOT/sysdeps/borlandc5.0/unix2dos.pl +find $BC5ROOT -name \*.bak | xargs rm -f diff --git a/sysdeps/borlandc5.0/pspp.ico b/sysdeps/borlandc5.0/pspp.ico new file mode 100755 index 00000000..4157a06a Binary files /dev/null and b/sysdeps/borlandc5.0/pspp.ico differ diff --git a/sysdeps/borlandc5.0/pspp.ide b/sysdeps/borlandc5.0/pspp.ide new file mode 100644 index 00000000..be51720f Binary files /dev/null and b/sysdeps/borlandc5.0/pspp.ide differ diff --git a/sysdeps/borlandc5.0/pspp.iwz.in b/sysdeps/borlandc5.0/pspp.iwz.in new file mode 100755 index 00000000..867f1edc --- /dev/null +++ b/sysdeps/borlandc5.0/pspp.iwz.in @@ -0,0 +1,383 @@ +[InstallShield Wizard] +iDate=0 +iTime=0 +Flag=0 +ISX.EXE Size=668160 +ISX.EXE Date=12:49:10AM 12/18/1996 +ISX.EXE Ver=1.11.0.0 +SETUP.EXE Size=44928 +SETUP.EXE Date=1:04:12PM 11/4/1996 +SETUP.EXE Ver=3.0.107.0 +SETUP.INS Size=66760 +SETUP.INS Date=5:50:16PM 3/7/1997 +SETUP.INS Ver=Not available +_INST16.EX_ Size=66760 +_INST16.EX_ Date=5:50:16PM 3/7/1997 +_INST16.EX_ Ver=Not available +_INST32I.EX_ Size=320276 +_INST32I.EX_ Date=4:17:32PM 11/5/1996 +_INST32I.EX_ Ver=Not available +ISDEPEND.INI Size=5102 +ISDEPEND.INI Date=4:31:20PM 6/11/1996 +ISDEPEND.INI Ver=Not available +SWDEPEND.INI Size=4605 +SWDEPEND.INI Date=1:12:52AM 3/12/1997 +SWDEPEND.INI Ver=Not available +ICOMP.EXE Size=119808 +ICOMP.EXE Date=3:05:10PM 1/15/1996 +ICOMP.EXE Ver=3.00.062 +SPLIT.EXE Size=90624 +SPLIT.EXE Date=3:09:36PM 1/15/1996 +SPLIT.EXE Ver=3.00.060 +PACKLIST.EXE Size=87552 +PACKLIST.EXE Date=3:10:30PM 1/15/1996 +PACKLIST.EXE Ver=3.00.060 +Version=1.11a +DevTool=for Borland C++ 5.0 +Platform=Win32 +PtrBase=30100 +PtrPosY=227 +PtrPage=4 +DisksBuilt=1 +DisksDir=PSPP\144MB\ +TabsVisit=1111111110000111111 +LangNum=0 + +[VisualDesign] +AppName=PSPP +AppExe=[Program Files]\pspp.exe +Version=0.1.0 +Company=Free Software Foundation +Title=PSPP +TitleType=1 +BackgrndBmp=@BASEDIR@\sysdeps\borlandc5.0\sm-gnu-hd.bmp +BackgrndAlign=4 +Backgrnd=1 +BackgrndColor=0 +Uninstall=1 +Silent=1 +SmsMode=0 + +[RegEntries] +Reg1Path=HKEY_CLASSES_ROOT +Reg1Val1Type=0 +Reg1Val1Name=(Default) +Reg1Val1Data=(value not set) +Reg1Vals=1 +Reg2Path=HKEY_CURRENT_USER +Reg2Val1Type=0 +Reg2Val1Name=(Default) +Reg2Val1Data=(value not set) +Reg2Vals=1 +Reg3Path=HKEY_LOCAL_MACHINE +Reg3Val1Type=0 +Reg3Val1Name=(Default) +Reg3Val1Data=(value not set) +Reg3Vals=1 +Reg4Path=HKEY_USERS +Reg4Val1Type=0 +Reg4Val1Name=(Default) +Reg4Val1Data=(value not set) +Reg4Vals=1 +Reg5Path=HKEY_CURRENT_CONFIG +Reg5Val1Type=0 +Reg5Val1Name=(Default) +Reg5Val1Data=(value not set) +Reg5Vals=1 +Reg6Path=HKEY_DYN_DATA +Reg6Val1Type=0 +Reg6Val1Name=(Default) +Reg6Val1Data=(value not set) +Reg6Vals=1 +Reg7Path=HKEY_CLASSES_ROOT\PSPP.Script +Reg7PathUninstall=1 +Reg7Val1Type=0 +Reg7Val1Name=(Default) +Reg7Val1Data=PSPP Script +Reg7Vals=1 +Reg8Path=HKEY_CLASSES_ROOT\PSPP.Script\shell +Reg8PathUninstall=1 +Reg8Val1Type=0 +Reg8Val1Name=(Default) +Reg8Val1Data=(value not set) +Reg8Vals=1 +Reg9Path=HKEY_CLASSES_ROOT\PSPP.Script\shell\open +Reg9PathUninstall=1 +Reg9Val1Type=0 +Reg9Val1Name=(Default) +Reg9Val1Data=(value not set) +Reg9Vals=1 +Reg10Path=HKEY_CLASSES_ROOT\.stat +Reg10PathUninstall=1 +Reg10Val1Type=0 +Reg10Val1Name=(Default) +Reg10Val1Data=PSPP.Script +Reg10Vals=1 +Reg11Path=HKEY_CLASSES_ROOT\PSPP.Script\DefaultIcon +Reg11PathUninstall=1 +Reg11Val1Type=0 +Reg11Val1Name=(Default) +Reg11Val1Data=\PSPP.ICO +Reg11Vals=1 +Reg12Path=HKEY_CLASSES_ROOT\.sps +Reg12PathUninstall=1 +Reg12Val1Type=0 +Reg12Val1Name=(Default) +Reg12Val1Data=PSPP.Script +Reg12Vals=1 +Reg13Path=HKEY_CLASSES_ROOT\.spss +Reg13PathUninstall=1 +Reg13Val1Type=0 +Reg13Val1Name=(Default) +Reg13Val1Data=PSPP.Script +Reg13Vals=1 +Reg14Path=HKEY_CLASSES_ROOT\PSPP.Script\shell\open\command +Reg14PathUninstall=1 +Reg14Val1Type=0 +Reg14Val1Name=(Default) +Reg14Val1Data=\PSPP.EXE %1 +Reg14Vals=1 +Reg15Path=HKEY_CLASSES_ROOT\.lst +Reg15PathUninstall=1 +Reg15Val1Type=0 +Reg15Val1Name=(Default) +Reg15Val1Data=PSPP.Listing +Reg15Vals=1 +Reg16Path=HKEY_CLASSES_ROOT\.list +Reg16PathUninstall=1 +Reg16Val1Type=0 +Reg16Val1Name=(Default) +Reg16Val1Data=PSPP.Listing +Reg16Vals=1 +Reg17Path=HKEY_CLASSES_ROOT\PSPP.Listing +Reg17PathUninstall=1 +Reg17Val1Type=0 +Reg17Val1Name=(Default) +Reg17Val1Data=PSPP Listing Output +Reg17Vals=1 +Reg18Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell +Reg18PathUninstall=1 +Reg18Val1Type=0 +Reg18Val1Name=(Default) +Reg18Val1Data=(value not set) +Reg18Vals=1 +Reg19Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell\open +Reg19PathUninstall=1 +Reg19Val1Type=0 +Reg19Val1Name=(Default) +Reg19Val1Data=(value not set) +Reg19Vals=1 +Reg20Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell\open\command +Reg20PathUninstall=1 +Reg20Val1Type=0 +Reg20Val1Name=(Default) +Reg20Val1Data=\NOTEPAD.EXE %1 +Reg20Vals=1 +Reg21Path=HKEY_CLASSES_ROOT\PSPP.Listing\DefaultIcon +Reg21PathUninstall=1 +Reg21Val1Type=0 +Reg21Val1Name=(Default) +Reg21Val1Data=\PSPP.ICO +Reg21Vals=1 +Regs=21 + +[Registry] +Reg1Path=HKEY_CLASSES_ROOT\PSPP.Script +Reg1PathUninstall=1 +Reg1ValName=(Default) +Reg1ValType=0 +Reg1ValData=PSPP Script +Reg2Path=HKEY_CLASSES_ROOT\PSPP.Script\shell +Reg2PathUninstall=1 +Reg3Path=HKEY_CLASSES_ROOT\PSPP.Script\shell\open +Reg3PathUninstall=1 +Reg4Path=HKEY_CLASSES_ROOT\.stat +Reg4PathUninstall=1 +Reg4ValName=(Default) +Reg4ValType=0 +Reg4ValData=PSPP.Script +Reg5Path=HKEY_CLASSES_ROOT\PSPP.Script\DefaultIcon +Reg5PathUninstall=1 +Reg5ValName=(Default) +Reg5ValType=0 +Reg5ValData=\PSPP.ICO +Reg6Path=HKEY_CLASSES_ROOT\.sps +Reg6PathUninstall=1 +Reg6ValName=(Default) +Reg6ValType=0 +Reg6ValData=PSPP.Script +Reg7Path=HKEY_CLASSES_ROOT\.spss +Reg7PathUninstall=1 +Reg7ValName=(Default) +Reg7ValType=0 +Reg7ValData=PSPP.Script +Reg8Path=HKEY_CLASSES_ROOT\PSPP.Script\shell\open\command +Reg8PathUninstall=1 +Reg8ValName=(Default) +Reg8ValType=0 +Reg8ValData=\PSPP.EXE %1 +Reg9Path=HKEY_CLASSES_ROOT\.lst +Reg9PathUninstall=1 +Reg9ValName=(Default) +Reg9ValType=0 +Reg9ValData=PSPP.Listing +Reg10Path=HKEY_CLASSES_ROOT\.list +Reg10PathUninstall=1 +Reg10ValName=(Default) +Reg10ValType=0 +Reg10ValData=PSPP.Listing +Reg11Path=HKEY_CLASSES_ROOT\PSPP.Listing +Reg11PathUninstall=1 +Reg11ValName=(Default) +Reg11ValType=0 +Reg11ValData=PSPP Listing Output +Reg12Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell +Reg12PathUninstall=1 +Reg13Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell\open +Reg13PathUninstall=1 +Reg14Path=HKEY_CLASSES_ROOT\PSPP.Listing\shell\open\command +Reg14PathUninstall=1 +Reg14ValName=(Default) +Reg14ValType=0 +Reg14ValData=\NOTEPAD.EXE %1 +Reg15Path=HKEY_CLASSES_ROOT\PSPP.Listing\DefaultIcon +Reg15PathUninstall=1 +Reg15ValName=(Default) +Reg15ValType=0 +Reg15ValData=\PSPP.ICO +Regs=15 + +[Groups] +Groups=6 +Group1Size=421589 +Group1Files=6 +Group1Name=Program Files +Group1Dir= +Group1File1=@BASEDIR@\pspp.exe +Group1File2=@BASEDIR@\config\devices +Group1File3=@BASEDIR@\config\papersize +Group1File4=@BASEDIR@\config\ps-prologue +Group1File5=@BASEDIR@\COPYING +Group1File6=@BASEDIR@\sysdeps\borlandc5.0\pspp.ICO +Group2Size=43097 +Group2Files=4 +Group2Name=Help Files - HTML +Group2Dir=\HELP +Group2File1=@BASEDIR@\doc\BUGS.html +Group2File2=@BASEDIR@\doc\LANGUAGE.html +Group2File3=@BASEDIR@\doc\README.html +Group2File4=@BASEDIR@\doc\THANKS.html +Group3Size=104388 +Group3Files=@TESTSCOUNT@ +Group3Name=Test Files +Group3Dir=\TESTS +Group4Size=63652 +Group4Files=7 +Group4Name=Help Files - ASCII +Group4Dir=\HELP\ASCII +Group4File1=@BASEDIR@\BUGS +Group4File2=@BASEDIR@\LANGUAGE +Group4File3=@BASEDIR@\NEWS +Group4File4=@BASEDIR@\README +Group4File5=@BASEDIR@\THANKS +Group4File6=@BASEDIR@\TODO +Group4File7=@BASEDIR@\AUTHORS +Group5Size=336614 +Group5Files=@MANUALCOUNT@ +Group5Name=Manual - HTML +Group5Dir=\HELP\MANUAL +Group6Size=229376 +Group6Files=1 +Group6Auto=108 +Group6ID=38308 +Group6Name=System Files +Group6Dir= +Group6File1=@BC5BASEDIR@\BIN\CW3220.DLL +Group6File1Auto=108 + +[Components] +Components=4 +Component1Groups=2 +Component1Name=Application Files +Component1Description=Application files needed to run the application +Component1GroupList=1 6 +Component2Groups=2 +Component2Name=Help and Tutorial Files +Component2Description=Help and tutorial needed for online help +Component2GroupList=2 4 +Component3Groups=1 +Component3Name=Sample Files +Component3Description=Sample data files +Component3GroupList=3 +Component4Groups=1 +Component4Name=Manual - HTML +Component4Description=On-line manual in World Wide Web HTML format. +Component4GroupList=5 + +[Types] +Types=3 +Type1Components=4 +Type1Name=Custom +Type1ComponentList=1 2 3 4 +Type2Components=4 +Type2Name=Typical +Type2ComponentList=1 2 3 4 +Type3Components=1 +Type3Name=Compact +Type3ComponentList=1 + +[Sequence] +DestinationLocationDir=\Free Software Foundation\PSPP +SelectProgramFolderName=PSPP +WelcomeMessage=1 +LicenseAgreement=1 +LicenseAgreementFile=@BASEDIR@\copying +DestinationLocation=1 +SetupType=1 +CustomSetup=1 +CustomSetupGroupSel=1 +SelectProgramFolder=1 +BeginFileTransfer=1 +ProgressBar=1 +Billboards=1 +BillboardsFile=@BASEDIR@\sysdeps\borlandc5.0\ +SetupComplete=1 + +[Icons] +Icons=5 +Icon1Cmd=[Program Files]\pspp.exe +Icon1Description=PSPP +Icon1WorkingDir=[Program Files] +Icon1IconFile=[Program Files]\pspp.ICO +Icon1RealFile=@BASEDIR@\sysdeps\borlandc5.0\pspp.ICO +Icon1WhichIcon=0 +Icon1KeyVirtual=0 +Icon1KeyFlags=0 +Icon2Cmd=[Help Files - HTML]\BUGS.html +Icon2Description=Bugs +Icon2WorkingDir=[Help Files - HTML] +Icon2RealFile=@BASEDIR@\doc\BUGS.html +Icon2WhichIcon=0 +Icon2KeyVirtual=0 +Icon2KeyFlags=0 +Icon3Cmd=[Help Files - HTML]\LANGUAGE.html +Icon3Description=Language Notes +Icon3WorkingDir=[Help Files - HTML] +Icon3RealFile=@BASEDIR@\doc\LANGUAGE.html +Icon3WhichIcon=0 +Icon3KeyVirtual=0 +Icon3KeyFlags=0 +Icon4Cmd=[Help Files - HTML]\README.html +Icon4Description=README +Icon4WorkingDir=[Help Files - HTML] +Icon4RealFile=@BASEDIR@\doc\README.html +Icon4WhichIcon=0 +Icon4KeyVirtual=0 +Icon4KeyFlags=0 +Icon5Cmd=[Manual - HTML]\pspp_toc.html +Icon5Description=Manual +Icon5WorkingDir=[Manual - HTML] +Icon5RealFile=@BASEDIR@\MANUAL\pspp_toc.html +Icon5WhichIcon=0 +Icon5KeyVirtual=0 +Icon5KeyFlags=0 diff --git a/sysdeps/borlandc5.0/setup1.bmp b/sysdeps/borlandc5.0/setup1.bmp new file mode 100755 index 00000000..620981e0 Binary files /dev/null and b/sysdeps/borlandc5.0/setup1.bmp differ diff --git a/sysdeps/borlandc5.0/sm-gnu-hd.bmp b/sysdeps/borlandc5.0/sm-gnu-hd.bmp new file mode 100755 index 00000000..6aaa8afc Binary files /dev/null and b/sysdeps/borlandc5.0/sm-gnu-hd.bmp differ diff --git a/sysdeps/borlandc5.0/unix2dos.pl b/sysdeps/borlandc5.0/unix2dos.pl new file mode 100644 index 00000000..95ee10d9 --- /dev/null +++ b/sysdeps/borlandc5.0/unix2dos.pl @@ -0,0 +1,19 @@ +#!/usr/bin/perl +while (<>) { + if ($ARGV ne $oldargv) { + $translate = -T $ARGV; + rename($ARGV, $ARGV . '.bak'); + open(ARGVOUT, ">$ARGV"); + select(ARGVOUT); + $oldargv = $ARGV; + } + if ($translate) { + chop; + $_ .= " +"; + } +} +continue { + print; # this prints to original filename +} +select(STDOUT); diff --git a/sysdeps/borlandc5.0/version.c b/sysdeps/borlandc5.0/version.c new file mode 100644 index 00000000..e7284769 --- /dev/null +++ b/sysdeps/borlandc5.0/version.c @@ -0,0 +1,7 @@ +#include +char bare_version[] = VERSION; +char version[] = GNU_PACKAGE " " VERSION; +char stat_version[] = GNU_PACKAGE " " VERSION + " (Fri Jul 11 12:33:09 GMT-5:00 1997)."; +char host_system[] = "i586-borlandc5.0"; +char build_system[] = "i586-borlandc5.0"; diff --git a/sysdeps/windows/README b/sysdeps/windows/README new file mode 100644 index 00000000..63258b4e --- /dev/null +++ b/sysdeps/windows/README @@ -0,0 +1,10 @@ +PSPP currently runs only as a console-mode application under Windows +environments. Since Windows 3.1 does not provide a console, PSPP +needs special assistance to run under Windows 3.1. con32s is a small +library that I have developed to do this. This directory contains the +compiler-independent portion of con32s. There is also a small +compiler-dependent portion that need to be written for each compiler. +See the example for Borland C++ for more details. + + -blp + diff --git a/sysdeps/windows/con32s.c b/sysdeps/windows/con32s.c new file mode 100644 index 00000000..f184f870 --- /dev/null +++ b/sysdeps/windows/con32s.c @@ -0,0 +1,504 @@ +/* con32s - emulates Windows console. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include +#include +#include +#include +#include + +typedef struct line_struct line; +struct line_struct + { + line *next, *prev; /* next and previous lines */ + char *text; /* text */ + int len; /* number of characters in text */ + int size; /* maximum allocated size for text */ + }; /* line */ + +/* Pointer to tail end of text lines. */ +static line *tail; + +/* Console window created. */ +static int inited = 0; + +/* Console window title. */ +static const char *title = _("Con32s Console Emulator by Ben Pfaff"); + +/* Important variables. */ +HINSTANCE _hInstance; +HINSTANCE _hPrev; +LPSTR _cmdline; +int _nCmdShow; + +/* Console window. */ +HWND wnd; + +/* Width, height of a single character in the console font. */ +int cw, ch; + +/* Width, height of console window in characters. */ +int nw, nh; + +/* Keyboard buffer. */ +#define MAX_KBD_BUF 80 /* Maximum number of characters to buffer. */ +char kbd[MAX_KBD_BUF]; +char *hp, *tp; /* Keyboard buffer head, tail. */ + +static void +outmsg (char *format,...) +{ + va_list args; + char s[128]; + + va_start (args, format); + vsprintf (s, format, args); + va_end (args); + MessageBox (_hInstance, s, "Con32s", + MB_OK | MB_ICONHAND | MB_SYSTEMMODAL); +} + +static void * +xmalloc (size_t size) +{ + void *vp; + if (size == 0) + return NULL; + vp = malloc (size); + if (!vp) + { + MessageBox (NULL, _("xmalloc(): out of memory"), NULL, MB_OK); + exit (EXIT_FAILURE); + } + return vp; +} + +static void * +xrealloc (void *ptr, size_t size) +{ + void *vp; + if (!size) + { + if (ptr) + free (ptr); + return NULL; + } + if (ptr) + vp = realloc (ptr, size); + else + vp = malloc (size); + if (!vp) + { + MessageBox (NULL, _("xrealloc(): out of memory"), NULL, MB_OK); + exit (EXIT_FAILURE); + } + return vp; +} + +void _blp_console_init (void); +void _blp_console_yield (void); +void _blp_console_paint (void); +void find_console_top (line ** top); +void find_console_bottom (int *x, int *y, line ** bottom); + +static void +writechar (int c) +{ + int x, y; + line *bottom; + + static HDC dc; + + if (c == 10000) + { + if (dc) + { + ReleaseDC (wnd, dc); + dc = 0; + } + return; + } + + if (!tail) + { + tail = xmalloc (sizeof (line)); + tail->next = tail->prev = NULL; + tail->text = NULL; + tail->len = tail->size = 0; + } + + switch (c) + { + case '\n': + { + tail->next = xmalloc (sizeof (line)); + tail->next->prev = tail; + tail = tail->next; + tail->next = NULL; + tail->text = NULL; + tail->len = tail->size = 0; + } + break; + case '\r': + break; + case '\b': + { + find_console_bottom (&x, &y, &bottom); + if (tail->len) + tail->len--; + else + { + tail = tail->prev; + free (tail->next); + tail->next = NULL; + } + + if (x > 1) + { + if (!dc) + { + dc = GetDC (wnd); + SelectObject (dc, GetStockObject (ANSI_FIXED_FONT)); + assert (dc); + } + TextOut (dc, x * cw, y * ch, " ", 1); + return; + } + } + break; + default: + { + if (tail->len + 1 > tail->size) + { + tail->size += 16; + tail->text = xrealloc (tail->text, tail->size); + } + + find_console_bottom (&x, &y, &bottom); + tail->text[tail->len++] = c; + if (y < nh) + { + if (!dc) + { + dc = GetDC (wnd); + SelectObject (dc, GetStockObject (ANSI_FIXED_FONT)); + assert (dc); + } + TextOut (dc, x * cw, y * ch, &tail->text[tail->len - 1], 1); + return; + } + } + break; + } + InvalidateRect (wnd, NULL, TRUE); +} + +/* Writes LEN bytes from BUF to the fake console window. */ +int +_blp_console_write (const void *buf, unsigned len) +{ + int i; + + if (!inited) + _blp_console_init (); + for (i = 0; i < len; i++) + writechar (((char *) buf)[i]); + writechar (10000); + return len; +} + +/* Reads one character from the fake console window. A whole line + is read at once, then spoon-fed to the runtime library. */ +#if __BORLANDC__ +#pragma argsused +#endif +int +_blp_console_read (const void *t1, unsigned t2) +{ + static char buf[1024]; + static int len; + static int n; + + MSG msg; + + int c; + + if (!inited) + _blp_console_init (); + if (n < len) + { + *(char *) t1 = buf[n]; + n++; + return 1; + } + + printf ("_"); + len = n = 0; + while (GetMessage ((LPMSG) & msg, NULL, 0, 0)) + { + TranslateMessage ((LPMSG) & msg); + DispatchMessage ((LPMSG) & msg); + + while (hp != tp) + { + c = *(unsigned char *) tp; + if (++tp >= &kbd[MAX_KBD_BUF]) + tp = kbd; + if ((c >= 32 && c < 128) || c == '\b' || c == '\r') + switch (c) + { + case '\b': + if (len <= 0) + break; + printf ("\b\b_"); + len--; + break; + default: + if (len >= 1022) + break; + if (c == '\r') + { + buf[len++] = '\n'; + printf ("\b\n"); + *(char *) t1 = buf[n]; + n++; + return 1; + } + buf[len++] = c; + printf ("\b%c_", c); + break; + } + } + } + len = 0; + return 0; +} + +LRESULT CALLBACK _export _blp_console_wndproc (HWND, UINT, WPARAM, LPARAM); + +void +_blp_console_init (void) +{ + WNDCLASS wc; + + if (inited) + return; + inited = 1; + wc.style = CS_HREDRAW | CS_VREDRAW; + wc.lpfnWndProc = _blp_console_wndproc; + wc.cbClsExtra = 0; + wc.cbWndExtra = 0; + wc.hInstance = (HINSTANCE) _hInstance; + wc.hIcon = LoadIcon (NULL, IDI_APPLICATION); + wc.hCursor = LoadCursor (NULL, IDC_ARROW); + wc.hbrBackground = CreateSolidBrush (RGB (255, 255, 255)); + wc.lpszMenuName = NULL; + wc.lpszClassName = "blp_console"; + if (!RegisterClass (&wc)) + { + MessageBox ((HWND) 0, _("RegisterClass(): returned 0."), + "_blp_console_init()", MB_APPLMODAL | MB_OK); + exit (EXIT_FAILURE); + } + + wnd = CreateWindow ("blp_console", title, WS_OVERLAPPEDWINDOW, + CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, + CW_USEDEFAULT, NULL, (HMENU) 0, (HINSTANCE) _hInstance, + NULL); + if (!wnd) + { + MessageBox ((HWND) 0, _("CreateWindow(): returned 0."), + "_blp_console_init()", MB_APPLMODAL | MB_OK); + exit (EXIT_FAILURE); + } + + ShowWindow (wnd, _nCmdShow); + + hp = tp = kbd; +} + +LRESULT CALLBACK _export +_blp_console_wndproc (HWND hwnd, UINT msg, WPARAM wp, LPARAM lp) +{ + char s[80]; + + switch (msg) + { + case WM_CREATE: + { + HDC dc = GetDC (hwnd); + TEXTMETRIC tm; + int success; + + SelectObject (dc, GetStockObject (ANSI_FIXED_FONT)); + success = GetTextMetrics (dc, &tm); + assert (success); + cw = tm.tmMaxCharWidth; + ch = tm.tmHeight; + success = ReleaseDC (hwnd, dc); + assert (success); + return 0; + } + case WM_PAINT: + _blp_console_paint (); + return 0; + case WM_CHAR: + { + if (hp + 1 != tp && (hp != &kbd[MAX_KBD_BUF - 1] || tp != kbd)) + { + *hp++ = wp; + if (hp >= &kbd[MAX_KBD_BUF]) + hp = kbd; + } + } + break; + } + return DefWindowProc (hwnd, msg, wp, lp); +} + +static void +find_console_top (line ** top) +{ + int success; + + /* Line count. */ + int lc; + + /* Line iterator. */ + line *iter; + + /* Scratch line. */ + static line temp; + + /* Client rectangle. */ + RECT r; + + success = GetClientRect (wnd, &r); + assert (success); + nw = r.right / cw; + if (nw < 1) + nw = 1; + nh = r.bottom / ch; + if (nh < 1) + nh = 1; + + /* Find the beginning of the text to display. */ + for (lc = 0, iter = tail; iter; iter = iter->prev) + { + if (!iter->len) + lc++; + else + lc += (iter->len / nw) + (iter->len % nw > 0); + if (lc >= nh || !iter->prev) + break; + } + if (lc > nh) + { + temp = *iter; + temp.text += nw * (lc - nh); + temp.len -= nw * (lc - nh); + *top = &temp; + } + else + *top = iter; +} + +static void +find_console_bottom (int *x, int *y, line ** bottom) +{ + find_console_top (bottom); + *x = *y = 0; + if (!*bottom) + return; + while (1) + { + if ((*bottom)->len == 0) + (*y)++; + else + (*y) += ((*bottom)->len / nw) + ((*bottom)->len % nw > 0); + if (!(*bottom)->next) + break; + *bottom = (*bottom)->next; + } + *x = (*bottom)->len % nw; + (*y)--; +} + +void +_blp_console_paint (void) +{ + PAINTSTRUCT ps; + HDC dc; + + /* Current screen location. */ + int x, y; + + /* Current line. */ + line *iter; + + dc = BeginPaint (wnd, &ps); + assert (dc); + + find_console_top (&iter); + + /* Display the text. */ + SelectObject (dc, GetStockObject (ANSI_FIXED_FONT)); + SetTextColor (dc, RGB (0, 0, 0)); + for (y = 0; iter; iter = iter->next) + { + if (!iter->len) + { + y += ch; + continue; + } + for (x = 0; x < iter->len; x += nw) + { + TextOut (dc, 0, y, &iter->text[x], + iter->len - x > nw ? nw : iter->len - x); + y += ch; + } + } + + EndPaint (wnd, &ps); +} + +int main (int argc, char *argv[], char *env[]); + +#if __BORLANDC__ +#pragma argsused +#endif +int CALLBACK +WinMain (HINSTANCE inst, HINSTANCE prev, LPSTR cmdline, int nCmdShow) +{ + int result; + MSG msg; + + char *pgmname = "PSPP"; + + _hInstance = inst; + _hPrev = prev; + _cmdline = cmdline; + _nCmdShow = nCmdShow; + + result = main (1, &pgmname, NULL); + + return result; +} diff --git a/tests/ChangeLog b/tests/ChangeLog new file mode 100644 index 00000000..5ae181d9 --- /dev/null +++ b/tests/ChangeLog @@ -0,0 +1,351 @@ +Fri Jan 7 20:30:23 2000 Ben Pfaff + + * data-fmts.stat: Add more date tests. + + * do-repeat.stat: SET ECHO ON. + + * syntax: Replace test -L with test -h. + +Tue Jan 5 14:21:52 1999 Ben Pfaff + + * data-list.stat, data-list.data: Adjust so that it can tell if + DATA LIST FREE properly parses and pads string values. + + * list.stat: Remove anachronistic `SET EMULATION PC'. + + * Rebuilt benchmark. + +Tue Jan 5 14:12:58 1999 Ben Pfaff + + * syntax: Replaced `test' calls with `['. This may or may not fix + the problems some people have reported. + +Sun Aug 9 11:15:38 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Update for renamed files. + + * autorecode.stat: Renamed autorecod.stat. + + * begin-data.stat: Renamed beg-data.stat. + + * data-formats.stat: Renamed data-fmts.stat. + + * expression.stat: Renamed expr.stat. + + * file-label.stat: Renamed file-lab.stat. + + * input-program.stat: Renamed inpt-pgm.stat. + + * modify-vars.stat: Renamed mdfy-vars.stat. + + * match-files.stat: Renamed mtch-file.stat. + + * process-if.stat: Renamed pcs-if.stat. + + * split-file.stat: Renamed splt-file.stat. + + * sysfile-info.stat: Renamed sys-info.stat. + + * expect/: Refreshed. + +Sat Aug 8 00:27:07 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add `syntax'. + (dist-hook) New target. + +Wed Aug 5 00:04:16 1998 Ben Pfaff + + * TEST-RESULTS: Removed. + + * show-check-msg: Removed. + + * expect/: New. + + * syntax: New. Thanks to James R. Van Zandt + for this implementation of automatic testing. + + * Makefile: (TESTS) Set to the syntax script. + (bench) New target. + (EXTRA_DIST) Remove TEST-RESULTS. Add `syntax'. + +Sun Jul 5 14:16:18 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add flip.stat. + +Sun Jul 5 00:50:41 1998 Ben Pfaff + + * crosstabs.stat: Change to test /MISSING=REPORT. + +Tue Jun 2 23:42:23 1998 Ben Pfaff + + * flip.stat: New file. + + * weighting.stat: Update. + +Mon May 25 12:45:46 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add crosstabs.stat, match-files.stat. + + * crosstabs.stat: Turn off cells=all. + +Tue May 12 16:22:06 1998 Ben Pfaff + + * crosstabs.stat: Minor changes. + +Thu May 7 23:16:03 1998 Ben Pfaff + + * crosstabs.stat: Replace with a test that is hopefully better. + +Tue Apr 14 01:00:46 1998 Ben Pfaff + + * crosstabs.stat: New. + +Mon Mar 9 15:40:25 1998 Ben Pfaff + + * match-files.stat: More thorough. + +Mon Mar 9 01:14:14 1998 Ben Pfaff + + * match-files.stat: More thorough. + +1998-03-05 Ben Pfaff + + * Makefile.am: Use ./gengarbage instead of gengarbage. + +1998-02-23 Ben Pfaff + + * Many tests: Remove final finish command. + +1998-02-16 Ben Pfaff + + * (DISTCLEANFILES) Clean *.save, pspp.*, foo* + + * file-label.stat, sysfile-info.stat: Replace .sav with .save. + + * match-files.stat: New file. + +Fri Feb 13 15:58:11 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add TEST-RESULTS. + +Tue Jan 13 01:11:36 1998 Ben Pfaff + + * aggregate.stat: Some more testing. + +Sat Jan 10 23:57:14 1998 Ben Pfaff + + * Makefile.am: (DISTCLEANFILES) Add aggregate.save. + + * aggregate.stat: Slightly more thorough. + +Sat Jan 10 02:17:00 1998 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add means.stat, t-test.stat. + + * means.stat: New file. + +Thu Jan 8 22:38:59 1998 Ben Pfaff + + * Many tests: Removed extra newlines from REMARKs. + +Mon Jan 5 11:18:44 1998 Ben Pfaff + + * sysfile-info.stat: Test most of the DISPLAY commands. Update + title. + + * vector.stat: Display vectors. + +Sun Jan 4 18:31:36 1998 Ben Pfaff + + * All tests: Added title. + + * begin-data.stat: Updated REMARK format. + + * descript.stat: Comment fix. + +Sun Dec 21 16:57:31 1997 Ben Pfaff + + * TEST-RESULTS: New file. + +Fri Dec 5 22:02:20 1997 Ben Pfaff + + * Makefile.am: (DISTCLEANFILES) Add fiasco.html. + +Tue Dec 2 14:55:22 1997 Ben Pfaff + + * t-test.stat: New file. + +Fri Nov 14 00:17:25 1997 Ben Pfaff + + * aggregate.stat: Changed. + +Tue Oct 28 16:26:25 1997 Ben Pfaff + + * aggregate.stat: New file. + + * Makefile.am: (EXTRA_DIST) Add aggregate.stat. + +Sun Oct 5 16:02:02 1997 Ben Pfaff + + * fall92.stat, fall92.data: Removed (unknown copyright). + + * gengarbage.c: Define EXIT_SUCCESS if not defined by headers. + From Alexandre Oliva . + +Sat Oct 4 16:35:59 1997 Ben Pfaff + + * repeating.stat: New file. + + * Makefile.am: (EXTRA_DIST) Add repeating.stat. + +Thu Sep 18 21:40:50 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add lag.stat. + +Mon Aug 18 18:31:42 1997 Ben Pfaff + + * do-repeat.stat: Even more useful. + + * lag.stat: New file. + +Sun Aug 17 22:47:53 1997 Ben Pfaff + + * do-repeat.stat: Made actually useful, not stupid. + +Sun Aug 3 11:46:00 1997 Ben Pfaff + + * In several files, replace usage of deprecated term `script' by + `syntax file'. + +Thu Jul 17 02:12:17 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Add tabs.stat. + + * file-label.stat: Improved. + + * sysfile-info.stat: Tests DISPLAY DICTIONARY now as well. + +Fri Jul 11 14:13:49 1997 Ben Pfaff + + * gengarbage.c: Reformat. #include's . Uses ANSI C + rand() in place of random(). Calls the randomizer srand(). + +Thu Jul 10 22:16:34 1997 Ben Pfaff + + * tabs.stat: New file. + +Wed Jun 25 22:54:40 1997 Ben Pfaff + + * Makefile.am: (EXTRA_DIST) Removed bug.stat, file-type.stat. + +Sun Jun 8 01:24:55 1997 Ben Pfaff + + * Makefile.am: Added fiasco.ps, fiasco.list, foo, foo.sav, msgs to + DISTCLEANFILES. + + * input-program.stat: Made some variables scratch. + +Fri Jun 6 22:53:03 1997 Ben Pfaff + + * Many files: Comment fixes, removed `set output raw.' commands. + + * Other miscellaneous changes. + +Tue Jun 3 23:44:46 1997 Ben Pfaff + + * list.stat: Re-enabled some of it. + +Wed Apr 23 21:33:48 1997 Ben Pfaff + + * sysfile-info.stat: A little more generalized now. + +Fri Apr 18 15:42:22 1997 Ben Pfaff + + * Makefile.am: Maintainer-clean Makefile.in. + +Thu Mar 27 01:11:29 1997 Ben Pfaff + + * gengarbage.pl: Removed. + +Sat Feb 15 21:26:53 1997 Ben Pfaff + + * descript.stat: Syntax fixes. + + * process-if.stat: New test for PROCESS IF. + +Sun Jan 19 14:22:11 1997 Ben Pfaff + + * autorecode.stat, modify-vars.stat: More thorough. + + * data-formats.stat, file-label.stat: New tests. + +Thu Jan 16 13:08:57 1997 Ben Pfaff + + * bug.stat: Comment fix. + +Wed Jan 1 22:08:10 1997 Ben Pfaff + + * filter.stat: New file; tests FILTER behavior. + +Wed Jan 1 17:00:59 1997 Ben Pfaff + + * gengarbage.pl: New perl program equivalent to gengarbage.c. + +Sun Dec 29 21:36:48 1996 Ben Pfaff + + * gengarbage.c: Changed. + + * sort.stat: Changed. + +Sun Dec 22 23:10:39 1996 Ben Pfaff + + * sort.stat: New file. + +Fri Dec 13 21:30:53 1996 Ben Pfaff + + * autorecode.stat: New file. + + * fall92.stat: Mods for practicality. + + * test.bat, testall.bat: Removed. + +Thu Nov 28 23:14:07 1996 Ben Pfaff + + * list.stat, weighting.stat: Changed SET COMPATIBILITY subcommand + to SET EMULATION in anticipation of change. + +Sat Oct 26 23:06:06 1996 Ben Pfaff + + * recode.stat: Removed comment about bug, since I fixed that. + +Thu Oct 24 20:13:42 1996 Ben Pfaff + + * print.stat: Slightly more thorough. + +Thu Oct 24 17:47:14 1996 Ben Pfaff + + * time-date.stat: Slightly more thorough. + +Wed Oct 23 21:53:43 1996 Ben Pfaff + + * time-date.stat: New file. + +Thu Sep 26 22:20:26 1996 Ben Pfaff + + * list.data: More data. + + * list.stat: Handles all that extra data. + + * weighting.stat: Doesn't try to list $WEIGHT because PC+ isn't + quite supported yet. + +Wed Sep 4 21:45:35 1996 Ben Pfaff + + * weighting.stat: Tests for proper ligatures. Won't work until + encodings are correct, of course... + +---------------------------------------------------------------------- +Local Variables: +mode: change-log +version-control: never +End: diff --git a/tests/Makefile.am b/tests/Makefile.am new file mode 100644 index 00000000..1109a24f --- /dev/null +++ b/tests/Makefile.am @@ -0,0 +1,29 @@ +## Process this file with automake to produce Makefile.in -*- makefile -*- + +bench: + make BENCHMARK=1 check + +TESTS = syntax + +noinst_PROGRAMS = gengarbage + +noinst_DATA = sort.data +sort.data: gengarbage + ./gengarbage | head -1000 > $@ + +EXTRA_DIST = aggregate.stat autorecod.stat beg-data.stat bignum.data \ +bignum.stat compute.stat count.stat crosstabs.stat data-fmts.stat \ +data-list.data data-list.stat descript.stat do-if.stat do-repeat.stat \ +expr.stat file-lab.stat filter.stat flip.stat gengarbage.c \ +inpt-pgm.stat lag.stat list.data list.stat loop.stat mtch-file.stat \ +means.stat mdfy-vars.stat print.stat pcs-if.stat recode.stat \ +repeating.stat reread.data reread.stat sample.stat sort.stat \ +splt-file.stat sys-info.stat t-test.stat tabs.stat temporary.stat \ +time-date.stat vector.stat weighting.data weighting.stat syntax + +dist-hook: + cp -rp $(srcdir)/expect $(distdir) + +DISTCLEANFILES = *.save sort.data pspp.* foo* msgs *.actual + +MAINTAINERCLEANFILES = Makefile.in diff --git a/tests/aggregate.stat b/tests/aggregate.stat new file mode 100644 index 00000000..3a95532c --- /dev/null +++ b/tests/aggregate.stat @@ -0,0 +1,20 @@ +title 'Test for AGGREGATE procedure'. + +data list /x y 1-2. +begin data. +13 +27 +30 +12 +26 +11 +10 +28 +29 +14 +15 +end data. +sort cases by x. +list. +aggregate outfile='aggregate.save'/missing=columnwise /document /presorted/break=x(a) /z'label for z'=sum(y)/foo=nu. +list. diff --git a/tests/autorecod.stat b/tests/autorecod.stat new file mode 100644 index 00000000..b035c336 --- /dev/null +++ b/tests/autorecod.stat @@ -0,0 +1,30 @@ +title 'Test for AUTORECODE procedure'. + +/* Tries AUTORECODE on some random but similar strings of characters. +data list /x 1-5(a) y 7. +begin data. +lasdj 1 1 3 +asdfk 0 3 <---- These are the numbers that should be produced for a 4 +asdfj 2 4 2 +asdfj 1 4 3 +asdfk 2 3 2 +asdfj 9 4 1 +lajks 9 2 1 +asdfk 0 3 These are the numbers that should be produced for b ----> 4 +asdfk 1 3 3 +end data. +list. +autorecode x y into a b/descend. + +/* This should produce the values indicated in the data above. +list. + +/* Just to make sure it works on second & subsequent executions, +/* try it again. +compute z=trunc(y/2). +autorecode z into w. + +/* This should display: +/* z 0 0 1 0 1 4 4 0 0 +/* w 1 1 2 1 2 3 3 1 1 +list z w. diff --git a/tests/beg-data.stat b/tests/beg-data.stat new file mode 100644 index 00000000..6bf5a8f5 --- /dev/null +++ b/tests/beg-data.stat @@ -0,0 +1,32 @@ +title 'Test BEGIN DATA ... END DATA'. + +remark EOF +---------------------------------------------------------------------- +First we show that we can input data with BEGIN DATA/END DATA after +a procedure. +---------------------------------------------------------------------- +EOF +data list /A B 1-2. +list. +begin data. +12 +34 +56 +78 +90 +end data. + +remark EOF +---------------------------------------------------------------------- +Next we show that BEGIN DATA/END DATA work fine on their own as well. +---------------------------------------------------------------------- +EOF +data list /A B 1-2. +begin data. +09 +87 +65 +43 +21 +end data. +list. diff --git a/tests/bignum.data b/tests/bignum.data new file mode 100644 index 00000000..1a1421f7 --- /dev/null +++ b/tests/bignum.data @@ -0,0 +1,62 @@ +0 +0.1 +0.5 +0.8 +0.9 +0.999 +1 +2 +3 +4 +5 +12 +123 +1234 +12345 +123456 +1234567 +12345678 +123456789 +1234567890 +19999999999 +199999999999 +1234567890123 +19999999999999 +199999999999999 +1234567890123456 +19999999999999999 +123456789012345678 +1999999999999999999 +12345678901234567890 +199999999999999999999 +1234567890123456789012 +19999999999999999999999 +123456789012345678901234 +1999999999999999999999999 +12345678901234567890123456 +199999999999999999999999999 +1234567890123456789012345678 +19999999999999999999999999999 +123456789012345678901234567890 +1999999999999999999999999999999 +12345678901234567890123456789012 +199999999999999999999999999999999 +1234567890123456789012345678901234 +19999999999999999999999999999999999 +123456789012345678901234567890123456 +1999999999999999999999999999999999999 +12345678901234567890123456789012345678 +199999999999999999999999999999999999999 +1234567890123456789012345678901234567890 +1999999999999999999999999999999999999999 +1e40 +1.1e40 +1.5e40 +1e41 +1e50 +1e100 +1e150 +1e200 +1e250 +1e300 +1.79641e308 diff --git a/tests/bignum.stat b/tests/bignum.stat new file mode 100644 index 00000000..df5cae31 --- /dev/null +++ b/tests/bignum.stat @@ -0,0 +1,28 @@ +title 'Test use of big numbers'. + +*** Do the portable output. +remark EOF +---------------------------------------------------------------------- +Testing use of big numbers.\n +The numbers in the data file are designed for IEEE754 double +format--if your system uses something different then the test needs to +be adjusted for whatever are big numbers to your system. +---------------------------------------------------------------------- +EOF +data list file='bignum.data'/BIGNUM 1-40. +list. + +*** Do the nonportable output for fun. +remark EOF +NOCOMP +SUCCESS? +---------------------------------------------------------------------- +This test merely shows whether your system can successfully handle +floating-point overflow. If you get a fatal exception at this point, +the source needs some editing--glob.c should mask overflow exceptions +in init_glob(). Again, the numbers are specific to IEEE754 double +format. +---------------------------------------------------------------------- +EOF +descriptives BIGNUM. +rem-SUCCESS diff --git a/tests/compute.stat b/tests/compute.stat new file mode 100644 index 00000000..55387244 --- /dev/null +++ b/tests/compute.stat @@ -0,0 +1,22 @@ +title 'Test COMPUTE expressions'. + +data list /w 1-3(a). +begin data. +123 +456 +919 +572 +end data. +*string y z(a6). +*compute y=ltrim(lpad(w,6,'*'),'*'). +*compute z=rtrim(rpad(w,6,'*'),'*'). +string z(a6). +compute x=number(w). +compute y=number(w,f8). +compute z=lpad(rpad(substr(string(x,f6),4,1),3,'@'),6,'*'). +compute y=y+1e-10. +if(x<=456) y=500. +select if x<=456. +compute #caseseq=#caseseq+1. +list. +list. diff --git a/tests/count.stat b/tests/count.stat new file mode 100644 index 00000000..f118947b --- /dev/null +++ b/tests/count.stat @@ -0,0 +1,15 @@ +title 'Test COUNT transformation'. + +data list /v1 to v2 1-4(a). +begin data. +1234 +321 +2 13 +4121 +1104 +03 4 +0193 +end data. +*count c=v1 to v4(1). +count c=v1 to v2('2',' 4','1'). +list. diff --git a/tests/crosstabs.stat b/tests/crosstabs.stat new file mode 100644 index 00000000..e201d260 --- /dev/null +++ b/tests/crosstabs.stat @@ -0,0 +1,19 @@ +clear transformations. +input program. +loop a=1 to 1000. +compute a=trunc(uniform(5)). +compute b=trunc(uniform(5)). +compute c=trunc(uniform(5)). +compute d=trunc(uniform(5)). +compute e=trunc(uniform(5)). +compute f=trunc(uniform(5)). +end case. +end loop. +end file. +end input program. +select if not ((a=1 and e=3) or (c=2)). +print /all. +missing value all (2). +*crosstabs/missing=report/variables=a to f(0,4)/tables=a by e by f/statistics=all/pivot on. +crosstabs a by e by f/statistics=all/pivot on. +execute. diff --git a/tests/data-fmts.stat b/tests/data-fmts.stat new file mode 100644 index 00000000..87b86bb2 --- /dev/null +++ b/tests/data-fmts.stat @@ -0,0 +1,179 @@ +set echo off. +title 'Test non-binary data input formats'. + +data list /a 1-8(a) /* 1 + ahex 9-16(ahex) /* 2 + comma 17-24(comma) /* 3 + dollar 25-32(dollar) /* 4 + f 33-40(f) /* 5 + pibhex 41-48(pibhex) /* 6 + n 49-56(n) /* 7 + e 57-64(e). /* 8 +formats comma(comma8.2) dollar(dollar8.2). +print /a ahex comma dollar f pibhex n e. + +/* This set of data should produce errors: +/* +/* - First line should be error-free. +/* - Second line should have errors for F, PIBHEX, and N fields. +/* - Third line should have errors for COMMA, DOLLAR, F, and N fields. +/* - Fourth line should have errors for F and N fields. +/* +/* 2 3 4 5 6 7 8 . +begin data. +abcdefgh414243441,2,3.4,$1,2,3.4123456.6100023451234567812345678 + 4a4b4c4d1,234.56$1234.56 abcd ghjk -12345671234+56 + 4C4D4E4F1234+56 $1234+56 0 1 abcd 12345e671234e+56 + 555657581234e+561234e+56 1.2 3 000000001234e67 1234-5 +end data. + +data list /date 1-32(date) /* 1 + time 33-64(time,4). /* 2 +print /date time. + +/* This set of data should produce errors: +/* +/* 2 +begin data. +11-july-1982 12:10:55.59 +8-xii-23 55:56:75.105 +end data. + +data list /datetime 1-32(datetime,4) /* 1 + adate 33-64(adate). /* 2 +print /datetime adate. +/* 2 +begin data. +7-7-8 12:10:55.5 10/15/1582 +11-jul-1982 9:00 10/01/78 +end data. + +data list /jdate 1-32(jdate) /* 1 + dtime 33-64(dtime). /* 2 +print /jdate dtime. +/* 2 +begin data. +1582365 10 15:30:00.32 +1996001 0 8:23:59.99 +end data. + +data list /wkday 1-32(wkday) /* 1 + month 33-64(month). /* 2 +print /wkday month. +/* 2 +begin data. +mon xii +Saturday 12 +thursday march + ixiii +end data. + +data list /moyr 1-32(moyr) /* 1 + qyr 33-64(qyr). /* 2 +print /moyr qyr. +/* 2 +begin data. +jan 96 4 q 1986 +mar 1896 1q1600 +end data. + +data list /wkyr 1-32(wkyr) /* 1 + pct 33-64(pct). /* 2 +print /wkyr pct. +/* 2 +begin data. +4 wk 97 105% +52 wk 1996 55.5% +end data. + +data list /dot 1-32(dot) /* 1 + edate 33-64(edate). /* 2 +formats dot(dot32.3). +print /dot edate. +/* 2 +begin data. +123.456.789,348 1.10.1978 + 30.12.1996 +end data. + +formats dot (comma32.3). +set decimal comma. +print /dot. +execute. + +set decimal dot. +print /dot. +execute. + +data list /sdate 1-32(sdate). /* 1 +print /sdate. +begin data. +1923/7/3 +1992.5.2 +end data. + +data list /date 1-32. +compute date = date * 86400. +print /date (date32). +begin data. +1 +50000 +102 +1157 +14288 +87365 +109623 +153211 +152371 +144623 +end data. + +data list /date 1-32(date). +compute jdate = date / 86400. +print /jdate. +begin data. +15-OCT-1582 +06-SEP-1719 +24-JAN-1583 +14-DEC-1585 +26-NOV-1621 +25-DEC-1821 +03-DEC-1882 +06-APR-2002 +18-DEC-1999 +01-OCT-1978 +end data. + +set cca 'NPX,PFX,SFX,NSX'. +set ccb 'NPX.PFX.SFX.NSX'. +set ccc '-,$,,'. +set ccd '(.SFR..)'. +set cce 'asld,adl,lfj,lfs'. + +data list /cc 1-32(f). +print /'cca: ' cc (cca32.2). +print /'ccb: ' cc (ccb32.2). +print /'ccc: ' cc (ccc32.2). +print /'ccd: ' cc (ccd32.2). +print /'cce: ' cc (cce32.2). +begin data. +78.19 +-78.19 +123456789.12 +1e23 +end data. + +print /'cca: ' cc (cca16.2). +print /'ccb: ' cc (ccb16.2). +print /'ccc: ' cc (ccc16.2). +print /'ccd: ' cc (ccd16.2). +print /'cce: ' cc (cce16.2). +execute. + +print /'cca: ' cc (cca8.2). +print /'ccb: ' cc (ccb8.2). +print /'ccc: ' cc (ccc8.2). +print /'ccd: ' cc (ccd8.2). +print /'cce: ' cc (cce8.2). +execute. + diff --git a/tests/data-list.data b/tests/data-list.data new file mode 100644 index 00000000..71ea15d5 --- /dev/null +++ b/tests/data-list.data @@ -0,0 +1,6 @@ +SHORT 2 3 4 +RIGHTLEN 6 +7 +8 TOOLONGLEN +10 11 +12 diff --git a/tests/data-list.stat b/tests/data-list.stat new file mode 100644 index 00000000..5df73cbf --- /dev/null +++ b/tests/data-list.stat @@ -0,0 +1,24 @@ +title 'Test DATA LIST FREE and DATA LIST LIST'. + +remark EOF +---------------------------------------------------------------------- +There is no test for DATA LIST FIXED since it is imagined that the +rest of the tests give it a pretty good workout. +---------------------------------------------------------------------- +EOF +remark EOF +---------------------------------------------------------------------- +Testing use of DATA LIST FREE. +---------------------------------------------------------------------- +EOF +data list free table file='data-list.data'/A(A8) B C D. +list. + +remark EOF +---------------------------------------------------------------------- +Testing use of DATA LIST LIST. +---------------------------------------------------------------------- +EOF +data list list table file='data-list.data'/A(A8) B C D. +list. + diff --git a/tests/descript.stat b/tests/descript.stat new file mode 100644 index 00000000..334ea2b4 --- /dev/null +++ b/tests/descript.stat @@ -0,0 +1,17 @@ +title 'Test DESCRIPTIVES procedure'. + +data list / v0 to v16 1-17. +begin data. +12128989012389023 +34128080123890128 +56127781237893217 +78127378123793112 +90913781237892318 +37978547878935789 +52878237892378279 +12377912789378932 +26787654347894348 +29137178947891888 +end data. + +descript all/stat=all/format=serial. diff --git a/tests/do-if.stat b/tests/do-if.stat new file mode 100644 index 00000000..8f1816e5 --- /dev/null +++ b/tests/do-if.stat @@ -0,0 +1,24 @@ +title 'Test DO IF control structure'. + +data list /x y z 1-6. +begin data. +000099 +019900 +019820 +001089 +020000 +end data. +do if x~=2. +loop i=1 to x. +do if x=0. +print /i x z. +else. +do if x=1. +print /i x y. +else. +print /i 'Huh?'. +end if. +end if. +end loop. +end if. +execute. diff --git a/tests/do-repeat.stat b/tests/do-repeat.stat new file mode 100644 index 00000000..c26951f5 --- /dev/null +++ b/tests/do-repeat.stat @@ -0,0 +1,17 @@ +title 'Test DO REPEAT control structure'. + +set echo on. +data list file='list.data'/var00001 to var00005 1-5. +string s1 to s5(a8). +vector s=s1 to s5. +do repeat v=var1 to var5/r=region1 to region5/x=0 to 4 + /y=10 to 6/z='abcd',x'010203','alksdj'+'fklasdjfladsf','al''ksj','iouio' + /longname=var00001 to var00005. +compute v=2**x. +compute v=x. +compute r=v. +compute longname=r. +compute s(x+1)=z. +end repeat print. +list. + diff --git a/tests/expect/crosstabs.stat b/tests/expect/crosstabs.stat new file mode 100644 index 00000000..db64d4a1 --- /dev/null +++ b/tests/expect/crosstabs.stat @@ -0,0 +1,7 @@ +crosstabs.stat:1: CLEAR TRANSFORMATIONS is not allowed (1) before a command to + specify the input program, such as DATA LIST, (2) between FILE TYPE and + END FILE TYPE, (3) between INPUT PROGRAM and END INPUT PROGRAM. +crosstabs.stat:1: warning: This command not executed. +crosstabs.stat:17: CROSSTABS: Syntax error expecting end of command at + `PIVOT'. +crosstabs.stat:17: warning: This command not executed. diff --git a/tests/expect/data-fmts.stat b/tests/expect/data-fmts.stat new file mode 100644 index 00000000..531d1fe1 --- /dev/null +++ b/tests/expect/data-fmts.stat @@ -0,0 +1,21 @@ +data-fmts.stat:24: data-file error: (columns 33-40, field type F8.0) Field + does not form a valid floating-point constant: " abcd ". +data-fmts.stat:24: data-file error: (columns 41-48, field type PIBHEX8.0) + Trailing characters in field: " ghjk ". +data-fmts.stat:24: data-file error: (columns 49-56, field type N8.0) All + characters in field must be digits. Field actually contained: + "-1234567". +data-fmts.stat:25: data-file error: (columns 17-24, field type COMMA8.0) + Trailing characters in field: "1234+56 ". +data-fmts.stat:25: data-file error: (columns 25-32, field type DOLLAR8.0) + Trailing characters in field: "$1234+56". +data-fmts.stat:25: data-file error: (columns 33-40, field type F8.0) Trailing + characters in field: " 0 1 ". +data-fmts.stat:25: data-file error: (columns 49-56, field type N8.0) All + characters in field must be digits. Field actually contained: + "12345e67". +data-fmts.stat:26: data-file error: (columns 33-40, field type F8.0) Trailing + characters in field: " 1.2 3 ". +data-fmts.stat:26: data-file error: (columns 49-56, field type N8.0) All + characters in field must be digits. Field actually contained: + "1234e67 ". diff --git a/tests/expect/data-list.stat b/tests/expect/data-list.stat new file mode 100644 index 00000000..4e4a0799 --- /dev/null +++ b/tests/expect/data-list.stat @@ -0,0 +1,17 @@ +data-list.data:2: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:3: warning: LIST: Missing value(s) for all variables from B + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:4: data-file error: (columns 3-10, field type F8.0) Field does + not form a valid floating-point constant: "TOOLONGL". +data-list.data:4: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:5: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:6: warning: LIST: Missing value(s) for all variables from B + onward. These will be filled with the system-missing value or blanks, + as appropriate. diff --git a/tests/expect/expr.stat b/tests/expect/expr.stat new file mode 100644 index 00000000..1a3b1ca8 --- /dev/null +++ b/tests/expect/expr.stat @@ -0,0 +1,144 @@ +expr.stat:10: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:10: warning: This command not executed. +expr.stat:11: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:11: warning: This command not executed. +expr.stat:12: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:12: warning: This command not executed. +expr.stat:15: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:15: warning: This command not executed. +expr.stat:16: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:16: warning: This command not executed. +expr.stat:17: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:17: warning: This command not executed. +expr.stat:18: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:18: warning: This command not executed. +expr.stat:20: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:20: warning: This command not executed. +expr.stat:21: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:21: warning: This command not executed. +expr.stat:22: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:22: warning: This command not executed. +expr.stat:23: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:23: warning: This command not executed. +expr.stat:25: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:25: warning: This command not executed. +expr.stat:26: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:26: warning: This command not executed. +expr.stat:28: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:28: warning: This command not executed. +expr.stat:29: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:29: warning: This command not executed. +expr.stat:30: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:30: warning: This command not executed. +expr.stat:32: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:32: warning: This command not executed. +expr.stat:33: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:33: warning: This command not executed. +expr.stat:34: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:34: warning: This command not executed. +expr.stat:35: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:35: warning: This command not executed. +expr.stat:36: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:36: warning: This command not executed. +expr.stat:37: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:37: warning: This command not executed. +expr.stat:38: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:38: warning: This command not executed. +expr.stat:39: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:39: warning: This command not executed. +expr.stat:40: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:40: warning: This command not executed. +expr.stat:41: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:41: warning: This command not executed. +expr.stat:42: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:42: warning: This command not executed. +expr.stat:43: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:43: warning: This command not executed. +expr.stat:44: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:44: warning: This command not executed. +expr.stat:45: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:45: warning: This command not executed. +expr.stat:46: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:46: warning: This command not executed. +expr.stat:47: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:47: warning: This command not executed. +expr.stat:48: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:48: warning: This command not executed. +expr.stat:49: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:49: warning: This command not executed. +expr.stat:50: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:50: warning: This command not executed. +expr.stat:51: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:51: warning: This command not executed. +expr.stat:52: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:52: warning: This command not executed. +expr.stat:53: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:53: warning: This command not executed. +expr.stat:54: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:54: warning: This command not executed. +expr.stat:55: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:55: warning: This command not executed. +expr.stat:56: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:56: warning: This command not executed. +expr.stat:57: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:57: warning: This command not executed. +expr.stat:58: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:58: warning: This command not executed. +expr.stat:59: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:59: warning: This command not executed. +expr.stat:60: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:60: warning: This command not executed. +expr.stat:61: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:61: warning: This command not executed. +expr.stat:63: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:63: warning: This command not executed. +expr.stat:64: The identifier(s) specified do not form a valid command name: + EVAL. +expr.stat:64: warning: This command not executed. diff --git a/tests/expect/loop.stat b/tests/expect/loop.stat new file mode 100644 index 00000000..af217334 --- /dev/null +++ b/tests/expect/loop.stat @@ -0,0 +1 @@ +loop.stat:12: warning: BREAK: BREAK not enclosed in DO IF structure. diff --git a/tests/expect/mdfy-vars.stat b/tests/expect/mdfy-vars.stat new file mode 100644 index 00000000..c9a9472f --- /dev/null +++ b/tests/expect/mdfy-vars.stat @@ -0,0 +1,3 @@ +mdfy-vars.stat:22: RENAME VARIABLES: Duplicate variable name `T2' after + renaming. +mdfy-vars.stat:22: warning: This command not executed. diff --git a/tests/expect/means.stat b/tests/expect/means.stat new file mode 100644 index 00000000..03dee4e5 --- /dev/null +++ b/tests/expect/means.stat @@ -0,0 +1,2 @@ +MEANS VARIABLES=V1(1,4) V2(1,9) V3(LO,HI) + TABLES=V1 BY V2 BY V3 diff --git a/tests/expect/print.stat b/tests/expect/print.stat new file mode 100644 index 00000000..09ac7ff3 --- /dev/null +++ b/tests/expect/print.stat @@ -0,0 +1,36 @@ +data-list.data:1: data-file error: (columns 1-8, field type F8.0) Field does + not form a valid floating-point constant: "SHORT ". +data-list.data:1: warning: LIST: The expression on PRINT SPACE evaluated to - + 2147483648. It's not possible to PRINT SPACE a negative number of + lines. +data-list.data:2: data-file error: (columns 1-8, field type F8.0) Field does + not form a valid floating-point constant: "RIGHTLEN". +data-list.data:4: warning: LIST: The expression on PRINT SPACE evaluated to - + 2147483648. It's not possible to PRINT SPACE a negative number of + lines. +data-list.data:4: data-file error: (columns 3-10, field type F8.0) Field does + not form a valid floating-point constant: "TOOLONGL". +data-list.data:6: warning: LIST: The expression on PRINT SPACE evaluated to - + 2147483648. It's not possible to PRINT SPACE a negative number of + lines. +data-list.data:1: data-file error: (columns 1-8, field type F8.0) Field does + not form a valid floating-point constant: "SHORT ". +data-list.data:2: data-file error: (columns 1-8, field type F8.0) Field does + not form a valid floating-point constant: "RIGHTLEN". +data-list.data:2: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:3: warning: LIST: Missing value(s) for all variables from B + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:4: data-file error: (columns 3-10, field type F8.0) Field does + not form a valid floating-point constant: "TOOLONGL". +data-list.data:4: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:5: warning: LIST: Missing value(s) for all variables from C + onward. These will be filled with the system-missing value or blanks, + as appropriate. +data-list.data:6: warning: LIST: Missing value(s) for all variables from B + onward. These will be filled with the system-missing value or blanks, + as appropriate. diff --git a/tests/expect/t-test.stat b/tests/expect/t-test.stat new file mode 100644 index 00000000..f423900b --- /dev/null +++ b/tests/expect/t-test.stat @@ -0,0 +1,23 @@ +T-TEST + PAIRS=V1 V2 WITH V3 V4 (PAIRED) + MISSING=ANALYSIS EXCLUDE + FORMAT=LABELS +Missing value +Missing value +Missing value + Number of 2-tail + Variable pairs Corr Sig Mean SD SE of Mean +--------------------------------------------------------------- +V1 0.0000 1.1909 0.3591 + 11.0000 -0.3835 0.8779 +V3 0.0000 2.4680 0.7441 +--------------------------------------------------------------- + + + + Paired Differences | + Mean SD SE of Mean | t-value df 2-tail Sig +--------------------------------------|--------------------------- + -1.1818 3.1247 0.9421 | -1.2544 10.0000 0.2382 +95pc CI ( -3.2810, 0.9174) | + diff --git a/tests/expect/vector.stat b/tests/expect/vector.stat new file mode 100644 index 00000000..01682e27 --- /dev/null +++ b/tests/expect/vector.stat @@ -0,0 +1,2 @@ +vector.stat:24: LIST: 6 is not a valid index value for vector X. The result + will be set to the empty string. diff --git a/tests/expect/weighting.stat b/tests/expect/weighting.stat new file mode 100644 index 00000000..10f28d02 --- /dev/null +++ b/tests/expect/weighting.stat @@ -0,0 +1,2 @@ +weighting.stat:6: warning: VALUE LABELS: Truncating value label to 60 + characters. diff --git a/tests/expr.stat b/tests/expr.stat new file mode 100644 index 00000000..0b9a4dab --- /dev/null +++ b/tests/expr.stat @@ -0,0 +1,65 @@ +title 'Test optimization of constant expressions'. + +remark EOF +---------------------------------------------------------------------- +Testing ability of stat to optimize constant expressions. +stat must have been compiled with debugging enabled in order to +run these tests. +---------------------------------------------------------------------- +EOF +eval 1+2+3+(4*5). +eval (4-2+6.323)*(0/4-1)*(1-3+abs(-9.78)). +eval 3**(2**(8/2*3/4)). + +* Truth tables. +eval 0 and 0. +eval 0 and 1. +eval 1 and 0. +eval 1 and 1. + +eval 0 or 0. +eval 0 or 1. +eval 1 or 0. +eval 1 or 1. + +eval not 0. +eval not 1. + +eval (1 gt 2) and (2 gt 1). +eval (7/8+1 lt 2) or (2-1/6 lt 1). +eval not (7 ne 6). + +eval -(7/8). +eval abs(-6.5). +eval arcos(1.0). +eval arcos(sqrt(2)/2). +eval arsin(sqrt(2)/2). +eval artan(0). +eval artan(1.0). +eval cos(3.141592654/4). +eval cos(3.141592654/6). +eval exp(1). +eval exp(-1). +eval lg10(10). +eval lg10(128.910). +eval ln(2.71828182846). +eval ln(50). +eval mod10(128.910). +eval rnd(128.9). +eval rnd(-128.9). +eval rnd(128.1). +eval rnd(-128.1). +eval rnd(128). +eval rnd(-128). +eval rnd(128.5). +eval rnd(-128.5). +eval sin(2*3.141592654). +eval sin(3.141592654/6). +eval tan(0). +eval tan(3.141592654/8). +eval trunc(3.141592654). +eval trunc(-9.99). + +eval 'x'. +eval concat('x','y'). + diff --git a/tests/file-lab.stat b/tests/file-lab.stat new file mode 100644 index 00000000..741a6dd8 --- /dev/null +++ b/tests/file-lab.stat @@ -0,0 +1,53 @@ +title 'Test FILE LABEL, DOCUMENT, DROP DOCUMENTS'. + +/* Set up a dummy active file in memory. +data list /x 1 y 2. +begin data. +16 +27 +38 +49 +50 +end data. + +/* Add value labels for some further testing of value labels. +value labels x y 1 'first label' 2 'second label' 3 'third label'. +add value labels x 1 'first label mark two'. + +/* Add a file label and a few documents. +file label This is a test file label. +document First line of a document +This is the second very long line of a document in an attempt to overflow the input buffer with a really long line +Note that the last line should end with a period: . + +/* Display the documents. +display documents. +display file label. /* undocumented feature of PSPP + +/* Save the active file then get it and display the documents again. +save 'foo.save'. +get 'foo.save'. +display documents. +display file label. /* undocumented feature of PSPP + +/* There is an interesting interaction that occurs if the `execute' +/* command below. What happens is that an error message is output +/* at the next `save' command that `foo.save' is already open for +/* input. This is because the `get' hasn't been executed yet and +/* therefore PSPP would be reading from and writing to the same +/* file at once, which is obviously a Bad Thing. But `execute' +/* here clears up that potential problem. +execute. + +/* Add another (shorter) document and try again. +document There should be another document now. +display documents. + +/* Save and get. +save 'foo.save'. +get 'foo.save'. +display documents. +display file label. /* undocumented feature of PSPP + +/* Done. + diff --git a/tests/filter.stat b/tests/filter.stat new file mode 100644 index 00000000..3761e387 --- /dev/null +++ b/tests/filter.stat @@ -0,0 +1,21 @@ +title 'Test FILTER'. + +data list /x 1-2. +begin data. +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +end data. +compute filter_$ = mod(x,2). +filter by filter_$. +list. +compute filter_$ = 1 - filter_$. +list. + diff --git a/tests/flip.stat b/tests/flip.stat new file mode 100644 index 00000000..e1ee8bed --- /dev/null +++ b/tests/flip.stat @@ -0,0 +1,13 @@ +data list /n 1 (a) a b c d 2-9. +list. +begin data. +v 1 2 3 4 5 +w 6 7 8 910 +x1112131415 +y1617181920 +z2122232425 +end data. +flip newnames=n. +list. +flip. +list. diff --git a/tests/gengarbage.c b/tests/gengarbage.c new file mode 100644 index 00000000..f079e911 --- /dev/null +++ b/tests/gengarbage.c @@ -0,0 +1,41 @@ +/* gengarbage - Generates 127-character lines of random digits. + Copyright (C) 1997, 1998 Free Software Foundation, Inc. + Written by Ben Pfaff . + + This program is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This program is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA + 02111-1307, USA. */ + +#include +#include +#include + +#ifndef EXIT_SUCCESS +#define EXIT_SUCCESS 0 +#endif + +int +main (void) +{ + srand (time (0)); + for (;;) + { + int c; + + for (c = 0; c < 127; c++) + putchar ('0' + rand() % 10); + putchar ('\n'); + } + exit (EXIT_SUCCESS); +} diff --git a/tests/inpt-pgm.stat b/tests/inpt-pgm.stat new file mode 100644 index 00000000..69e934c6 --- /dev/null +++ b/tests/inpt-pgm.stat @@ -0,0 +1,26 @@ +/* +/* +/* Tests for INPUT PROGRAM. +/* +/* + +remark EOF +---------------------------------------------------------------------- +Testing use of INPUT PROGRAM. +---------------------------------------------------------------------- +EOF +input program. +data list free/A #B. +end case. +data list free/C D. +end case. +data list fixed/#E 2. +end case. +end input program. +list. + +begin data. +1 2 3 4 5 +6 7 8 9 0 +end data. + diff --git a/tests/lag.stat b/tests/lag.stat new file mode 100644 index 00000000..5b9e936a --- /dev/null +++ b/tests/lag.stat @@ -0,0 +1,16 @@ +title 'Test LAG'. + +data list /w 1. +begin data. +1 +2 +3 +4 +5 +end data. + +compute x=lag(w,1). +compute y=lag(x). +compute z=lag(w,2). +list. + diff --git a/tests/list.data b/tests/list.data new file mode 100644 index 00000000..1205b46c --- /dev/null +++ b/tests/list.data @@ -0,0 +1,25 @@ +7675324663485137890734831064091758592958428152951137532659418752338157675324663485137890734831064091758592958428152951137532658 +8886930894241775423783341867603681475586900279731022668741684555067148886930894241775423783341867603681475586900279731022668746 +4926115079091871527264278522424838562069980278342188725586260041526024926115079091871527264278522424838562069980278342188725589 +8198488920231958758793320014917736896880133221016088440640236265727008198488920231958758793320014917736896880133221016088440641 +4527778987095637298455415166506950647746645120849887640160659505391494527778987095637298455415166506950647746645120849887640166 +2399619670777327606635251150735186059118186910880465190328196246896752399619670777327606635251150735186059118186910880465190325 +1667799691266476994404743989237315394276412079760310706395103299441571667799691266476994404743989237315394276412079760310706394 +1623914684196892316847117011543627119597908599740525246164191508013201623914684196892316847117011543627119597908599740525246168 +3681393233760129489113121829599857288501099123283196628714148965084573681393233760129489113121829599857288501099123283196628710 +6418731145431082994856816505035997982096732150359754547299618487885306418731145431082994856816505035997982096732150359754547297 +2284534083749507716651086429071219765163759829793478587147234341234422284534083749507716651086429071219765163759829793478587149 +6617637452040749181349911788974757522469664838867901014182486697572956617637452040749181349911788974757522469664838867901014185 +9865713582686612007222010782682778269839299871393015436402026985409089865713582686612007222010782682778269839299871393015436406 +1163234537762200807794960252447773098443340762844734350378750440902951163234537762200807794960252447773098443340762844734350377 +9981663637563833300035426136702893989464123526087380834445132807905549981663637563833300035426136702893989464123526087380834449 +6821567746059103565005738960248842198995590602288700476282307110291686821567746059103565005738960248842198995590602288700476284 +0952774952675261545955280805340357545942400156201918638742082134243330952774952675261545955280805340357545942400156201918638748 +1641790193211861509106839217119496865877118406579619492614744114869021641790193211861509106839217119496865877118406579619492615 +3763182871580174789328837194968536876074344562932187960893275881656443763182871580174789328837194968536876074344562932187960891 +2046820753062224045535890932721137819807333757171926425442973439426792046820753062224045535890932721137819807333757171926425441 +7970620091940385928762632764618525899890186135929797170456339589318347970620091940385928762632764618525899890186135929797170458 +4841176017025105774506500896252757076690392034601283834048308843632644841176017025105774506500896252757076690392034601283834045 +6949973797990956291072158123887473582962673878519619834868801568536326949973797990956291072158123887473582962673878519619834868 +1396285996535489440816124700682933874365128786823824758133461156649721396285996535489440816124700682933874365128786823824758138 +0700489524358208358697349450036208378421878800636427151211185320194660700489524358208358697349450036208378421878800636427151218 diff --git a/tests/list.stat b/tests/list.stat new file mode 100644 index 00000000..22643348 --- /dev/null +++ b/tests/list.stat @@ -0,0 +1,25 @@ +title 'Test LIST procedure.' + +*** Single lines. +remark EOF +---------------------------------------------------------------------- +Testing use of LIST in single-line cases. +---------------------------------------------------------------------- +EOF +data list file='weighting.data'/AVAR 1-5 BVAR 6-10. +weight by BVAR. +list. +*list /cases=from 5 to 20 by 2 /format numbered. +list /format numbered weight. + +*** Multiple lines. +remark EOF +---------------------------------------------------------------------- +Testing use of LIST in multi-line cases. +---------------------------------------------------------------------- +EOF +data list file='list.data' notable /X000 to X126 1-127. +*list /cases=from 1 to 25 by 5 /format numbered. +list x000 to x030. +list /cases=from 1 to 25. + diff --git a/tests/loop.stat b/tests/loop.stat new file mode 100644 index 00000000..b1aa4c15 --- /dev/null +++ b/tests/loop.stat @@ -0,0 +1,14 @@ +title 'Test LOOP procedure'. + +data list /x 1 y 2 z 3. +begin data. +125 +256 +397 +401 +end data. +loop i=y to z by abs(z-y)/(z-y). +print /x i. +break. /* Generates warning. +end loop. +execute. diff --git a/tests/mdfy-vars.stat b/tests/mdfy-vars.stat new file mode 100644 index 00000000..d53cddb0 --- /dev/null +++ b/tests/mdfy-vars.stat @@ -0,0 +1,31 @@ +title 'Test MODIFY VARS, RENAME VARIABLES'. + +/* Note that these are not quite in alphabetic order. +data list /a b c d e f g h i j k m n o p l q r s t u v w x y z 1-26 (a). + +/* Dummy data that's not actually examined. +begin data. +ABCDEFGHIJKLMNOPQRSTUVWXYZ +NOPQRSTUVWXYZABCDEFGHIJKLM +end data. + +/* This should display z y x w s q p n m l k j i h t7 t6 t5 t4 t3 t2 t1. +modify vars /reorder=backward alpha/drop o r t u v/rename (a to g=t1 to t7). +display var. + +/* This should display z y x w s q p n m l x14 x13 x12 x11 t1 t6 t5 t4 t3 +/* t2 t7. +rename variables (t1=t7)(t7=t1)(h i j k=x11 to x14). +display var. + +/* The command below should fail with an error message. +rename variables (t1=t2)(t2=t2). + +/* This should display y x w s q p n m l x14 x13 x12 x11 t1 t6 t5 t3 t7. +modify vars /reorder=forward positional/keep y to t5 t3 x14 t7. +display var. + +/* This should display t7 x11 q s x y. */ +modify vars /reorder=backward positional/keep x s y x11 t7 q. +display var. + diff --git a/tests/means.stat b/tests/means.stat new file mode 100644 index 00000000..dbc00dfd --- /dev/null +++ b/tests/means.stat @@ -0,0 +1,14 @@ +title 'Preliminary test for MEANS procedure'. + +data list /v1 to v4 1-4. +begin data. +1234 +321 +2 13 +4121 +1104 +03 4 +0193 +end data. +means variables=v1(1,4) v2(1,9) v3(lo,hi) + /tables=v1 by v2 by v3. diff --git a/tests/mtch-file.stat b/tests/mtch-file.stat new file mode 100644 index 00000000..ba6a033a --- /dev/null +++ b/tests/mtch-file.stat @@ -0,0 +1,55 @@ +title 'Test MATCH FILES'. +data list /x a b c 1-4. +begin data. +0243 +1983 +2924 +2853 +3195 +4862 +2056 +end data. +save 'mtf-1.save'. + +data list /x d e f 1-4. +begin data. +0837 +1834 +2843 +2049 +3853 +5029 +2853 +end data. +save 'mtf-2.save'. + +data list /x g h i 1-4. +begin data. +0743 +1823 +6845 +2875 +3945 +4341 +2723 +end data. + +match files /file='mtf-1.save' /file='mtf-2.save' /table=* /by x. +list. + +data list /x g h i 1-4. +begin data. +0743 +1823 +6845 +2875 +3945 +4341 +2723 +end data. + +match files /file='mtf-1.save' /file='mtf-2.save' /file=* /by x. +list. + +match files/file='mtf-1.save' /file='mtf-2.save'/by x. +list. diff --git a/tests/pcs-if.stat b/tests/pcs-if.stat new file mode 100644 index 00000000..29ee48c4 --- /dev/null +++ b/tests/pcs-if.stat @@ -0,0 +1,21 @@ +title 'Test PROCESS IF utility'. + +data list /x 1-2. +begin data. +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +end data. +process if mod(x,2) ~= 0. +list. +compute x = x*3. +process if mod(x,2) = 0. +list. + diff --git a/tests/print.stat b/tests/print.stat new file mode 100644 index 00000000..36520961 --- /dev/null +++ b/tests/print.stat @@ -0,0 +1,28 @@ +title 'Test PRINT transformation'. + +remark EOF +---------------------------------------------------------------------- +There is no test for DATA LIST FIXED since it is imagined that the +rest of the tests give it a pretty good workout. +---------------------------------------------------------------------- +EOF +remark EOF +---------------------------------------------------------------------- +Testing use of DATA LIST FREE. +---------------------------------------------------------------------- +EOF +data list free table file='data-list.data'/A B C D. +print outfile="foo" table/A(f8.2) '/' B(e8.2) '/' C(n10) '/' D(rbhex16) '/'. +print space a. +print outfile="foo" /a b c d. +list. + +remark EOF +---------------------------------------------------------------------- +Testing use of DATA LIST LIST. +---------------------------------------------------------------------- +EOF +data list list table file='data-list.data'/A B C D. +print table/A B C D. +list. + diff --git a/tests/recode.stat b/tests/recode.stat new file mode 100644 index 00000000..07a64f32 --- /dev/null +++ b/tests/recode.stat @@ -0,0 +1,21 @@ +title 'Test RECODE transformation'. + +data list /A B 1-20(a). +begin data. +12345678901234567890 +a b +jkl; aklsdf +aklsd ioqeur + ioquer pasdflk +end data. +*recode A B(1,2,3,4=5)(5 thru hi=9)(lo thru 10=4) into A D + /A B(lo thru hi=copy)(sysmis=0)(else=sysmis) into C D. +string c d(a10). +leave c d. +recode A B('a'='b')('jkl;'='jkl;p')('ioqeur'='sdjfkla') into C D. +*recode A B(1,2,3,4="asdf")(else="xyzw")(sysmis="bdfg") into C D. +*recode A B("asdf"=copy)(convert)("lkjf"=sysmis)(convert)(else=123) into C D. +*recode A B(1,3,5,6,7=COPY)(SYSMIS=5e5) into C D. +*recode a (convert)('xx'=50) into b. +list. + diff --git a/tests/repeating.stat b/tests/repeating.stat new file mode 100644 index 00000000..fdfd330c --- /dev/null +++ b/tests/repeating.stat @@ -0,0 +1,16 @@ +title 'Test REPEATING DATA utility'. + +input program. +data list /x 1 n 3. +repeating data starts=11-20 /continues=2-11 /length=10 /occurs=n + /id=1=x /data=name 1-5 (a) number 6-10. +end input program. + +begin data. +1 3 foo 1 +1bar 2 +1baz 3 +end data. + +list. + diff --git a/tests/reread.data b/tests/reread.data new file mode 100644 index 00000000..caa7a044 --- /dev/null +++ b/tests/reread.data @@ -0,0 +1,5 @@ +5510ACME 5 + 5MISC 8901 +8974ACME 9 +1928ACME 4 + 6MISC 8973 diff --git a/tests/reread.stat b/tests/reread.stat new file mode 100644 index 00000000..694e61d4 --- /dev/null +++ b/tests/reread.stat @@ -0,0 +1,16 @@ +title 'Test REREAD transformation'. + +file handle INPUT /name='reread.data'. + +input program. + data list file=INPUT/BRAND 5-10(a). + do if(BRAND='ACME'). + reread. + data list /PART 1-4 COUNT 11-15. + else if(BRAND='MISC'). + reread. + data list /PART 11-15 COUNT 1-4. + end if. + end case. +end input program. +list. diff --git a/tests/sample.stat b/tests/sample.stat new file mode 100644 index 00000000..9a2c0071 --- /dev/null +++ b/tests/sample.stat @@ -0,0 +1,19 @@ +title 'Test SAMPLE utility'. + +set seed=random. +data list /a 1-2. +begin data. +1 +2 +3 +4 +5 +6 +7 +8 +9 +10 +end data. +sample .5. +n 5. +list. diff --git a/tests/sort.stat b/tests/sort.stat new file mode 100644 index 00000000..ff85e436 --- /dev/null +++ b/tests/sort.stat @@ -0,0 +1,8 @@ +title 'Test SORT procedure'. + +data list file='sort.data' notable /X000 to X126 1-127(a). +*data list file='sort.data' notable /X000 to X005 1-6(a). +sort by X000 to x005. +print /X000 to X005. +execute. + diff --git a/tests/splt-file.stat b/tests/splt-file.stat new file mode 100644 index 00000000..422d3810 --- /dev/null +++ b/tests/splt-file.stat @@ -0,0 +1,23 @@ +title 'Test SPLIT FILE utility'. + +data list /x 1 y 2. +begin data. +12 +16 +17 +19 +15 +14 +27 +20 +26 +25 +28 +29 +24 +end data. +split file by x. +formats x(e20.2). +value labels x 1 'This is the value label for value 1.' + 2 'This is the value label for value 2.'. +descriptives y. diff --git a/tests/syntax b/tests/syntax new file mode 100755 index 00000000..3f2ced76 --- /dev/null +++ b/tests/syntax @@ -0,0 +1,51 @@ +#! /bin/sh +set -e +RESULT=pass + +srcdir=${srcdir:-.} +for x in `cd $srcdir; echo *.stat *.data`; do + if [ ! -e $x ]; then + ln -s $srcdir/$x . + fi +done + +rm -f *.actual +if [ -z "$BENCHMARK" ]; then + for x in *.stat; do + echo -n "$x ... " + ../src/pspp --testing-mode $x >$x.actual + if [ -f $srcdir/expect/$x ]; then + if diff -u $srcdir/expect/$x $x.actual; then + echo "pass"; rm $x.actual + else + echo "FAIL"; RESULT=fail + fi + else + if [ -s $x.actual ]; then + echo "FAIL"; RESULT=fail + else + echo "pass"; rm $x.actual + fi + fi + done +else + mkdir benchmark || true + rm -f benchmark/* + for x in *.stat; do + echo -n "$x ... " + ../src/pspp --testing-mode $x > benchmark/$x + if [ ! -s benchmark/$x ]; then + rm benchmark/$x + fi + echo + done +fi + +for x in *.stat *.data; do + if [ -h $x ]; then + rm $x + fi +done + +if [ $RESULT = fail ]; then exit 1; fi + diff --git a/tests/sys-info.stat b/tests/sys-info.stat new file mode 100644 index 00000000..070e0d5e --- /dev/null +++ b/tests/sys-info.stat @@ -0,0 +1,13 @@ +title 'Test SYSFILE INFO, DISPLAY utilities'. + +/* Run file-label.stat before running this syntax file, as it +/* creates foo.save. +sysfile info file='foo.save'. + +get 'foo.save'. +display names. +display index. +display labels. +display variables. +display dictionary. + diff --git a/tests/t-test.stat b/tests/t-test.stat new file mode 100644 index 00000000..3395a500 --- /dev/null +++ b/tests/t-test.stat @@ -0,0 +1,13 @@ +title 'Preliminary test for T-TEST procedure'. + +data list /v1 to v4 1-4. +begin data. +1234 +321 +2 13 +4121 +1104 +03 4 +0193 +end data. +t-test v1 v2 with v3 v4 (paired). diff --git a/tests/tabs.stat b/tests/tabs.stat new file mode 100644 index 00000000..fbeede6b --- /dev/null +++ b/tests/tabs.stat @@ -0,0 +1,12 @@ +title 'Test handling of tab characters in user data'. + +/* The program contains separate code for the case of a single +/* tab on a line and multiple tabs, so we try both below. +data list /x 1-80 (a). +begin data. + 1 12 123 1234 12345 123456 1234567 12345678 +asdf jkl; +end data. +print /x. +execute. + diff --git a/tests/temporary.stat b/tests/temporary.stat new file mode 100644 index 00000000..08645a35 --- /dev/null +++ b/tests/temporary.stat @@ -0,0 +1,29 @@ +title 'Test TEMPORARY transformation'. + +set echo on/screen on. +data list /z 1 x 2. +formats x(f3). +split file by z. +list. +begin data. +12 +13 +14 +15 +16 +23 +24 +25 +26 +27 +28 +end data. +compute x=x+1. +temporary. +compute x=x+1. +compute y=x+1. +sel if y<7. +descriptives x y. +list. +compute x=x-10. +list. diff --git a/tests/time-date.stat b/tests/time-date.stat new file mode 100644 index 00000000..f9a9c736 --- /dev/null +++ b/tests/time-date.stat @@ -0,0 +1,77 @@ +title 'Test time and date input and output formats'. + +data list fixed + /a(date20)/b(adate20)/c(jdate20)/d(qyr20)/e(moyr20)/f(wkyr20)/g(wkday20) + /h(month20)/i(time20.2)/j(dtime20.2)/k(datetime24.2). +begin data. +01-oct-78 +10/1/78 +78101 +3q96 +nov 52 +38wk23 +saturday +xi +10:01 +4 5:12.9 +01-feb-1903 04:05:06.07 +end data. +print /a to e. +print /f to k. +execute. + +data list /x 1. +begin data. +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +1 +end data. +compute y=$time. +formats y(datetime25). +list. +compute z=$time. +formats z(datetime25). +list. +compute p=$time. +formats p(datetime25). +list. + diff --git a/tests/vector.stat b/tests/vector.stat new file mode 100644 index 00000000..8f702261 --- /dev/null +++ b/tests/vector.stat @@ -0,0 +1,24 @@ +title 'Test VECTOR utility'. + +data list /c 1(a). +begin data. +5 +3 +4 +1 +2 +end data. + +string x1 to x5 y1 to y5(a1). +vector x=x1 to x5. +*formats all(f1). +compute x(number(c))=c. +leave x1 to x5. +list. + +vector x=x1 to x5. +vector y=y1 to y5. +*formats all(f1). +compute y(number(c))=x(number(c)+1). +display vector. +list. diff --git a/tests/weighting.data b/tests/weighting.data new file mode 100644 index 00000000..bf74fa04 --- /dev/null +++ b/tests/weighting.data @@ -0,0 +1,52 @@ + 18 1 + 19 7 + 20 26 + 21 76 + 22 57 + 23 58 + 24 38 + 25 38 + 26 30 + 27 21 + 28 23 + 29 24 + 30 23 + 31 14 + 32 21 + 33 21 + 34 14 + 35 14 + 36 17 + 37 11 + 38 16 + 39 14 + 40 15 + 41 14 + 42 14 + 43 8 + 44 15 + 45 10 + 46 12 + 47 13 + 48 13 + 49 5 + 50 5 + 51 3 + 52 7 + 53 6 + 54 2 + 55 2 + 56 2 + 57 3 + 58 1 + 59 3 + 61 1 + 62 3 + 63 1 + 64 1 + 65 2 + 70 1 + 78 1 + 79 1 + 80 1 + 94 1 \ No newline at end of file diff --git a/tests/weighting.stat b/tests/weighting.stat new file mode 100644 index 00000000..2611e74e --- /dev/null +++ b/tests/weighting.stat @@ -0,0 +1,8 @@ +title 'Test WEIGHT'. + +data list file='weighting.data'/AVAR 1-5 BVAR 6-10. +weight by BVAR. +value labels avar 18 'This is a value label that is really long so it takes up lots of room.' + 19 'flustered and flim-flammed by fields'. +descriptives AVAR /statistics all /format serial. +frequencies AVAR /statistics all /format condensed.