Mercurial > hg > xemacs-beta
changeset 5178:97eb4942aec8
merge
line wrap: on
line diff
--- a/.hgtags Tue Feb 23 07:28:35 2010 -0600 +++ b/.hgtags Mon Mar 29 21:28:13 2010 -0500 @@ -235,5 +235,7 @@ 223736d75acb5265cfd9352497e8483d787d8eab r21-2-45 0784d089fdc93fb58040b6efbec55cd4fdf650c2 r21-2-46 5aa1854ad5374fa936e99e22e7b1242097292f16 r21-2-47 +aaf96f4ba61234a5331b280b774d357503cd7994 ben-lisp-object-bp 1af222c7586991f690ea06d1b8c75fb5a6a0a352 r21-5-28 5c427ece884b7023a244fba8cad8cf41b37dd5ca r21-5-29 +3742ea8250b5fd339d6d797835faf8761f61d0ae ben-lisp-object-final-ws-year-2005
--- a/CHANGES-beta Tue Feb 23 07:28:35 2010 -0600 +++ b/CHANGES-beta Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,133 @@ +to XEmacs 21.5.30 "harblegarble" + +by Ben Wing: + +debugging: + +-- make objects consistently print a UID, with a separate number space per + object type +-- add variable `debug-soe' for debugging stack-of-extents code in extents.c +-- correctly note pdumped objects in memory-usage stats returned by + `garbage-collect' and `object-memory-usage-stats'. +-- make VDB debugging functions (e.g. `test-segfault', which causes an + immediate crash!) conditional on `--with-debug' +-- rename `debug-xemacs-searches' -> `debug-searches' +-- Turn on "compiled-function annotation hack" so that compiled-function + objects print the function they are assigned to +-- Resurrect byte-metering code when --with-debug; enable with variables + `byte-code-meter', `byte-metering-on' +-- Add more checks for invalid byte code; when a byte-code-related crash + occurs, output the last 100 instructions processed + +documentation: + +-- fix to `previous/next-single[-char]-property-change' + +Lisp API: + +-- `set-frame-displayable-pixel-height' and friends had bugs in them, esp. + on MS Windows, where they didn't work; fixed +-- `frame-pixel-height', `set-frame-pixel-height' and friends will now + use updated values for frame size (as of next redisplay) when the frame + was previously resized but a redisplay has not yet happened +-- When `set-case-table' called with a length-256 vector, don't overwrite + existing case table; instead, populate a new table +-- Fix internal case comparisons to use the "canonical case mapping" so that + they always work even in the presence of complex case mappings (other + than just upper -> lower and lower -> upper) +-- In `scan-lists' and friends, when an error occurs, return a `scan-error' + along with two arguments specifying the range in which the error occurred, + for GNU compatibility + +Internals: + +-- reduce lcrecord header size from 3 words to 2 +-- major change to the way Lisp objects are defined and declared; introduce + a cleaner surface-layer API that eliminates references to "lrecords" and + "lcrecords", and uses "frob-block object" in place of "basic object"/ + "simple object"/etc. +-- new disksave method for Lisp objects, separated out from the finalize method +-- Lisp objects now must specify a print method; use either + internal_object_printer() or external_object_printer() as a default +-- equal method for Lisp objects has new `foldcase' param, to implement + case-folding comparison ala `equalp' +-- various changes to frame-geometry macros in frame-impl.h, gutter.h, etc., + and frame-sizing code in frame.c +-- Major rewrite, updated documentation to dynarr functions and macros +-- Major updates to internals manual and long comments in C files: + frame geometry, specifier authors, MS-Windows compilation flags, xlike + mechanism, ... +-- Rename LISP_TO_VOID -> STORE_LISP_IN_VOID, + VOID_TO_LISP -> GET_LISP_FROM_VOID; add STORE_VOID_IN_LISP, + GET_VOID_FROM_LISP +-- Convert various source files to UTF-8 +-- File renames: + select-common.h -> select-xlike-inc.c + xgccache.{ch} -> gccache-x.{ch} + toolbar-common.{ch} -> toolbar-xlike.{ch} +-- New files: + bytecode-ops.h + sysgtk.h, sysgdkx.h + keymap-buttons.h, keymap-slots.h +-- Deleted files: + event-gtk.h +-- Major reworking of DFC macros e.g. EXTERNAL_TO_C_STRING renamed to + EXTERNAL_TO_ITEXT; make them return their values when possible rather + than storing into a named variable +-- Eliminate unused second argument to xfree() +-- separate HAVE_XFT into HAVE_XFT and USE_XFT, to facilitate compiling + simultaneously with X and GTK +-- Move `equalp' to C + +Testing: + +-- Move test-harness.el to Lisp directory + +Building: + +-- Fix `--quick-build' so full rebuilds don't happen when changes are made + to files like lisp.h, config.h that are included by all C files +-- Fix C++ build on Cygwin when configured with --have-database + +User-Visible Bug Fixes: + +-- `escape-quoted' was failing to add escape quoting to Control-1 characters; + many potential byte-code-related crashes may have resulted from the old + behavior +-- Fix a redisplay bug where args to default_face_height_and_width() were + in wrong order +-- "speedy insert" code (to make `revert-buffer' preserve extents, markers, + etc. in unmodified sections of a reverted file) was broken with binary + files +-- File-locking code now names lock files .#FN# instead of .#FN, to avoid + problems with programs that e.g. try to process all .c or .h files +-- Fix a crash in frame creation due to lack of call to reset_glyph_cachels() +-- Fix long-standing bug: searching for Control-1 chars didn't work +-- Turn on `load-ignore-out-of-date-elc-files' by default + + + +by Didier Verna: + +Lisp API: + +-- new `background-placement' property of faces; with a value of `absolute', + the background pixmap is drawn relative to the root window, allowing + seamless integration with the desktop background + +by Jerry James: + +Lisp API: + +-- signal an error instead of crashing when encountering a ratio like 1/0 + +Internals: + +-- locate and add copyright notices to various files in preparation for + move to GPL v3 + + + to XEmacs 21.5.29 "garbanzo" Major Features and Backward Incompatible Changes
--- a/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,17 @@ +2010-03-18 Ben Wing <ben@xemacs.org> + + * CHANGES-beta: + Partially updated with last couple of months worth of changes. + +2010-03-18 Mike Sperber <mike@xemacs.org> + + * INSTALL: Reflect change from `lib' to `share'; also, document + how to invoke configure to get the old setting. + + * configure.ac: Set LATE_PACKAGE_DIRECTORIES_USER_DEFINED if + `datadir' was changed; set `with_late_packages' to something + sensible for this case. + 2010-02-20 Ben Wing <ben@xemacs.org> * configure.ac (XE_COMPLEX_ARG):
--- a/INSTALL Tue Feb 23 07:28:35 2010 -0600 +++ b/INSTALL Mon Mar 29 21:28:13 2010 -0500 @@ -257,7 +257,7 @@ should put XEmacs and its data files. This defaults to `/usr/local'. - XEmacs (and the other utilities users run) go in PREFIXDIR/bin (unless the `--exec-prefix' option says otherwise). -- The architecture-independent files go in PREFIXDIR/lib/xemacs-VERSION +- The architecture-independent files go in PREFIXDIR/share/xemacs-VERSION (where VERSION is the version number of XEmacs, like `21.0'). - The architecture-dependent files go in PREFIXDIR/lib/xemacs-VERSION/CONFIGURATION-NAME @@ -284,6 +284,12 @@ part of the generated executable; everything else will continue to work as usual. +Unlike previous versions of XEmacs (21.4 or earlier), +architecture-independent files (in particular, the Lisp files and +package hierarchies) by default get installed under `/usr/local/share' +rather than `/usr/local/lib'. To create a setup as in previous +versions, use the `--datadir=/usr/local/lib' option to configure. + Configuring Feature Support --------------------------- @@ -567,7 +573,7 @@ `xemacs', `etags', `ctags', `b2m', `emacsclient', `ellcc', `gnuclient', `gnudoit', and `gnuattach'. -`/usr/local/lib/xemacs-VERSION/lisp' holds the Emacs Lisp libraries; +`/usr/local/share/xemacs-VERSION/lisp' holds the Emacs Lisp libraries; `VERSION' stands for the number of the XEmacs version you are installing, like `18.59' or `19.14'. Since the lisp libraries change from one version of XEmacs to @@ -578,14 +584,14 @@ XEmacs searches for its lisp files in these directories, and then in - `/usr/local/lib/xemacs/site-lisp/*'. + `/usr/local/share/xemacs/site-lisp/*'. -`/usr/local/lib/xemacs-VERSION/etc' holds the XEmacs tutorial, the +`/usr/local/share/xemacs-VERSION/etc' holds the XEmacs tutorial, the Unicode database, and other architecture-independent files XEmacs might need while running. VERSION is as specified for `.../lisp'. -`/usr/local/lib/xemacs/lock' contains files indicating who is +`/usr/local/share/xemacs/lock' contains files indicating who is editing what, so XEmacs can detect editing clashes between users. @@ -614,7 +620,7 @@ sub-directory of it, and then in `/usr/local/lib/xemacs/site-modules/*'. -`/usr/local/lib/xemacs-VERSION/info' holds the on-line documentation +`/usr/local/share/xemacs-VERSION/info' holds the on-line documentation for XEmacs, known as "info files". `/usr/local/man/man1' holds the man pages for the programs installed @@ -642,7 +648,7 @@ `datadir' indicates where to put the architecture-independent read-only data files that XEmacs refers to while it runs; it - defaults to /usr/local/lib. We create the following + defaults to /usr/local/data. We create the following subdirectories under `datadir': - `xemacs-VERSION/lisp', containing the XEmacs lisp libraries, and @@ -655,6 +661,13 @@ same time; this means that you don't have to make XEmacs unavailable while installing a new version. +`datarootdir' indicates where to put the documentation. (Usually, + this is identical to `datadir'---in the default configuration + `datadir' is set to the value of `datarootdir'.) + Specifically, the man pages are put in the `man' subdirectory + of `datarootdir', and the info pages are put in the + `xemacs/info' subdirectory. + `statedir' indicates where to put architecture-independent data files that XEmacs modifies while it runs; it defaults to /usr/local/lib as well. We create the following @@ -680,7 +693,7 @@ XEmacs is installed on. `infodir' indicates where to put the info files distributed with - XEmacs; it defaults to `/usr/local/lib/xemacs-VERSION/info'. + XEmacs; it defaults to `/usr/local/share/xemacs-VERSION/info'. `mandir' indicates where to put the man pages for XEmacs and its utilities (like `etags'); it defaults to @@ -710,23 +723,23 @@ `lispdir' indicates where XEmacs installs and expects its lisp libraries. Its default value, based on `datadir' (see above), - is `/usr/local/lib/xemacs-VERSION/lisp' (where `VERSION' is as + is `/usr/local/share/xemacs-VERSION/lisp' (where `VERSION' is as described above). `sitelispdir' indicates where XEmacs should search for lisp libraries specific to your site. XEmacs checks them in order before checking `lispdir'. Its default value, based on `datadir' - (see above), is `/usr/local/lib/xemacs/site-lisp'. + (see above), is `/usr/local/share/xemacs/site-lisp'. `etcdir' indicates where XEmacs should install and expect the rest of its architecture-independent data, like the tutorial and yow database. Its default value, based on `datadir' - (see above), is `/usr/local/lib/xemacs-VERSION/etc' (where + (see above), is `/usr/local/share/xemacs-VERSION/etc' (where `VERSION' is as described above). `lockdir' indicates the directory where XEmacs keeps track of its locking information. Its default value, based on `statedir' - (see above), is `/usr/local/lib/xemacs/lock'. + (see above), is `/usr/local/share/xemacs/lock'. `archlibdir' indicates where XEmacs installs and expects the executable files and other architecture-dependent data it uses
--- a/configure Tue Feb 23 07:28:35 2010 -0600 +++ b/configure Mon Mar 29 21:28:13 2010 -0500 @@ -1995,13 +1995,14 @@ --with-quick-build Speed up the build cycle by leaving out steps where XEmacs will still work (more or less) without them. Potentially dangerous if you don't know what you're - doing. This (1) doesn't garbage-collect after - loading each file during dumping, (2) doesn't + doing. This (1) Doesn't garbage-collect after + loading each file during dumping, (2) Doesn't automatically rebuild the DOC file (remove it by hand to get it rebuilt), (3) Removes config.h, lisp.h and associated files from the dependency lists, so changes to these files don't automatically - cause all .c files to be rebuilt. + cause all .c files to be rebuilt, (4) Doesn't check + for Lisp shadows. --with-union-type Use union definition of Lisp_Object type. Known to trigger bugs in some compilers. --with-quantify Support performance debugging using Quantify. @@ -5509,6 +5510,8 @@ $as_echo "#define ETCDIR_USER_DEFINED 1" >>confdefs.h + $as_echo "#define LATE_PACKAGE_DIRECTORIES_USER_DEFINED 1" >>confdefs.h + fi if test "x$libdir" != "x\${exec_prefix}/lib" @@ -5533,6 +5536,7 @@ inststaticdir='${PROGNAME}' instvardir='${PROGNAME}-${version}' sitemoduledir='${libdir}/${inststaticdir}/site-modules' +with_late_packages='${datadir}/${PROGNAME}' statedir=$with_statedir
--- a/configure.ac Tue Feb 23 07:28:35 2010 -0600 +++ b/configure.ac Mon Mar 29 21:28:13 2010 -0500 @@ -1108,6 +1108,7 @@ AC_DEFINE(INFODIR_USER_DEFINED) AC_DEFINE(LISPDIR_USER_DEFINED) AC_DEFINE(ETCDIR_USER_DEFINED) + AC_DEFINE(LATE_PACKAGE_DIRECTORIES_USER_DEFINED) fi if test "x$libdir" != "x\${exec_prefix}/lib" @@ -1128,6 +1129,7 @@ inststaticdir='${PROGNAME}' instvardir='${PROGNAME}-${version}' sitemoduledir='${libdir}/${inststaticdir}/site-modules' +with_late_packages='${datadir}/${PROGNAME}' AC_SUBST(inststaticdir) AC_SUBST(statedir,$with_statedir)
--- a/lib-src/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/lib-src/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,20 @@ +2010-03-02 Ben Wing <ben@xemacs.org> + + * digest-doc.c: + * make-path.c: + `emacs' isn't defined, but HAVE_CONFIG_H is, so use it to get + config.h. + + * getopt.h: + Conditionalize on HAVE_CONFIG_H to get real prototypes. + +2010-02-25 Ben Wing <ben@xemacs.org> + + * make-docfile.c: + * make-docfile.c (write_c_args): + Convert newlines to spaces so that argument lists are always on one + line, because that's what function-documentation-1 expects. + 2010-02-11 Vin Shelton <acs@xemacs.org> * winclient.c: Bump connection retries to 20 because some people
--- a/lib-src/digest-doc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/lib-src/digest-doc.c Mon Mar 29 21:28:13 2010 -0500 @@ -5,7 +5,7 @@ See also sorted-doc.c, which produces similar output but in texinfo format and sorted by function/variable name. */ -#ifdef emacs +#ifdef HAVE_CONFIG_H #include <config.h> #endif #include <stdio.h>
--- a/lib-src/getopt.h Tue Feb 23 07:28:35 2010 -0600 +++ b/lib-src/getopt.h Mon Mar 29 21:28:13 2010 -0500 @@ -98,7 +98,7 @@ #define required_argument 1 #define optional_argument 2 -#if defined (__GNU_LIBRARY__) || defined (__cplusplus) || defined (CYGWIN) +#if defined (__GNU_LIBRARY__) || defined (__cplusplus) || defined (HAVE_CONFIG_H) /* Many other libraries have conflicting prototypes for getopt, with differences in the consts, in stdlib.h. To avoid compilation errors, only prototype getopt for the GNU C library. */
--- a/lib-src/make-docfile.c Tue Feb 23 07:28:35 2010 -0600 +++ b/lib-src/make-docfile.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,7 +3,7 @@ Free Software Foundation, Inc. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1998, 1999 J. Kean Johnston. - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -651,11 +651,11 @@ } /* Print the C argument list as it would appear in lisp: - print underscores as hyphens, and print commas and newlines + print underscores as hyphens, and print commas, tabs and newlines as spaces. Collapse adjacent spaces into one. */ if (c == '_') c = '-'; - else if (c == ',' /* || c == '\n' */) + else if (c == ',' || c == '\n' || c == '\t') c = ' '; /* XEmacs change: handle \n below for readability */ @@ -682,18 +682,28 @@ in_ident = 0; just_spaced = 0; } - /* XEmacs change: if the character is carriage return or linefeed, - escape it for the compiler */ +#if 0 + /* [[ XEmacs change: if the character is carriage return or linefeed, + escape it for the compiler ]] I doubt the clause with '\r' ever + worked right, and outputting newlines now screws up the regexp + in function-documentation-1, so don't do this; instead, we treat + newlines like spaces. --ben */ else if (c == '\n') { putc('\\', out); putc('\n', out); + c = ' '; } else if (c == '\r') { putc('\\', out); putc('\r', out); } +#else + else if (c == '\r') /* Just eat it, since we expect a newline to + follow */ + ; +#endif /* (not) 0 */ else if (c != ' ' || !just_spaced) { if (c >= 'a' && c <= 'z')
--- a/lib-src/make-path.c Tue Feb 23 07:28:35 2010 -0600 +++ b/lib-src/make-path.c Mon Mar 29 21:28:13 2010 -0500 @@ -26,7 +26,7 @@ command on some of the purer BSD systems (like Mt. Xinu) don't have that option. */ -#ifdef emacs +#ifdef HAVE_CONFIG_H #include <config.h> #endif
--- a/lisp/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -46,6 +46,214 @@ put categories in alphabetical order, move remaning "misc" stuff to bottom. +2010-03-29 Aidan Kehoe <kehoea@parhasard.net> + + * hyper-apropos.el (hyper-apropos-get-doc): + Use help.el's #'function-arglist, #'function-documentation, + #'symbol-file in this function, instead of rolling our own. + +2010-03-25 Ben Wing <ben@xemacs.org> + + * diagnose.el (show-memory-usage): + * diagnose.el (show-object-memory-usage-stats): + Further changes to correspond with changes in the C code; + add an additional column in show-object-memory-usage-stats showing + the ancillary Lisp overhead used with each type; shrink columns for + windows in show-memory-usage to get it to fit in 79 chars. + +2010-03-26 Aidan Kehoe <kehoea@parhasard.net> + + * descr-text.el (describe-char-display): + Behave better on builds without database support, and for + characters where no font is available. Especially relevant on + Win32. + +2010-03-23 Aidan Kehoe <kehoea@parhasard.net> + + * x-win-xfree86.el (x-win-init-xfree86): + If iso-left-tab (something ISO-specified and portable in theory; + in practice only seen with XFree86 and derived non-US layouts) + exists on the keyboard layout, make it equivalent to shift-tab, + addressing the issue FKtPp sees in + http://mid.gmane.org/1269358206.4873.1.camel@fktpp-laptop . + +2010-03-21 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (cl-prettyprint): + Handle (function ...) specially here, as we do (quote ...). + +2010-03-20 Ben Wing <ben@xemacs.org> + + * diagnose.el (show-memory-usage): + * diagnose.el (show-object-memory-usage-stats): + Further changes to correspond with changes in the C code; + add an additional column showing the overhead used with each type, + and add it into the grand total memory usage. + +2010-03-19 Ben Wing <ben@xemacs.org> + + * diagnose.el (show-object-memory-usage-stats): + Rewrite to take into account non-lisp-storage statistics + returned by garbage-collect-1 and friends. + +2010-03-18 Ben Wing <ben@xemacs.org> + + * diagnose.el (show-memory-usage): + Rewrite to take into account API changes in memory-usage functions. + +2010-03-20 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (notany, notevery): + Correct these compiler macros. + +2010-03-15 Ben Wing <ben@xemacs.org> + + * mule/mule-cmds.el: + * mule/mule-cmds.el (finish-set-language-environment): + Fix bug in generating display-table entries for error octet characters. + +2010-03-12 Ben Wing <ben@xemacs.org> + + * test-harness.el (test-harness-from-buffer): + Undo change of e.g. (Assert (equalp ...)) to (Assert-equalp ...). + Get rid of `Assert-equalp' and friends, `Assert-test', and + `Assert-test-not'. Instead, make `Assert' smart enough to do the + equivalent functionality when an expression like (Assert (equalp ...)) + is seen. + +2010-03-11 Aidan Kehoe <kehoea@parhasard.net> + + * setup-paths.el (paths-find-emacs-roots) + (paths-construct-info-path): + Pass :from-end t to the delete-duplicates calls in these + functions, now the compiler macro no longer defaults it to t. + +2010-03-07 Ben Wing <ben@xemacs.org> + + * disp-table.el: + * disp-table.el (standard-display-g1): + * disp-table.el (standard-display-graphic): + Fix up docs; add comments about authorship. + +2010-03-06 Ben Wing <ben@xemacs.org> + + * test-harness.el: + * test-harness.el (test-harness-backtrace): New. + * test-harness.el (test-harness-assertion-failure-do-debug): + * test-harness.el (test-harness-unexpected-error-do-debug): + Use the print settings from edebug.el to make backtraces not + be so huge. + +2010-03-06 Aidan Kehoe <kehoea@parhasard.net> + + * bytecomp.el (byte-compile-compiled-obj-to-list): + Remove this function, printing a compiled object to a string and + then reading back a substring is senseless, just use the + compiled-function slot accessor functions. + +2010-03-05 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (delete-duplicates): + Correct the logic of this compiler macro when :from-end is nil, + avoiding a hang in query-coding-tests.el. Thanks for the reports, + Vin and Mats! + +2010-03-04 Aidan Kehoe <kehoea@parhasard.net> + + * make-docfile.el (process-args): + Use #'subseq here, not #'substring, fixing the native Windows + build. Thank you for the error report, Vin! + +2010-03-03 Aidan Kehoe <kehoea@parhasard.net> + + Move byte code #o117 to #'subseq, not #'substring. + Make #'substring available as an alias for #'subseq in Lisp. + * bytecomp.el (79, subseq, substring): + * bytecomp.el (byte-compile-subseq): New. + * update-elc.el (update-elc-chop-extension): Use #'subseq, not + #'substring, the latter is not yet available. + * subr.el (substring): New alias, to #'subseq. + +2010-03-02 Aidan Kehoe <kehoea@parhasard.net> + + * cl-macs.el (delete-dups): New compiler macro for this function, + expanding to inline byte codes. + (delete-duplicates): Handle the :from-end argument correctly in + this compiler macro. + +2010-03-01 Aidan Kehoe <kehoea@parhasard.net> + + * cl-seq.el (cl-parsing-keywords): + * cl-macs.el (cl-do-arglist): + Use the new invalid-keyword-argument error here. + +2010-02-26 Aidan Kehoe <kehoea@parhasard.net> + + Back out Ben's revision c673987f5f3d. + * coding.el: + Add a compiler macro for #'make-coding-system on non-Mule builds + too, to fix the problem he addressed with that changeset. + * mule/make-coding-system.el (fixed-width-private-use-start): + Don't call (decode-char ... 'ucs) here, it can make bootstrapping + harder. + +2010-02-26 Ben Wing <ben@xemacs.org> + + * autoload.el (autoload-featurep-protect-autoloads): + Always insert a coding-system cookie, either raw-text-unix or + escape-quoted. As before, insert an error statement when an + escape-quoted auto-autoload is loaded in a non-Mule XEmacs. + + This fixes problems when the default coding system is UTF-8, + as in Cygwin. Under some circumstances, the file can get + written out as raw text and read in as UTF-8, where invididual + high-bytes are usually invalid UTF-8 sequences and lead to + error octets in the buffer; when written out again, these + force escape-quoted. Result: auto-autoloads.el for the + source-tree lisp/ directory would end up as escape-quoted. + +2010-02-25 Didier Verna <didier@xemacs.org> + + The background-placement face property. + * cl-macs.el (face-background-placement): New defsetf. + * cus-face.el (custom-face-attributes): + * faces.el (face-interactive): + * faces.el (set-face-property): + * faces.el (face-equal): + * faces.el (init-other-random-faces): Update. + * faces.el (face-background-placement): + * faces.el (set-face-background-placement): + * faces.el (face-background-placement-instance): + * faces.el (face-background-placement-instance-p): + * frame.el (set-frame-background-placement): + * frame.el (frame-background-placement): + * frame.el (frame-background-placement-instance): + * objects.el (make-face-background-placement-specifier): New. + +2010-02-25 Ben Wing <ben@xemacs.org> + + * autoload.el (make-autoload): + Call cl-function-arglist with one arg. + + * cl-macs.el (cl-function-arglist): + * cl-macs.el (cl-transform-lambda): + Make cl-function-arglist take only one arg, the arglist; no + function name passed. Also make sure to print () instead of nil + when empty arglist, or function-documentation-1 won't recognize + the arguments: line. + * help.el (function-arglist): If empty arg, don't display extra + space after function name. + +2010-02-24 Aidan Kehoe <kehoea@parhasard.net> + + * cl-extra.el (constantly): + Normally return a compiled function from #'constantly if we are + handed a single argument. Shouldn't actually matter, the overhead + for returning a single constant in a lambda form vs. in a compiled + function is minuscule, but using compiled functions as much as + possible is good style in XEmacs, our interpreter is not stellar + (nor indeed should it need to be). + 2010-02-23 Ben Wing <ben@xemacs.org> * help.el: fux typo in comment. (oops) @@ -91,29 +299,6 @@ 2010-02-22 Ben Wing <ben@xemacs.org> - * mule/make-coding-system.el: - * mule/make-coding-system.el (fixed-width-generate-helper): - * mule/make-coding-system.el (fixed-width-private-use-start): Removed. - * mule/make-coding-system.el (fixed-width-create-decode-encode-tables): - * coding.el: - * coding.el (decode-char): New. - * coding.el (featurep): - * coding.el (encode-char): New. - * dumped-lisp.el (preloaded-file-list): - Dump make-coding-system. Aidan's hack to avoid dumping this file - never really worked right -- with some configurations (not clear - exactly which ones) `make-coding-system.el' gets dumped anyway due to - calls to `make-coding-system' in unicode.el, with the result that - the documentation of functions in make-coding-system.el gets lost. - - Also needed to remove defvar fixed-width-private-use-start and - incorporate it inline, due to bootstrapping issues -- the call to - decode-char introduced a cross-dependency between unicode.el and - make-coding-system.el. - - -2010-02-22 Ben Wing <ben@xemacs.org> - * cl-seq.el: * cl-seq.el (stable-union): New. * cl-seq.el (stable-intersection): New.
--- a/lisp/autoload.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/autoload.el Mon Mar 29 21:28:13 2010 -0500 @@ -286,11 +286,10 @@ (body (nthcdr (get car 'doc-string-elt) form)) (doc (if (stringp (car body)) (pop body)))) (if (memq car '(defmacro defmacro* defun defun*)) - (let ((arglist (nth 2 form)) - (placeholder (eval-when-compile (gensym)))) + (let ((arglist (nth 2 form))) (setq doc (concat (or doc "") "\n\narguments: " - (cl-function-arglist placeholder arglist t) + (cl-function-arglist arglist) "\n")))) ;; `define-generic-mode' quotes the name, so take care of that (list 'autoload (if (listp name) name (list 'quote name)) file doc @@ -1089,11 +1088,13 @@ ;; recognized only one of the two magic-cookie styles (the -*- kind) ;; in find-file, but both of them in load. We go ahead and put both ;; in, just to be safe. + (insert (format " -*- coding: %s -*-\n" buffer-file-coding-system)) (when (eq buffer-file-coding-system 'escape-quoted) - (insert " -*- coding: escape-quoted; -*- -\(or (featurep 'mule) (error \"Loading this file requires Mule support\")) -;;;###coding system: escape-quoted")) - (insert "\n(if (featurep '" sym ")") + (insert "(or (featurep 'mule) ") + (insert "(error \"Loading this file requires Mule support\"))\n")) + (insert (format ";;;###coding system: %s\n" + buffer-file-coding-system)) + (insert "(if (featurep '" sym ")") (insert " (error \"Feature " sym " already loaded\"))\n") (goto-char (point-max)) (save-excursion
--- a/lisp/bytecomp.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/bytecomp.el Mon Mar 29 21:28:13 2010 -0500 @@ -609,7 +609,7 @@ (byte-defop 76 -1 byte-set) (byte-defop 77 -1 byte-fset) ; this was commented out (byte-defop 78 -1 byte-get) -(byte-defop 79 -2 byte-substring) +(byte-defop 79 -2 byte-subseq) (byte-defop 80 -1 byte-concat2) (byte-defop 81 -2 byte-concat3) (byte-defop 82 -3 byte-concat4) @@ -2247,22 +2247,6 @@ (defun byte-compile-file-form-defmacro (form) (byte-compile-file-form-defmumble form t)) -(defun byte-compile-compiled-obj-to-list (obj) - ;; #### this is fairly disgusting. Rewrite the code instead - ;; so that it doesn't create compiled objects in the first place! - ;; Much better than creating them and then "uncreating" them - ;; like this. - (read (concat "(" - (substring (let ((print-readably t) - (print-gensym - (if (and byte-compile-print-gensym - (not byte-compile-emacs19-compatibility)) - '(t) nil)) - (print-gensym-alist nil)) - (prin1-to-string obj)) - 2 -1) - ")"))) - (defun byte-compile-file-form-defmumble (form macrop) (let* ((name (car (cdr form))) (this-kind (if macrop 'byte-compile-macro-environment @@ -2330,7 +2314,14 @@ (byte-compile-warn "Probable `\"' without `\\' in doc string of %s" (nth 1 form)))) (let* ((new-one (byte-compile-lambda (cons 'lambda (nthcdr 2 form)))) - (code (byte-compile-byte-code-maker new-one))) + (code (byte-compile-byte-code-maker new-one)) + (docform-info + (cond ((atom code) ; compiled-function-p + (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) + ((eq (car code) 'quote) + (setq code new-one) + (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) + ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))))) (if this-one (setcdr this-one new-one) (set this-kind @@ -2339,60 +2330,37 @@ (eq 'quote (car-safe code)) (eq 'lambda (car-safe (nth 1 code)))) (cons (car form) - (cons name (cdr (nth 1 code)))) + (cons name (cdr (nth 1 code)))) (byte-compile-flush-pending) (if (not (stringp (nth 3 form))) - ;; No doc string. Provide -1 as the "doc string index" - ;; so that no element will be treated as a doc string. - (byte-compile-output-docform - "\n(defalias '" - name - (cond ((atom code) - (if macrop '(" '(macro . #[" -1 "])") '(" #[" -1 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " -1 ")") '(" '(" -1 ")"))) - ((if macrop '(" (cons 'macro (" -1 "))") '(" (" -1 ")")))) - ;; FSF just calls `(append code nil)' here but that relies - ;; on horrible C kludges in concat() that accept byte- - ;; compiled objects and pretend they're vectors. - (if (compiled-function-p code) - (byte-compile-compiled-obj-to-list code) - (append code nil)) - (and (atom code) byte-compile-dynamic - 1) - nil) - ;; Output the form by hand, that's much simpler than having - ;; b-c-output-file-form analyze the defalias. - (byte-compile-output-docform - "\n(defalias '" - name - (cond ((atom code) ; compiled-function-p - (if macrop '(" '(macro . #[" 4 "])") '(" #[" 4 "]"))) - ((eq (car code) 'quote) - (setq code new-one) - (if macrop '(" '(macro " 2 ")") '(" '(" 2 ")"))) - ((if macrop '(" (cons 'macro (" 5 "))") '(" (" 5 ")")))) - ;; The result of byte-compile-byte-code-maker is either a - ;; compiled-function object, or a list of some kind. If it's - ;; not a cons, we must coerce it into a list of the elements - ;; to be printed to the file. - (if (consp code) - code - (nconc (list - (compiled-function-arglist code) - (compiled-function-instructions code) - (compiled-function-constants code) - (compiled-function-stack-depth code)) - (let ((doc (documentation code t))) - (if doc (list doc))) - (if (commandp code) - (list (nth 1 (compiled-function-interactive code)))))) - (and (atom code) byte-compile-dynamic - 1) + ;; No doc string. Provide -1 as the "doc string index" so that + ;; no element will be treated as a doc string by + ;; byte-compile-output-doc-form. + (setq docform-info (list (first docform-info) -1 + (third docform-info)))) + (byte-compile-output-docform + "\n(defalias '" + name + docform-info + ;; The result of byte-compile-byte-code-maker is either a + ;; compiled-function object, or a list of some kind. If it's not a + ;; cons, we must coerce it into a list of the elements to be + ;; printed to the file. + (if (consp code) + code + (nconc (list + (compiled-function-arglist code) + (compiled-function-instructions code) + (compiled-function-constants code) + (compiled-function-stack-depth code) + (compiled-function-doc-string code)) + (if (commandp code) + (list (nth 1 (compiled-function-interactive code)))))) + (and (atom code) byte-compile-dynamic + 1) nil)) (princ ")" byte-compile-outbuffer) - nil)))) + nil))) ;; Print Lisp object EXP in the output file, inside a comment, ;; and return the file position it will have. @@ -3111,7 +3079,8 @@ (byte-defop-compiler aref 2) (byte-defop-compiler get 2+1) (byte-defop-compiler nth 2) -(byte-defop-compiler substring 2-3) +(byte-defop-compiler subseq byte-compile-subseq) +(byte-defop-compiler (substring byte-subseq) 2-3) (byte-defop-compiler (move-marker byte-set-marker) 2-3) (byte-defop-compiler set-marker 2-3) (byte-defop-compiler match-beginning 1) @@ -3524,6 +3493,12 @@ the syntax (function (lambda (...) ...)) instead.")))) (byte-compile-two-args form)) +(defun byte-compile-subseq (form) + (byte-compile-two-or-three-args form) + ;; Check that XEmacs supports the substring-subseq equivalence. + (pushnew '(eq 'subseq (symbol-function 'substring)) + byte-compile-checks-on-load :test #'equal)) + (defmacro byte-compile-funarg-n (&rest n) `#'(lambda (form) ,@(loop
--- a/lisp/cl-extra.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/cl-extra.el Mon Mar 29 21:28:13 2010 -0500 @@ -612,9 +612,7 @@ ((memq (car plst) indicator-list) (return (values (car plst) (cadr plst) plst)))))) -;; See our compiler macro in cl-macs.el, we will only pass back the -;; actual lambda list in interpreted code or if we've been funcalled -;; (from #'apply or #'mapcar or whatever). +;; See also the compiler macro in cl-macs.el. (defun constantly (value &rest more-values) "Construct a function always returning VALUE, and possibly MORE-VALUES. @@ -622,7 +620,24 @@ Members of MORE-VALUES, if provided, will be passed as multiple values; see `multiple-value-bind' and `multiple-value-setq'." - `(lambda (&rest ignore) (values-list ',(cons value more-values)))) + (symbol-macrolet + ((arglist '(&rest ignore))) + (if (or more-values (eval-when-compile (not (cl-compiling-file)))) + `(lambda ,arglist (values-list ',(cons value more-values))) + (make-byte-code + arglist + (eval-when-compile + (let ((compiled (byte-compile-sexp #'(lambda (&rest ignore) + (declare (ignore ignore)) + 'placeholder)))) + (assert (and + (equal [placeholder] + (compiled-function-constants compiled)) + (= 1 (compiled-function-stack-depth compiled))) + t + "Our assumptions about compiled code appear not to hold.") + (compiled-function-instructions compiled))) + (vector value) 1)))) ;;; Hash tables. @@ -673,15 +688,19 @@ (defun cl-prettyprint (form) "Insert a pretty-printed rendition of a Lisp FORM in current buffer." - (let ((pt (point)) last) + (let ((pt (point)) last just) (insert "\n" (prin1-to-string form) "\n") (setq last (point)) (goto-char (1+ pt)) - (while (search-forward "(quote " last t) - (delete-backward-char 7) - (insert "'") + (while (re-search-forward "(\\(?:\\(?:function\\|quote\\) \\)" last t) + (delete-region (match-beginning 0) (match-end 0)) + (if (= (length "(function ") (- (match-end 0) (match-beginning 0))) + (insert "#'") + (insert "'")) + (setq just (point)) (forward-sexp) - (delete-char 1)) + (delete-char 1) + (goto-char just)) (goto-char (1+ pt)) (cl-do-prettyprint)))
--- a/lisp/cl-macs.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/cl-macs.el Mon Mar 29 21:28:13 2010 -0500 @@ -297,27 +297,22 @@ (mapcar 'cl-upcase-arg arg))) (t arg))) ; Maybe we are in initializer -;; npak@ispras.ru +;; npak@ispras.ru, modified by ben@666.com ;;;###autoload -(defun cl-function-arglist (name arglist &optional omit-name) +(defun cl-function-arglist (arglist) "Returns string with printed representation of arguments list. Supports Common Lisp lambda lists." - ;; #### I would just change this so that OMIT-NAME is always true and - ;; eliminate the argument, but this function is autoloaded, which means - ;; someone might be using it somewhere. (if (not (or (listp arglist) (symbolp arglist))) "Not available" (check-argument-type #'true-list-p arglist) (let ((print-gensym nil)) (condition-case nil - (prin1-to-string - (let ((args (cond ((null arglist) nil) - ((listp arglist) (cl-upcase-arg arglist)) - ((symbolp arglist) - (cl-upcase-arg (list '&rest arglist))) - (t (wrong-type-argument 'listp arglist))))) - (if omit-name args - (cons (if (eq name 'cl-none) 'lambda name) args)))) + (let ((args (cond ((null arglist) nil) + ((listp arglist) (cl-upcase-arg arglist)) + ((symbolp arglist) + (cl-upcase-arg (list '&rest arglist))) + (t (wrong-type-argument 'listp arglist))))) + (if args (prin1-to-string args) "()")) (t "Not available"))))) (defun cl-transform-lambda (form bind-block) @@ -325,7 +320,7 @@ (bind-defs nil) (bind-enquote nil) (bind-inits nil) (bind-lets nil) (bind-forms nil) (header nil) (simple-args nil) - (complex-arglist (cl-function-arglist bind-block args t)) + (complex-arglist (cl-function-arglist args)) (doc "")) (while (or (stringp (car body)) (eq (car-safe (car body)) 'interactive)) (push (pop body) header)) @@ -352,7 +347,7 @@ ;; Add CL lambda list to documentation, if the CL lambda list differs ;; from the non-CL lambda list. npak@ispras.ru (unless (equal complex-arglist - (cl-function-arglist bind-block simple-args t)) + (cl-function-arglist simple-args)) (and (stringp (car header)) (setq doc (pop header))) ;; Stick the arguments onto the end of the doc string in a way that ;; will be recognized specially by `function-arglist'. @@ -499,8 +494,7 @@ (list t (list 'error - (format "Keyword argument %%s not one of %s" - keys) + ''invalid-keyword-argument (list 'car var))))))) (push (list 'let (list (list var restarg)) check) bind-forms))) (while (and (eq (car args) '&aux) (pop args)) @@ -2164,6 +2158,8 @@ (defsetf face-background (f &optional s) (x) (list 'set-face-background f x s)) (defsetf face-background-pixmap (f &optional s) (x) (list 'set-face-background-pixmap f x s)) +(defsetf face-background-placement (f &optional s) (x) + (list 'set-face-background-placement f x s)) (defsetf face-font (f &optional s) (x) (list 'set-face-font f x s)) (defsetf face-foreground (f &optional s) (x) (list 'set-face-foreground f x s)) (defsetf face-underline-p (f &optional s) (x) @@ -3296,50 +3292,113 @@ (list 'let (list (list temp val)) (subst temp val res))))) form)) -;; XEmacs; inline delete-duplicates if it's called with a literal -;; #'equal or #'eq and no other keywords, we want the speed in -;; font-lock.el. +(define-compiler-macro delete-dups (list) + `(delete-duplicates (the list ,list) :test #'equal :from-end t)) + +;; XEmacs; inline delete-duplicates if it's called with one of the +;; common compile-time constant tests and an optional :from-end +;; argument, we want the speed in font-lock.el. (define-compiler-macro delete-duplicates (&whole form cl-seq &rest cl-keys) (let ((listp-check - (if (memq (car-safe cl-seq) - ;; No need to check for a list at runtime with these. We - ;; could expand the list, but these are all the functions - ;; in the relevant context at the moment. - '(nreverse append nconc mapcan mapcar)) - t - '(listp begin)))) - (cond ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote eq) (fourth form)) - (equal '(function eq) (fourth form)))) + (cond + ((memq (car-safe cl-seq) + ;; No need to check for a list at runtime with these. We + ;; could expand the list, but these are all the functions + ;; in the relevant context at the moment. + '(nreverse append nconc mapcan mapcar string-to-list)) + t) + ((and (listp cl-seq) (eq (first cl-seq) 'the) + (eq (second cl-seq) 'list)) + ;; Allow users to force this, if they really want to. + t) + (t + '(listp begin))))) + (cond ((loop + for relevant-key-values + in '((:test 'eq) + (:test #'eq) + (:test 'eq :from-end nil) + (:test #'eq :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (memq (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (memq (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq))) + (setq cl-seq (cdr cl-seq))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'eq :from-end t) + (:test #'eq :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + (cl-seq begin)) + (if ,listp-check + (progn + (while cl-seq + (setq cl-seq (setcdr cl-seq + (delq (car cl-seq) (cdr cl-seq))))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + + ((loop + for relevant-key-values + in '((:test 'equal) + (:test #'equal) + (:test 'equal :from-end nil) + (:test #'equal :from-end nil)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) + `(let* ((begin ,cl-seq) + cl-seq) + (if ,listp-check + (progn + (while (member (car begin) (cdr begin)) + (setq begin (cdr begin))) + (setq cl-seq begin) + (while (cddr cl-seq) + (if (member (cadr cl-seq) (cddr cl-seq)) + (setcdr (cdr cl-seq) (cddr cl-seq))) + (setq cl-seq (cdr cl-seq))) + begin) + ;; Call cl-delete-duplicates explicitly, to avoid the form + ;; getting compiler-macroexpanded again: + (cl-delete-duplicates begin ',cl-keys nil)))) + ((loop + for relevant-key-values + in '((:test 'equal :from-end t) + (:test #'equal :from-end t)) + ;; One of the above corresponds exactly to CL-KEYS: + thereis (not (set-difference cl-keys relevant-key-values + :test #'equal))) `(let* ((begin ,cl-seq) (cl-seq begin)) (if ,listp-check (progn (while cl-seq - (setq cl-seq (setcdr cl-seq (delq (car cl-seq) - (cdr cl-seq))))) - begin) + (setq cl-seq + (setcdr cl-seq (delete (car cl-seq) (cdr cl-seq))))) + begin) ;; Call cl-delete-duplicates explicitly, to avoid the form ;; getting compiler-macroexpanded again: (cl-delete-duplicates begin ',cl-keys nil)))) - ((and (= 4 (length form)) - (eq :test (third form)) - (or (equal '(quote equal) (fourth form)) - (equal '(function equal) (fourth form)))) - `(let* ((begin ,cl-seq) - (cl-seq begin)) - (if ,listp-check - (progn - (while cl-seq - (setq cl-seq (setcdr cl-seq (delete (car cl-seq) - (cdr cl-seq))))) - begin) - ;; Call cl-delete-duplicates explicitly, to avoid the form - ;; getting compiler-macroexpanded again: - (cl-delete-duplicates begin ',cl-keys nil)))) - (t - form)))) + (t form)))) ;; XEmacs; it's perfectly reasonable, and often much clearer to those ;; reading the code, to call regexp-quote on a constant string, which is @@ -3550,10 +3609,10 @@ ;; (t form))))) (define-compiler-macro notany (&whole form &rest cl-rest) - (cons 'not (cons 'some (cdr cl-rest)))) + `(not (some ,@(cdr form)))) (define-compiler-macro notevery (&whole form &rest cl-rest) - (cons 'not (cons 'every (cdr cl-rest)))) + `(not (every ,@(cdr form)))) (define-compiler-macro constantly (&whole form value &rest more-values) (cond
--- a/lisp/cl-seq.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/cl-seq.el Mon Mar 29 21:28:13 2010 -0500 @@ -107,7 +107,7 @@ other-keys)))) '(car (cdr (memq (quote :allow-other-keys) cl-keys))) - '(error "Bad keyword argument %s" + '(error 'invalid-keyword-argument (car cl-keys-temp))) '(setq cl-keys-temp (cdr (cdr cl-keys-temp))))))) body))))
--- a/lisp/coding.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/coding.el Mon Mar 29 21:28:13 2010 -0500 @@ -5,7 +5,7 @@ ;; Copyright (C) 1995 Amdahl Corporation. ;; Copyright (C) 1995 Sun Microsystems. ;; Copyright (C) 1997 MORIOKA Tomohiko -;; Copyright (C) 2000, 2001, 2002, 2010 Ben Wing. +;; Copyright (C) 2000, 2001, 2002 Ben Wing. ;; This file is part of XEmacs. @@ -464,27 +464,42 @@ (and (query-coding-string char coding-system) (encode-coding-string char coding-system))) -(defun decode-char (quote-ucs code &optional restriction) - "FSF compatibility--return Mule character with Unicode codepoint CODE. -The second argument must be 'ucs, the third argument is ignored. " - ;; We're prepared to accept invalid Unicode in unicode-to-char, but not in - ;; this function, which is the API that should actually be used, since - ;; it's available in GNU and in Mule-UCS. - (check-argument-range code #x0 #x10FFFF) - (assert (eq quote-ucs 'ucs) t - "Sorry, decode-char doesn't yet support anything but the UCS. ") - (unicode-to-char code)) +(if (featurep 'mule) + (progn + ;; Under Mule, we do much of the complicated coding system creation in + ;; Lisp and especially at compile time. We need some function + ;; definition for this function to be created in this file, but we can + ;; leave assigning the docstring to the autoload cookie + ;; handling later. Thankfully; that docstring is big. + (autoload 'make-coding-system "mule/make-coding-system") -(defun encode-char (char quote-ucs &optional restriction) - "FSF compatibility--return the Unicode code point of CHAR. -The second argument must be 'ucs, the third argument is ignored. " - (assert (eq quote-ucs 'ucs) t - "Sorry, encode-char doesn't yet support anything but the UCS. ") - (char-to-unicode char)) + ;; (During byte-compile before dumping, make-coding-system may already + ;; have been loaded, make sure not to overwrite the correct compiler + ;; macro:) + (when (eq 'autoload (car (symbol-function 'make-coding-system))) + ;; Make sure to pick up the correct compiler macro when compiling + ;; files: + (define-compiler-macro make-coding-system (&whole form name type + &optional description props) + (load (second (symbol-function 'make-coding-system))) + (funcall (get 'make-coding-system 'cl-compiler-macro) + form name type description props)))) -(unless (featurep 'mule) ;; Mule's not available; (fset 'make-coding-system (symbol-function 'make-coding-system-internal)) + (define-compiler-macro make-coding-system (&whole form name type + &optional description props) + (cond + ;; We shouldn't normally see these forms under non-Mule; they're all in + ;; the mule/ subdirectory. + ((equal '(quote fixed-width) type) + form) + ((byte-compile-constp type) + `(funcall (or (and (fboundp 'make-coding-system-internal) + 'make-coding-system-internal) 'make-coding-system) + ,@(cdr form))) + (t form))) + (define-coding-system-alias 'escape-quoted 'binary) ;; These are so that gnus and friends work when not mule:
--- a/lisp/cus-face.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/cus-face.el Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,7 @@ ;;; cus-face.el -- Support for Custom faces. ;; ;; Copyright (C) 1996, 1997 Free Software Foundation, Inc. +;; Copyright (C) 2010 Didier Verna ;; ;; Author: Per Abrahamsen <abraham@dina.kvl.dk> ;; Maintainer: Hrvoje Niksic <hniksic@xemacs.org> @@ -83,7 +84,12 @@ :help-echo "\ Name of background pixmap file.") set-face-background-pixmap custom-face-background-pixmap) - (:dim (toggle :format "%[Dim%]: %v\n" + (:background-placement (choice :tag "Background placement" :value relative + (const :tag "Relative" :value relative) + (const :tag "Absolute" :value absolute)) + set-face-background-placement + face-background-placement) + (:dim (toggle :format "%[Dim%]: %v\n" :help-echo "Control whether the text should be dimmed.") set-face-dim-p face-dim-p) (:bold (toggle :format "%[Bold%]: %v\n"
--- a/lisp/descr-text.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/descr-text.el Mon Mar 29 21:28:13 2010 -0500 @@ -257,14 +257,6 @@ file)) ;; XEmacs additions, from here until `describe-char-unicode-data' -(defcustom describe-char-use-cache t - "Whether `describe-char' should use a DBM or Berkeley DB cache. -This speeds up navigation of `describe-char-unicodedata-file', and makes -navigation of `describe-char-unihan-file' reasonable." - :group 'mule - :type '(choice (const :tag "None" nil) - file)) - (defcustom describe-char-unihan-file nil "Location of Unihan file. This the Unihan.txt file from the Unicode Consortium, used for diagnostics. @@ -290,6 +282,14 @@ (and (featurep 'berkeley-db) 'berkeley-db)) "The DB format to use for the `describe-char' cache, or nil if no cache.") +(defcustom describe-char-use-cache (not (null unidata-database-format)) + "Whether `describe-char' should use a DBM or Berkeley DB cache. +This speeds up navigation of `describe-char-unicodedata-file', and makes +navigation of `describe-char-unihan-file' reasonable." + :group 'mule + :type '(choice (const :tag "None" nil) + file)) + (defvar describe-char-unihan-field-descriptions #s(hash-table :test equal :data ("kAccountingNumeric" @@ -967,14 +967,17 @@ (ccl (or (and (charset-property charset 'encode-as-utf-8) ccl-encode-to-ucs-2) (charset-property charset 'ccl-program))) - (ccl-vector (make-vector 8 0))) + (ccl-vector (make-vector 8 0)) + font-instance) (if (display-graphic-p (selected-frame)) (list - (font-instance-name - (face-font-instance (or (get-char-property pos 'face) - 'default) - (selected-window) - charset)) + (if (setq font-instance + (face-font-instance (or (get-char-property pos 'face) + 'default) + (selected-window) + charset)) + (font-instance-name font-instance) + "[no font available]") (cond ((and ccl (eq 'x (frame-type frame))) (setq char (split-char char))
--- a/lisp/diagnose.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/diagnose.el Mon Mar 29 21:28:13 2010 -0500 @@ -35,29 +35,42 @@ "Show statistics about memory usage of various sorts in XEmacs." (interactive) (garbage-collect) - (flet ((show-foo-stats (objtypename objlist memfun) + (flet ((show-foo-stats (objtypename statname-plist cleanfun objlist + &optional objnamelen) (let* ((hash (make-hash-table)) (first t) - types fmt - (objnamelen 25) + types origtypes fmt + (objnamelen (or objnamelen 25)) (linelen objnamelen) (totaltotal 0)) - (dolist (obj objlist) + (loop for obj in objlist do (let ((total 0) - (stats (funcall memfun obj))) - (loop for (type . num) in stats while type do + (stats (object-memory-usage obj))) + ;; Pop off the slice describing the object itself's + ;; memory + (while (and stats (not (eq t (pop stats))))) + ;; Pop off the slice describing the associated + ;; non-Lisp-Object memory from the allocation + ;; perspective, so we can get to the slice describing + ;; the memory grouped by type + (while (and stats (pop stats))) + + (loop for (type . num) in (remq t stats) while type do + (if first (push type origtypes)) + (setq type (getf statname-plist type type)) (puthash type (+ num (or (gethash type hash) 0)) hash) (incf total num) (if first (push type types))) (incf totaltotal total) (when first (setq types (nreverse types)) + (setq origtypes (nreverse origtypes)) (setq fmt (concat (format "%%-%ds" objnamelen) (mapconcat #'(lambda (type) (let ((fieldlen - (max 8 (+ 2 (length + (max 7 (+ 2 (length (symbol-name type)))))) (incf linelen fieldlen) (format "%%%ds" fieldlen))) @@ -68,13 +81,13 @@ (append types (list 'total)))) (princ (make-string linelen ?-)) (princ "\n")) - (let ((objname (format "%s" obj))) + (let ((objname (format "%s" (funcall cleanfun obj)))) (princ (apply 'format fmt (substring objname 0 (min (length objname) (1- objnamelen))) (nconc (mapcar #'(lambda (type) (cdr (assq type stats))) - types) + origtypes) (list total))))) (setq first nil))) (princ "\n") @@ -94,8 +107,8 @@ (when-fboundp 'charset-list (setq begin (point)) (incf grandtotal - (show-foo-stats 'charset (charset-list) - #'charset-memory-usage)) + (show-foo-stats 'charset nil 'charset-name + (mapcar 'get-charset (charset-list)))) (when-fboundp 'sort-numeric-fields (sort-numeric-fields -1 (save-excursion @@ -108,7 +121,7 @@ (princ "\n")) (setq begin (point)) (incf grandtotal - (show-foo-stats 'buffer (buffer-list) #'buffer-memory-usage)) + (show-foo-stats 'buffer nil 'buffer-name (buffer-list))) (when-fboundp 'sort-numeric-fields (sort-numeric-fields -1 (save-excursion @@ -121,10 +134,19 @@ (princ "\n") (setq begin (point)) (incf grandtotal - (show-foo-stats 'window (mapcan #'(lambda (fr) - (window-list fr t)) - (frame-list)) - #'window-memory-usage)) + (show-foo-stats 'window + '(line-start-cache line-st. + face-cache face + glyph-cache glyph + redisplay-structs redisplay + scrollbar-instances scrollbar + window-mirror mirror) + #'(lambda (x) + (buffer-name (window-buffer x))) + (mapcan #'(lambda (fr) + (window-list fr t)) + (frame-list)) + 16)) (when-fboundp #'sort-numeric-fields (sort-numeric-fields -1 (save-excursion @@ -142,16 +164,19 @@ (princ (make-string 40 ?-)) (princ "\n") (map-plist #'(lambda (stat num) - (when (string-match - "\\(.*\\)-storage$" - (symbol-name stat)) + (when (and + (not + (string-match + "\\(.*\\)-ancillary-storage$" + (symbol-name stat))) + (string-match + "\\(.*\\)-storage$" + (symbol-name stat))) (incf total num) (princ (format fmt (match-string 1 (symbol-name stat)) num))) - (when (eq stat 'long-strings-total-length) - (incf total num) - (princ (format fmt stat num)))) + ) (sixth (garbage-collect))) (princ "\n") (princ (format fmt "total" total)) @@ -176,64 +201,99 @@ (garbage-collect) (let ((buffer "*object memory usage statistics*") (plist (object-memory-usage-stats)) - (fmt "%-30s%10s%10s\n") + (fmt "%-28s%10s%10s%10s%10s%10s\n") (grandtotal 0) begin) (flet ((show-stats (match-string) - (princ (format fmt "object" "count" "storage")) - (princ (make-string 50 ?-)) + (princ (format "%28s%10s%40s\n" "" "" + "--------------storage---------------")) + (princ (format fmt "object" "count" "object" "overhead" + "non-Lisp" "ancillary")) + (princ (make-string 78 ?-)) (princ "\n") (let ((total-use 0) + (total-non-lisp-use 0) (total-use-overhead 0) + (total-use-with-overhead 0) (total-count 0)) (map-plist #'(lambda (stat num) - (when (string-match match-string - (symbol-name stat)) - (let ((storage-use num) - (storage-use-overhead - (plist-get - plist - (intern (concat (match-string 1 (symbol-name stat)) - "-storage-including-overhead")))) - (storage-count - (or (loop for str in '("s-used" "es-used" "-used") - for val = (plist-get - plist - (intern - (concat (match-string - 1 (symbol-name stat)) - str))) - if val - return val) - (plist-get - plist - (intern - (concat (substring - (match-string 1 (symbol-name stat)) - 0 -1) - "ies-used"))) - ))) - (incf total-use storage-use) - (incf total-use-overhead (if storage-use-overhead - storage-use-overhead - storage-use)) - (incf total-count (or storage-count 0)) - (and (> storage-use 0) - (princ (format fmt - (match-string 1 (symbol-name stat)) - (or storage-count "unknown") - storage-use)))))) + (let ((symmatch + (and (string-match match-string (symbol-name stat)) + (match-string 1 (symbol-name stat))))) + (when (and symmatch + (or (< (length symmatch) 9) + (not (equal (substring symmatch -9) + "-non-lisp"))) + (or (< (length symmatch) 15) + (not (equal (substring symmatch -15) + "-lisp-ancillary")))) + (let* ((storage-use num) + (storage-use-overhead + (or (plist-get + plist + (intern (concat symmatch + "-storage-overhead"))) + 0)) + (storage-use-with-overhead + (or (plist-get + plist + (intern (concat + symmatch + "-storage-including-overhead"))) + (+ storage-use storage-use-overhead))) + (storage-use-overhead + (- storage-use-with-overhead storage-use)) + (non-lisp-storage + (or (plist-get + plist + (intern (concat symmatch + "-non-lisp-storage"))) + 0)) + (lisp-ancillary-storage + (or (plist-get + plist + (intern (concat symmatch + "-lisp-ancillary-storage"))) + 0)) + (storage-count + (or (loop for str in '("s-used" "es-used" "-used") + for val = (plist-get + plist + (intern + (concat symmatch str))) + if val + return val) + (plist-get + plist + (intern + (concat (substring symmatch 0 -1) + "ies-used"))) + ))) + (incf total-use storage-use) + (incf total-use-overhead storage-use-overhead) + (incf total-use-with-overhead storage-use-with-overhead) + (incf total-non-lisp-use non-lisp-storage) + (incf total-count (or storage-count 0)) + (and (> storage-use-with-overhead 0) + (princ (format fmt symmatch + (or storage-count "unknown") + storage-use + storage-use-overhead + non-lisp-storage + lisp-ancillary-storage))))))) plist) (princ "\n") (princ (format fmt "total" - total-count total-use-overhead)) - (incf grandtotal total-use-overhead) + total-count total-use total-use-overhead + total-non-lisp-use "")) + (incf grandtotal total-use-with-overhead) + (incf grandtotal total-non-lisp-use) (when-fboundp #'sort-numeric-fields - (sort-numeric-fields -1 + (sort-numeric-fields -4 (save-excursion (goto-char begin) - (forward-line 3) + (forward-line 4) (point)) (save-excursion (forward-line -2) @@ -242,7 +302,7 @@ (save-excursion (set-buffer buffer) (setq begin (point)) - (princ "Allocated with lisp allocator:\n") + (princ "Allocated with lisp allocator or related:\n") (show-stats "\\(.*\\)-storage$") (princ (format "\n\ngrand total: %s\n" grandtotal))) grandtotal))))
--- a/lisp/disp-table.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/disp-table.el Mon Mar 29 21:28:13 2010 -0500 @@ -2,8 +2,8 @@ ;; Copyright (C) 1987, 1994, 1997, 2007 Free Software Foundation, Inc. ;; Copyright (C) 1995 Sun Microsystems. +;; Copyright (C) 2005 Ben Wing. -;; Author: Howard Gayle ;; Maintainer: XEmacs Development Team ;; Keywords: i18n, internal @@ -29,7 +29,10 @@ ;;; Commentary: ;; Rewritten for XEmacs July 1995, Ben Wing. - +;; November 1998?, display tables generalized to char/range tables, Hrvoje +;; Niksic. +;; July 2007, rewrite this file to handle generalized display tables, +;; Aidan Kehoe. ;;; Code: @@ -116,6 +119,9 @@ ;; Let me say one more time how much dynamic scoping sucks. +;; #### Need more thinking about basic primitives for modifying a specifier. +;; cf `modify-specifier-instances'. + ;;;###autoload (defun frob-display-table (fdt-function fdt-locale &optional tag-set) (or fdt-locale (setq fdt-locale 'global)) @@ -184,8 +190,8 @@ ;;;###autoload (defun standard-display-g1 (c sc &optional locale) "Display character C as character SC in the g1 character set. -This function assumes that your terminal uses the SO/SI characters; -it is meaningless for an X frame." +This only has an effect on TTY devices and assumes that your terminal uses +the SO/SI characters." (frob-display-table (lambda (x) (put-char-table c (concat "\016" (char-to-string sc) "\017") x)) @@ -194,8 +200,7 @@ ;;;###autoload (defun standard-display-graphic (c gc &optional locale) "Display character C as character GC in graphics character set. -This function assumes VT100-compatible escapes; it is meaningless for an -X frame." +This only has an effect on TTY devices and assumes VT100-compatible escapes." (frob-display-table (lambda (x) (put-char-table c (concat "\e(0" (char-to-string gc) "\e(B") x))
--- a/lisp/dumped-lisp.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/dumped-lisp.el Mon Mar 29 21:28:13 2010 -0500 @@ -160,7 +160,6 @@ "code-process" ;; Provide basic commands to set coding systems to user "code-cmds" - (when (featurep 'mule) "mule/make-coding-system") "unicode" ;;;;;;;;;;;;;;;;;; MULE support (when (featurep 'mule)
--- a/lisp/faces.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/faces.el Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Board of Trustees, University of Illinois ;; Copyright (C) 1995, 1996, 2002, 2005 Ben Wing +;; Copyright (C) 2010 Didier Verna ;; Author: Ben Wing <ben@xemacs.org> ;; Keywords: faces, internal, dumped @@ -87,6 +88,8 @@ (color-instance-name default)) ((image-instance-p default) (image-instance-file-name default)) + ((face-background-placement-instance-p default) + (symbol-name default)) (t default)))))) (list face (if (equal value "") nil value)))) @@ -333,6 +336,11 @@ Only used by faces on X and MS Windows devices. For valid instantiators, see `make-image-specifier'. + background-placement The placement of the face's background pixmap. + Only used by faces on X devices. + For valid instantiators, + see `make-face-background-placement-specifier'. + underline Underline all text covered by this face. For valid instantiators, see `make-face-boolean-specifier'. @@ -716,6 +724,45 @@ (list face (if (equal file "") nil file)))) (set-face-property face 'background-pixmap file)) +(defun face-background-placement (face &optional domain default no-fallback) + "Return FACE's background placement in DOMAIN. +See `face-property-instance' for the semantics of the DOMAIN argument." + (face-property face 'background-placement domain default no-fallback)) + +(defun set-face-background-placement (face placement &optional locale tag-set + how-to-add) + "Change the background-placement property of FACE to PLACEMENT. +PLACEMENT is normally a background-placement instantiator; see +`make-face-background-placement-specifier'. +See `set-face-property' for the semantics of the LOCALE, TAG-SET, and +HOW-TO-ADD arguments." + (interactive (face-interactive "background placement")) + ;; When called non-interactively (for example via custom), PLACEMENT is + ;; expected to be a symbol. -- dvl + (unless (symbolp placement) + (setq placement (intern placement))) + (set-face-property face 'background-placement placement locale tag-set + how-to-add)) + +(defun face-background-placement-instance (face &optional domain default + no-fallback) + "Return FACE's background-placement instance in DOMAIN. +Return value will be a background-placement instance object. + +FACE may be either a face object or a symbol representing a face. + +Normally DOMAIN will be a window or nil (meaning the selected window), +and an instance object describing the background placement in that particular +window and buffer will be returned. + +See `face-property-instance' for more information." + (face-property-instance face 'background-placement domain default + no-fallback)) + +(defun face-background-placement-instance-p (object) + "Return t if OBJECT is a face-background-placement instance." + (or (eq object 'absolute) (eq object 'relative))) + (defun face-display-table (face &optional locale tag-set exact-p) "Return the display table spec of FACE in LOCALE, or nil if unspecified.. @@ -871,7 +918,7 @@ (let ((device (dfw-device domain)) (common-props '(foreground background font display-table underline dim inherit)) - (win-props '(background-pixmap strikethru)) + (win-props '(background-pixmap background-placement strikethru)) (tty-props '(highlight blinking reverse))) ;; First check the properties which are used in common between the @@ -1943,7 +1990,8 @@ ;; element faces. So take the modeline face information from its ;; fallbacks, themselves ultimately set up in faces.c: (loop - for face-property in '(foreground background background-pixmap) + for face-property in '(foreground background + background-pixmap background-placement) do (when (and (setq face-property (face-property 'modeline face-property)) (null (specifier-instance face-property device nil t)) (specifier-instance face-property device))
--- a/lisp/fontcolor.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/fontcolor.el Mon Mar 29 21:28:13 2010 -0500 @@ -2,6 +2,7 @@ ;; Copyright (C) 1994, 1997 Free Software Foundation, Inc. ;; Copyright (C) 1995 Ben Wing +;; Copyright (C) 2010 Didier Verna ;; Author: Chuck Thompson <cthomp@xemacs.org> ;; Author: Ben Wing <ben@xemacs.org> @@ -194,4 +195,18 @@ if non-nil, means to invert the sense of the inherited property." (make-specifier-and-init 'face-boolean spec-list)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; face-background-placement specifiers + +(defun make-face-background-placement-specifier (spec-list) + "Return a new `face-background-placement' specifier object. +SPEC-LIST can be a list of specifications (each of which is a cons of a +locale and a list of instantiators), a single instantiator, or a list +of instantiators. See `make-specifier' for a detailed description of +how specifiers work. + +Valid instantiators for face-background-placement specifiers are: +-- absolute or relative (symbols), +-- a vector of one element: a face to inherit from." + (make-specifier-and-init 'face-background-placement spec-list)) + ;;; fontcolor.el ends here.
--- a/lisp/frame.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/frame.el Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ ;; Copyright (C) 1993, 1994, 1996, 1997, 2000, 2001, 2003 ;; Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996 Ben Wing. +;; Copyright (C) 2010 Didier Verna ;; Maintainer: XEmacs Development Team ;; Keywords: internal, dumped @@ -1015,6 +1016,28 @@ "Set property PROP of FRAME to VAL. See `set-frame-properties'." (set-frame-properties frame (list prop val))) +(defun set-frame-background-placement (placement) + "Set the background placement of the selected frame to PLACEMENT. +When called interactively, prompt for the placement to use." + (interactive (list (intern (completing-read "Placement: " + '(("absolute" absolute) + ("relative" relative)) + nil t)))) + (set-face-background-placement 'default placement (selected-frame))) + +(defun frame-background-placement () + "Retrieve the selected frame's background placement." + (interactive) + (face-background-placement 'default (selected-frame))) + +(defun frame-background-placement-instance () + "Retrieve the selected frame's background placement instance." + (interactive) + (face-background-placement-instance 'default (selected-frame))) + +;; #### FIXME: misnomers ! The functions below should be called +;; set-frame-<blabla> -- dvl. + ;; XEmacs change: this function differs significantly from Emacs. (defun set-background-color (color-name) "Set the background color of the selected frame to COLOR-NAME.
--- a/lisp/help.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/help.el Mon Mar 29 21:28:13 2010 -0500 @@ -1209,7 +1209,9 @@ t)) ((stringp arglist) - (format "(%s %s)" function arglist))))) + (if (> (length arglist) 0) + (format "(%s %s)" function arglist) + (format "(%s)" function)))))) ;; If STRIP-ARGLIST is true, return a cons (DOC . ARGS) of the documentation ;; with any embedded arglist stripped out, and the arglist that was stripped
--- a/lisp/hyper-apropos.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/hyper-apropos.el Mon Mar 29 21:28:13 2010 -0500 @@ -730,7 +730,7 @@ (local mode-name) global local-str global-str font fore back undl - aliases alias-desc desc) + aliases alias-desc desc arglist) (save-excursion (set-buffer (get-buffer-create hyper-apropos-help-buf)) ;;(setq standard-output (current-buffer)) @@ -764,21 +764,19 @@ (bytecode . "compiled Lisp ") (autoload . "autoloaded Lisp ") (lambda . "Lisp ")))) - desc - (case symtype - ((autoload) (format ",\n(autoloaded from \"%s\")" - (nth 1 newsym))) - ((bytecode) (format ",\n(loaded from \"%s\")" - (symbol-file symbol))))) + desc ",\n(loaded from \"" + (or (symbol-file symbol 'defun) + "[no file information available]") + "\")") local (current-local-map) global (current-global-map) obsolete (get symbol 'byte-obsolete-info) - doc (or (condition-case nil - (documentation symbol) - (void-function - "(alias for undefined function)") - (error "(unexpected error from `documention')")) - "function not documented")) + doc (function-documentation symbol t) + arglist (replace-in-string + (function-arglist symbol) + (format "^(%s " + (regexp-quote (symbol-name symbol))) + "(")) (save-excursion (set-buffer hyper-apropos-help-buf) (goto-char (point-max)) @@ -802,32 +800,7 @@ 'hyper-apropos-warning)) (setq beg (point)) (insert-face "arguments: " 'hyper-apropos-heading) - (cond ((eq symtype 'lambda) - (princ (or (nth 1 newsym) "()"))) - ((eq symtype 'bytecode) - (princ (or (compiled-function-arglist newsym) - "()"))) - ((and (or (eq symtype 'subr) (eq symtype 'autoload)) - (string-match - "[\n\t ]*\narguments: ?(\\([^)]*\\))\n?\\'" - doc)) - (insert (substring doc - (match-beginning 1) - (match-end 1))) - (setq doc (substring doc 0 (match-beginning 0)))) - ((and (eq symtype 'subr) - (string-match - "\ -\[\n\t ]*([^\n\t )]+[\t ]*\\([^\n)]+\\)?)\\(:[\t ]*\\|\n?\\'\\)" - doc)) - (insert "(" - (if (match-end 1) - (substring doc - (match-beginning 1) - (match-end 1))) - ")") - (setq doc (substring doc (match-end 0)))) - (t (princ "[not available]"))) + (princ arglist) (insert "\n\n") (hyper-apropos-insert-face doc) (insert "\n") @@ -944,14 +917,14 @@ (progn (setq ok t) (copy-face symbol 'hyper-apropos-temp-face 'global) - (mapcar #'(lambda (property) - (setq symtype (face-property-instance symbol - property)) - (if symtype - (set-face-property 'hyper-apropos-temp-face - property - symtype))) - built-in-face-specifiers) + (mapc #'(lambda (property) + (setq symtype (face-property-instance symbol + property)) + (if symtype + (set-face-property 'hyper-apropos-temp-face + property + symtype))) + built-in-face-specifiers) (setq font (cons (face-property-instance symbol 'font nil 0 t) (face-property-instance symbol 'font)) fore (cons (face-foreground-instance symbol nil 0 t)
--- a/lisp/make-docfile.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/make-docfile.el Mon Mar 29 21:28:13 2010 -0500 @@ -92,7 +92,7 @@ ;; no generate-new-buffer so use its implementation. (let ((buf (get-buffer-create (generate-new-buffer-name "foo")))) (set-buffer buf) - (insert-file-contents-internal (substring arg 1)) + (insert-file-contents-internal (subseq arg 1)) ;; now majorly grind up the response file. ;; backslashes get doubled, quotes around strings, ;; get rid of pesky CR's and NL's, and put parens around @@ -123,8 +123,7 @@ (concat (file-name-nondirectory ;; no match-string so use its implementation. - (substring arg (match-beginning 1) - (match-end 1))) + (subseq arg (match-beginning 1) (match-end 1))) ".c") source-src))) (if (and (null docfile-out-of-date)
--- a/lisp/mule/make-coding-system.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/mule/make-coding-system.el Mon Mar 29 21:28:13 2010 -0500 @@ -2,7 +2,6 @@ ;;; much of the implementation of the fixed-width coding system type. ;; Copyright (C) 2009 Free Software Foundation -;; Copyright (C) 2010 Ben Wing. ;; Author: Aidan Kehoe @@ -27,6 +26,13 @@ ;;; Code: +(defvar fixed-width-private-use-start ?\uE000 + "Start of a 256 code private use area for fixed-width coding systems. + +This is used to ensure that distinct octets on disk for a given coding +system map to distinct XEmacs characters, preventing spurious changes when +a file is read, not changed, and then written. ") + (defun fixed-width-generate-helper (decode-table encode-table encode-failure-octet) "Helper func, `fixed-width-generate-encode-program-and-skip-chars-strings', @@ -317,7 +323,7 @@ (check-argument-type #'listp unicode-map) (let ((decode-table (make-vector 256 nil)) (encode-table (make-hash-table :size 256 :rehash-threshold 0.999)) - (private-use-start #xE000) + (private-use-start (encode-char fixed-width-private-use-start 'ucs)) (invalid-sequence-code-point-start (eval-when-compile (char-to-unicode
--- a/lisp/mule/mule-cmds.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/mule/mule-cmds.el Mon Mar 29 21:28:13 2010 -0500 @@ -3,7 +3,7 @@ ;; Copyright (C) 1995,1999 Electrotechnical Laboratory, JAPAN. ;; Licensed to the Free Software Foundation. ;; Copyright (C) 1997 MORIOKA Tomohiko -;; Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. +;; Copyright (C) 2000, 2001, 2002, 2003, 2010 Ben Wing. ;; Keywords: mule, multilingual @@ -789,8 +789,8 @@ (setq string (format "%c" unicode-error-lookup))) ;; Treat control characters specially: (setq first-char (aref string 0)) - (when (or (and (>= #x00 first-char) (<= first-char #x1f)) - (and (>= #x80 first-char) (<= first-char #x9f))) + (when (or (and (>= first-char #x00) (<= first-char #x1f)) + (and (>= first-char #x80) (<= first-char #x9f))) (setq string (format "^%c" (+ ?@ (aref string 0)))))) (setq glyph (make-glyph (vector 'string :data string))) (set-glyph-face glyph 'unicode-invalid-sequence-warning-face)
--- a/lisp/setup-paths.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/setup-paths.el Mon Mar 29 21:28:13 2010 -0500 @@ -150,11 +150,11 @@ (and configure-prefix-directory (list (file-name-as-directory configure-prefix-directory)))) - :test #'equal)) + :test #'equal :from-end t)) (installation-roots (remove-if-not root-p potential-installation-roots))) (delete-duplicates (nconc invocation-roots installation-roots) - :test #'equal))) + :test #'equal :from-end t))) (defun paths-find-site-lisp-directory (roots) "Find the site Lisp directory of the XEmacs hierarchy. @@ -281,8 +281,8 @@ (nconc (paths-directories-which-exist configure-info-path) (paths-directories-which-exist paths-default-info-directories)) - :test #'equal))) - :test #'equal))) + :test #'equal :from-end t))) + :test #'equal :from-end t))) (defun paths-find-doc-directory (roots) "Find the documentation directory.
--- a/lisp/subr.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/subr.el Mon Mar 29 21:28:13 2010 -0500 @@ -220,6 +220,9 @@ (define-function 'send-string-to-terminal 'external-debugging-output) (define-function 'special-form-p 'special-operator-p) +;; XEmacs; this is in Lisp, its bytecode now taken by subseq. +(define-function 'substring 'subseq) + ;; XEmacs: (defun local-variable-if-set-p (sym buffer) "Return t if SYM would be local to BUFFER after it is set.
--- a/lisp/test-harness.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/test-harness.el Mon Mar 29 21:28:13 2010 -0500 @@ -194,6 +194,12 @@ (kill-buffer input-buffer) )) +(defsubst test-harness-backtrace () + "Display a reasonable-size backtrace." + (let ((print-escape-newlines t) + (print-length 50)) + (backtrace nil t))) + (defsubst test-harness-assertion-failure-do-debug (error-info) "Maybe enter debugger or display a backtrace on assertion failure. ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'. @@ -206,7 +212,7 @@ test-harness-assertion-failure-enter-debugger) (funcall debugger 'error error-info)) (test-harness-assertion-failure-show-backtrace - (backtrace nil t))))) + (test-harness-backtrace))))) (defsubst test-harness-unexpected-error-do-debug (error-info) "Maybe enter debugger or display a backtrace on unexpected error. @@ -220,7 +226,7 @@ test-harness-unexpected-error-enter-debugger) (funcall debugger 'error error-info)) (test-harness-unexpected-error-show-backtrace - (backtrace nil t))))) + (test-harness-backtrace))))) (defsubst test-harness-unexpected-error-condition-handler (error-info context-msg) "Condition handler for when unexpected errors occur. @@ -392,6 +398,29 @@ DESCRIPTION describes the assertion; by default, the unevalated assertion expression is given. FAILING-CASE and DESCRIPTION are useful when Assert is used in a loop." + (let ((test-assertion assertion) + (negated nil)) + (when (and (listp test-assertion) + (= 2 (length test-assertion)) + (memq (car test-assertion) '(not null))) + (setq test-assertion (cadr test-assertion)) + (setq negated t)) + (when (and (listp test-assertion) + (= 3 (length test-assertion)) + (member (car test-assertion) + '(eq eql equal equalp = string= < <= > >=))) + (let* ((test (car test-assertion)) + (testval (second test-assertion)) + (expected (third test-assertion)) + (failmsg `(format ,(if negated + "%S shouldn't be `%s' to %S but is" + "%S should be `%s' to %S but isn't") + ,testval ',test ,expected))) + (setq failing-case (if failing-case + `(concat + (format "%S, " ,failing-case) + ,failmsg) + failmsg))))) (let ((description (or description `(quote ,assertion)))) `(condition-case nil @@ -419,95 +448,6 @@ (incf passes))) (cl-assertion-failed nil)))) -;;;;; BEGIN DEFINITION OF SPECIFIC KINDS OF ASSERT MACROS - - (defmacro Assert-test (test testval expected &optional failing-case - description) - "Test passes if TESTVAL compares correctly to EXPECTED using TEST. -TEST should be a two-argument predicate (i.e. a function of two arguments -that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=', -'>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the -particular failure; any value given here will be concatenated with a phrase -describing the expected and actual values of the comparison. Optional -DESCRIPTION describes the assertion; by default, the unevalated comparison -expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert -is used in a loop." - (let* ((assertion `(,test ,testval ,expected)) - (failmsg `(format "%S should be `%s' to %S but isn't" - ,testval ',test ,expected)) - (failmsg2 (if failing-case `(concat - (format "%S, " ,failing-case) - ,failmsg) - failmsg))) - `(Assert ,assertion ,failmsg2 ,description))) - - (defmacro Assert-test-not (test testval expected &optional failing-case - description) - "Test passes if TESTVAL does not compare correctly to EXPECTED using TEST. -TEST should be a two-argument predicate (i.e. a function of two arguments -that returns t or nil), such as `eq', `eql', `equal', `equalp', `=', `<=', -'>', 'file-newer-than-file-p' etc. Optional FAILING-CASE describes the -particular failure; any value given here will be concatenated with a phrase -describing the expected and actual values of the comparison. Optional -DESCRIPTION describes the assertion; by default, the unevalated comparison -expressions are given. FAILING-CASE and DESCRIPTION are useful when Assert -is used in a loop." - (let* ((assertion `(not (,test ,testval ,expected))) - (failmsg `(format "%S shouldn't be `%s' to %S but is" - ,testval ',test ,expected)) - (failmsg2 (if failing-case `(concat - (format "%S, " ,failing-case) - ,failmsg) - failmsg))) - `(Assert ,assertion ,failmsg2 ,description))) - - ;; Specific versions of `Assert-test'. These are just convenience - ;; functions, functioning identically to `Assert-test', and duplicating - ;; the doc string for each would be too annoying. - (defmacro Assert-eq (testval expected &optional failing-case - description) - `(Assert-test eq ,testval ,expected ,failing-case ,description)) - (defmacro Assert-eql (testval expected &optional failing-case - description) - `(Assert-test eql ,testval ,expected ,failing-case ,description)) - (defmacro Assert-equal (testval expected &optional failing-case - description) - `(Assert-test equal ,testval ,expected ,failing-case ,description)) - (defmacro Assert-equalp (testval expected &optional failing-case - description) - `(Assert-test equalp ,testval ,expected ,failing-case ,description)) - (defmacro Assert-string= (testval expected &optional failing-case - description) - `(Assert-test string= ,testval ,expected ,failing-case ,description)) - (defmacro Assert= (testval expected &optional failing-case - description) - `(Assert-test = ,testval ,expected ,failing-case ,description)) - (defmacro Assert<= (testval expected &optional failing-case - description) - `(Assert-test <= ,testval ,expected ,failing-case ,description)) - - ;; Specific versions of `Assert-test-not'. These are just convenience - ;; functions, functioning identically to `Assert-test-not', and - ;; duplicating the doc string for each would be too annoying. - (defmacro Assert-not-eq (testval expected &optional failing-case - description) - `(Assert-test-not eq ,testval ,expected ,failing-case ,description)) - (defmacro Assert-not-eql (testval expected &optional failing-case - description) - `(Assert-test-not eql ,testval ,expected ,failing-case ,description)) - (defmacro Assert-not-equal (testval expected &optional failing-case - description) - `(Assert-test-not equal ,testval ,expected ,failing-case ,description)) - (defmacro Assert-not-equalp (testval expected &optional failing-case - description) - `(Assert-test-not equalp ,testval ,expected ,failing-case ,description)) - (defmacro Assert-not-string= (testval expected &optional failing-case - description) - `(Assert-test-not string= ,testval ,expected ,failing-case ,description)) - (defmacro Assert-not= (testval expected &optional failing-case - description) - `(Assert-test-not = ,testval ,expected ,failing-case ,description)) - (defmacro Check-Error (expected-error &rest body) (let ((quoted-body (if (= 1 (length body)) `(quote ,(car body)) `(quote (progn ,@body)))))
--- a/lisp/update-elc.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/update-elc.el Mon Mar 29 21:28:13 2010 -0500 @@ -137,7 +137,7 @@ (defun update-elc-chop-extension (file) (if (string-match "\\.elc?$" file) - (substring file 0 (match-beginning 0)) + (subseq file 0 (match-beginning 0)) file)) ;; we used to call packages-list-autoloads here, but it's false generality.
--- a/lisp/x-win-xfree86.el Tue Feb 23 07:28:35 2010 -0600 +++ b/lisp/x-win-xfree86.el Mon Mar 29 21:28:13 2010 -0500 @@ -77,6 +77,9 @@ nil nil nil nil nil ?/ nil nil nil nil nil nil nil nil nil nil nil nil nil ?=]) + (when (x-keysym-on-keyboard-p 'iso-left-tab device) + (define-key function-key-map 'iso-left-tab [(shift tab)])) + (loop for (key sane-key) in '((f13 f1) (f14 f2)
--- a/man/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/man/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -4,6 +4,114 @@ * internals/internals.texi (Modules for other Display-Related Lisp Objects): objects*.[ch] -> fontcolor*.[ch]. +2010-03-18 Mike Sperber <mike@xemacs.org> + + * xemacs/startup.texi (Startup Paths): Reflect the (long-ago) + change from `lib' to `share' for the architecture-independent + directories. + +2010-03-13 Ben Wing <ben@xemacs.org> + + * internals/internals.texi (Working with Lisp Objects): + * internals/internals.texi (Writing Macros): + * internals/internals.texi (lrecords): + More rewriting to correspond with changes from + *LRECORD* to *LISP_OBJECT*. + +2010-03-05 Ben Wing <ben@xemacs.org> + + * internals/internals.texi (Introduction to Allocation): + * internals/internals.texi (Integers and Characters): + * internals/internals.texi (Allocation from Frob Blocks): + * internals/internals.texi (lrecords): + * internals/internals.texi (Low-level allocation): + Rewrite section on allocation of Lisp objects to reflect the new + reality. Remove references to nonexistent XSETINT and XSETCHAR. + +2010-03-04 Ben Wing <ben@xemacs.org> + + * internals/internals.texi (Top): + * internals/internals.texi (list-to-texinfo): Removed. + * internals/internals.texi (convert-list-to-texinfo): New. + * internals/internals.texi (table-to-texinfo): Removed. + * internals/internals.texi (convert-table-to-texinfo): New. + Update Lisp functions at top to newest versions. + + * internals/internals.texi (A History of Emacs): + * internals/internals.texi (Through Version 18): + * internals/internals.texi (Lucid Emacs): + * internals/internals.texi (XEmacs): + * internals/internals.texi (The XEmacs Split): + * internals/internals.texi (Modules for Other Aspects of the Lisp Interpreter and Object System): + * internals/internals.texi (Introduction to Writing C Code): + * internals/internals.texi (Writing Good Comments): + * internals/internals.texi (Writing Macros): + * internals/internals.texi (Major Textual Changes): + * internals/internals.texi (Great Integral Type Renaming): + * internals/internals.texi (How to Regression-Test): + * internals/internals.texi (Creating a Branch): + * internals/internals.texi (Dynamic Arrays): + * internals/internals.texi (Allocation by Blocks): + * internals/internals.texi (mark_object): + * internals/internals.texi (gc_sweep): + * internals/internals.texi (Byte-Char Position Conversion): + * internals/internals.texi (Searching and Matching): + * internals/internals.texi (Introduction to Multilingual Issues #3): + * internals/internals.texi (Byte Types): + * internals/internals.texi (Different Ways of Seeing Internal Text): + * internals/internals.texi (Buffer Positions): + * internals/internals.texi (Basic internal-format APIs): + * internals/internals.texi (The DFC API): + * internals/internals.texi (General Guidelines for Writing Mule-Aware Code): + * internals/internals.texi (Mule-izing Code): + * internals/internals.texi (Locales): + * internals/internals.texi (More about code pages): + * internals/internals.texi (More about locales): + * internals/internals.texi (Unicode support under Windows): + * internals/internals.texi (The Frame): + * internals/internals.texi (The Non-Client Area): + * internals/internals.texi (The Client Area): + * internals/internals.texi (The Paned Area): + * internals/internals.texi (Text Areas): + * internals/internals.texi (The Displayable Area): + * internals/internals.texi (Event Queues): + * internals/internals.texi (Event Stream Callback Routines): + * internals/internals.texi (Focus Handling): + * internals/internals.texi (Future Work -- Autodetection): + Replace " with ``, '' (not complete, maybe about halfway through). + +2010-03-03 Ben Wing <ben@xemacs.org> + + * internals/internals.texi (Intro to Window and Frame Geometry): + * internals/internals.texi (The Paned Area): + * internals/internals.texi (The Displayable Area): + Update to make note of e.g. the fact that the bottom gutter is + actually above the minibuffer. + +2010-03-02 Jerry James <james@xemacs.org> + + * custom.texi: Delete, redundant with xemacs/custom.texi and + lispref/customize.texi. + * Makefile: Remove all rules relating to custom.texi. + +2010-03-03 Aidan Kehoe <kehoea@parhasard.net> + + * lispref/tips.texi (Comment Tips): + * lispref/text.texi (Text Properties): + * lispref/strings.texi (Creating Strings): + * lispref/processes.texi (Input to Processes): + * lispref/functions.texi (Argument List): + * lispref/extents.texi (Duplicable Extents): + Move examples that used substring to using subseq; in + strings.texi, do not change the examples, but document that in + this XEmacs, it is an alias for subseq, and that there may be some + incompatibilities if you depend on that. + +2010-02-25 Didier Verna <didier@xemacs.org> + + The background-placement face property. + * xemacs/custom.texi (Faces): Document it. + 2010-02-20 Ben Wing <ben@xemacs.org> * internals/internals.texi (Intro to Window and Frame Geometry):
--- a/man/Makefile Tue Feb 23 07:28:35 2010 -0600 +++ b/man/Makefile Mon Mar 29 21:28:13 2010 -0500 @@ -46,7 +46,6 @@ info_files = \ $(INFODIR)/beta.info \ $(INFODIR)/cl.info \ - $(INFODIR)/custom.info \ $(INFODIR)/emodules.info \ $(INFODIR)/external-widget.info \ $(INFODIR)/info.info \ @@ -63,7 +62,6 @@ html_files = \ $(HTMLDIR)/beta.html \ $(HTMLDIR)/cl.html \ - $(HTMLDIR)/custom.html \ $(HTMLDIR)/emodules.html \ $(HTMLDIR)/external-widget.html \ $(HTMLDIR)/info.html \ @@ -80,7 +78,6 @@ dvi_files = \ beta.dvi \ cl.dvi \ - custom.dvi \ emodules.dvi \ external-widget.dvi \ info.dvi \ @@ -97,7 +94,6 @@ pdf_files = \ beta.pdf \ cl.pdf \ - custom.pdf \ emodules.pdf \ external-widget.pdf \ info.pdf \ @@ -245,9 +241,6 @@ $(INFODIR)/cl.info : cl.texi $(MAKEINFO) -o $(INFODIR)/cl.info cl.texi -$(INFODIR)/custom.info : custom.texi - $(MAKEINFO) -o $(INFODIR)/custom.info custom.texi - $(INFODIR)/emodules.info : emodules.texi $(MAKEINFO) -o $(INFODIR)/emodules.info emodules.texi @@ -353,9 +346,6 @@ $(HTMLDIR)/cl.html : cl.texi $(TEXI2HTML_SPLIT) cl.texi -$(HTMLDIR)/custom.html : custom.texi - $(TEXI2HTML_SPLIT) custom.texi - $(HTMLDIR)/emodules.html : emodules.texi $(TEXI2HTML_SPLIT) emodules.texi
--- a/man/custom.texi Tue Feb 23 07:28:35 2010 -0600 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,438 +0,0 @@ -\input texinfo.tex - -@c %**start of header -@setfilename ../info/custom.info -@settitle The Customization Library -@iftex -@afourpaper -@headings double -@end iftex -@c %**end of header - -@ifinfo -@dircategory XEmacs Editor -@direntry -* Customizations: (custom). Customization Library. -@end direntry -@end ifinfo - -@node Top, Declaring Groups, (dir), (dir) -@comment node-name, next, previous, up -@top The Customization Library - -This manual describes how to declare customization groups, variables, -and faces. It doesn't contain any examples, but please look at the file -@file{cus-edit.el} which contains many declarations you can learn from. - -@menu -* Declaring Groups:: -* Declaring Variables:: -* Declaring Faces:: -* Usage for Package Authors:: -* Utilities:: -* The Init File:: -* Wishlist:: -@end menu - -All the customization declarations can be changes by keyword arguments. -Groups, variables, and faces all share these common keywords: - -@table @code -@item :group -@var{value} should be a customization group. -Add @var{symbol} to that group. -@item :link -@var{value} should be a widget type. -Add @var{value} to the external links for this customization option. -Useful widget types include @code{custom-manual}, @code{info-link}, and -@code{url-link}. -@item :load -Add @var{value} to the files that should be loaded before displaying -this customization option. The value should be either a string, which -should be a string which will be loaded with @code{load-library} unless -present in @code{load-history}, or a symbol which will be loaded with -@code{require}. -@item :tag -@var{Value} should be a short string used for identifying the option in -customization menus and buffers. By default the tag will be -automatically created from the options name. -@end table - -@node Declaring Groups, Declaring Variables, Top, Top -@comment node-name, next, previous, up -@section Declaring Groups - -Use @code{defgroup} to declare new customization groups. - -@defun defgroup symbol members doc [keyword value]... -Declare @var{symbol} as a customization group containing @var{members}. -@var{symbol} does not need to be quoted. - -@var{doc} is the group documentation. - -@var{members} should be an alist of the form ((@var{name} -@var{widget})...) where @var{name} is a symbol and @var{widget} is a -widget for editing that symbol. Useful widgets are -@code{custom-variable} for editing variables, @code{custom-face} for -editing faces, and @code{custom-group} for editing groups.@refill - -Internally, custom uses the symbol property @code{custom-group} to keep -track of the group members, and @code{group-documentation} for the -documentation string. - -The following additional @var{keyword}'s are defined: - -@table @code -@item :prefix -@var{value} should be a string. If the string is a prefix for the name -of a member of the group, that prefix will be ignored when creating a -tag for that member. -@end table -@end defun - -@node Declaring Variables, Declaring Faces, Declaring Groups, Top -@comment node-name, next, previous, up -@section Declaring Variables - -Use @code{defcustom} to declare user editable variables. - -@defun defcustom symbol value doc [keyword value]... -Declare @var{symbol} as a customizable variable that defaults to @var{value}. -Neither @var{symbol} nor @var{value} needs to be quoted. -If @var{symbol} is not already bound, initialize it to @var{value}. - -@var{doc} is the variable documentation. - -The following additional @var{keyword}'s are defined: - -@table @code -@item :type -@var{value} should be a widget type. - -@item :options -@var{value} should be a list of possible members of the specified type. -For hooks, this is a list of function names. - -@item :initialize -@var{value} should be a function used to initialize the variable. It -takes two arguments, the symbol and value given in the @code{defcustom} call. -Some predefined functions are: - -@table @code -@item custom-initialize-set -Use the @code{:set} method to initialize the variable. Do not -initialize it if already bound. This is the default @code{:initialize} -method. - -@item custom-initialize-default -Always use @code{set-default} to initialize the variable, even if a -@code{:set} method has been specified. - -@item custom-initialize-reset -If the variable is already bound, reset it by calling the @code{:set} -method with the value returned by the @code{:get} method. - -@item custom-initialize-changed -Like @code{custom-initialize-reset}, but use @code{set-default} to -initialize the variable if it is not bound and has not been set -already. -@end table - -@item :set -@var{value} should be a function to set the value of the symbol. It -takes two arguments, the symbol to set and the value to give it. The -default is @code{set-default}. - -@item :get -@var{value} should be a function to extract the value of symbol. The -function takes one argument, a symbol, and should return the current -value for that symbol. The default is @code{default-value}. - -@item :require -@var{value} should be a feature symbol. Each feature will be required -when the `defcustom' is evaluated, or when Emacs is started if the user -has saved this option. - -@end table - -@xref{Sexp Types,,,widget,The Widget Library}, for information about -widgets to use together with the @code{:type} keyword. -@end defun - -Internally, custom uses the symbol property @code{custom-type} to keep -track of the variables type, @code{standard-value} for the program -specified default value, @code{saved-value} for a value saved by the -user, and @code{variable-documentation} for the documentation string. - -Use @code{custom-add-option} to specify that a specific function is -useful as a member of a hook. - -@defun custom-add-option symbol option -To the variable @var{symbol} add @var{option}. - -If @var{symbol} is a hook variable, @var{option} should be a hook -member. For other types of variables, the effect is undefined." -@end defun - -@node Declaring Faces, Usage for Package Authors, Declaring Variables, Top -@comment node-name, next, previous, up -@section Declaring Faces - -Faces are declared with @code{defface}. - -@defun defface face spec doc [keyword value]... - -Declare @var{face} as a customizable face that defaults to @var{spec}. -@var{face} does not need to be quoted. - -If @var{face} has been set with `custom-set-face', set the face attributes -as specified by that function, otherwise set the face attributes -according to @var{spec}. - -@var{doc} is the face documentation. - -@var{spec} should be an alist of the form @samp{((@var{display} @var{atts})...)}. - -@var{atts} is a list of face attributes and their values. The possible -attributes are defined in the variable `custom-face-attributes'. - -The @var{atts} of the first entry in @var{spec} where the @var{display} -matches the frame should take effect in that frame. @var{display} can -either be the symbol `t', which will match all frames, or an alist of -the form @samp{((@var{req} @var{item}...)...)}@refill - -For the @var{display} to match a FRAME, the @var{req} property of the -frame must match one of the @var{item}. The following @var{req} are -defined:@refill - -@table @code -@item type -(the value of (window-system))@* -Should be one of @code{x} or @code{tty}. - -@item class -(the frame's color support)@* -Should be one of @code{color}, @code{grayscale}, or @code{mono}. - -@item background -(what color is used for the background text)@* -Should be one of @code{light} or @code{dark}. -@end table - -Internally, custom uses the symbol property @code{face-defface-spec} for -the program specified default face properties, @code{saved-face} for -properties saved by the user, and @code{face-documentation} for the -documentation string.@refill - -@end defun - -@node Usage for Package Authors, Utilities, Declaring Faces, Top -@comment node-name, next, previous, up -@section Usage for Package Authors - -The recommended usage for the author of a typical emacs lisp package is -to create one group identifying the package, and make all user options -and faces members of that group. If the package has more than around 20 -such options, they should be divided into a number of subgroups, with -each subgroup being member of the top level group. - -The top level group for the package should itself be member of one or -more of the standard customization groups. There exists a group for -each @emph{finder} keyword. Press @kbd{C-h p} to see a list of finder -keywords, and add you group to each of them, using the @code{:group} -keyword. - -@node Utilities, The Init File, Usage for Package Authors, Top -@comment node-name, next, previous, up -@section Utilities - -These utilities can come in handy when adding customization support. - -@deffn Widget custom-manual -Widget type for specifying the info manual entry for a customization -option. It takes one argument, an info address. -@end deffn - -@defun custom-add-to-group group member widget -To existing @var{group} add a new @var{member} of type @var{widget}, -If there already is an entry for that member, overwrite it. -@end defun - -@defun custom-add-link symbol widget -To the custom option @var{symbol} add the link @var{widget}. -@end defun - -@defun custom-add-load symbol load -To the custom option @var{symbol} add the dependency @var{load}. -@var{load} should be either a library file name, or a feature name. -@end defun - -@defun customize-menu-create symbol &optional name -Create menu for customization group @var{symbol}. -If optional @var{name} is given, use that as the name of the menu. -Otherwise the menu will be named `Customize'. -The menu is in a format applicable to @code{easy-menu-define}. -@end defun - -@node The Init File, Wishlist, Utilities, Top -@comment node-name, next, previous, up -@section The Init File - -Customizations are saved to the file specified by @code{custom-file}, as -calls to @code{custom-set-variables} and @code{custom-set-faces}. - -When you save customizations, the current implementation removes the -calls to @code{custom-set-variables} and @code{custom-set-faces}, and -replaces them with code generated on the basis of the current -customization state in Emacs. - -By default @code{custom-file} is your @file{.emacs} file (for GNU Emacs -and older XEmacs) and is @file{custom.el} in the same directory as -@file{init.el} (in XEmacs 21.4 and later). If you use another file, you -must explicitly load it yourself. - -As of XEmacs 21.4.7, when @code{custom-file} is present, it is loaded -@emph{after} @file{init.el}. This is likely to change in the future, -because (1) actions in @file{init.el} often would like to depend on -customizations for consistent appearance and (2) Custom is quite brutal -about enforcing its idea of the correct values at initialization. - -@node Wishlist, , The Init File, Top -@comment node-name, next, previous, up -@section Wishlist - -@itemize @bullet -@item -Better support for keyboard operations in the customize buffer. - -@item -Integrate with @file{w3} so you can get customization buffers with much -better formatting. I'm thinking about adding a <custom>name</custom> -tag. The latest w3 have some support for this, so come up with a -convincing example. - -@item -Add an `examples' section, with explained examples of custom type -definitions. - -@item -Support selectable color themes. I.e., change many faces by setting one -variable. - -@item -Support undo using lmi's @file{gnus-undo.el}. - - -@item -Make it possible to append to `choice', `radio', and `set' options. - -@item -Ask whether set or modified variables should be saved in -@code{kill-buffer-hook}. - -Ditto for @code{kill-emacs-query-functions}. - -@item -Command to check if there are any customization options that -does not belong to an existing group. - -@item -Optionally disable the point-cursor and instead highlight the selected -item in XEmacs. This is like the *Completions* buffer in XEmacs. -Suggested by Jens Lautenbacher -@samp{<jens@@lemming0.lem.uni-karlsruhe.de>}.@refill - -@item -Explain why it is necessary that all choices have different default -values. - -@item -Add some direct support for meta variables, i.e. make it possible to -specify that this variable should be reset when that variable is -changed. - -@item -Add tutorial. - -@item -Describe the @code{:type} syntax in this manual. - -@item -Find a place is this manual for the following text: - -@strong{Radio vs. Buttons} - -Use a radio if you can't find a good way to describe the item in the -choice menu text. I.e. it is better to use a radio if you expect the -user would otherwise manually select each item from the choice menu in -turn to see what it expands too. - -Avoid radios if some of the items expands to complex structures. - -I mostly use radios when most of the items are of type -@code{function-item} or @code{variable-item}. - -@item -Update customize buffers when @code{custom-set-variable} or -@code{custom-save-customized} is called. - -@item -Better handling of saved but uninitialized items. - -@item -Detect when faces have been changed outside customize. - -@item -Enable mouse help in Emacs by default. - -@item -Add an easy way to display the standard settings when an item is modified. - -@item -See if it is feasible to scan files for customization information -instead of loading them, - -@item -Add hint message when user push a non-pushable tag. - -Suggest that the user unhide if hidden, and edit the value directly -otherwise. - -@item -Use checkboxes and radio buttons in the state menus. - -@item -Add option to hide @samp{[hide]} for short options. Default, on. - -@item -Add option to hide @samp{[state]} for options with their standard -settings. - -@item -There should be a way to specify site defaults for user options. - -@item -There should be more buffer styles. The default `nested style, the old -`outline' style, a `numeric' style with numbers instead of stars, an -`empty' style with just the group name, and `compact' with only one line -per item. - -@item -Newline and tab should be displayed as @samp{^J} and @samp{^I} in the -@code{regexp} and @code{file} widgets. I think this can be done in -XEmacs by adding a display table to the face. - -@item -Use glyphs to draw the @code{customize-browse} tree. - -Add echo and balloon help. You should be able to read the documentation -simply by moving the mouse pointer above the name. - -Add parent links. - -Add colors. - -@end itemize - -@contents -@bye
--- a/man/internals/internals.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/internals/internals.texi Mon Mar 29 21:28:13 2010 -0500 @@ -161,13 +161,13 @@ Note: to define these routines, put point after the end of the definition and type C-x C-e. -(defun list-to-texinfo (b e) +(defun convert-list-to-texinfo (b e) "Convert the selected region from an ASCII list to a Texinfo list." (interactive "r") (save-restriction (narrow-to-region b e) (goto-char (point-min)) - (let ((dash-type "^ *-+ +") + (let ((dash-type "^ *\\(-+\\|o\\) +") ;; allow single-letter numbering or roman numerals (letter-type "^ *[[(]?\\([a-zA-Z]\\|[IVXivx]+\\)[]).] +") (num-type "^ *[[(]?[0-9]+[]).] +") @@ -239,7 +239,7 @@ (forward-char min)) (kill-rectangle b (point)))))) -(defun table-to-texinfo (b e) +(defun convert-table-to-texinfo (b e) "Convert the selected region from an ASCII table to a Texinfo table. Assumes entries are separated by a blank line, and the first sexp in each entry is the table heading." @@ -283,20 +283,24 @@ in text: @code{} surrounded by ` and ' or followed by a (); @strong{} surrounded by *'s; @file{} something that looks like a file name." (interactive) - (if (and (not no-narrow) (region-active-p)) - (save-restriction - (narrow-to-region (region-beginning) (region-end)) - (convert-text-to-texinfo t)) - (let ((p (point)) - (case-replace nil)) - (query-replace-regexp "`\\([^']+\\)'\\([^']\\)" "@code{\\1}\\2" nil) - (goto-char p) - (query-replace-regexp "\\(\\Sw\\)\\*\\(\\(?:\\s_\\|\\sw\\)+\\)\\*\\([^A-Za-z.}]\\)" "\\1@strong{\\2}\\3" nil) - (goto-char p) - (query-replace-regexp "\\(\\(\\s_\\|\\sw\\)+()\\)\\([^}]\\)" "@code{\\1}\\3" nil) - (goto-char p) - (query-replace-regexp "\\(\\(\\s_\\|\\sw\\)+\\.[A-Za-z]+\\)\\([^A-Za-z.}]\\)" "@file{\\1}\\3" nil) - ))) + (save-excursion + (if (and (not no-narrow) (region-active-p)) + (save-restriction + (narrow-to-region (region-beginning) (region-end)) + (goto-char (region-beginning)) + (zmacs-deactivate-region) + (convert-text-to-texinfo t)) + (let ((p (point)) + (case-replace nil)) + (message "Point is %d" (point)) + (query-replace-regexp "`\\([^']+\\)'\\([^']\\)" "@code{\\1}\\2" nil) + (goto-char p) + (query-replace-regexp "\\(\\Sw\\)\\*\\(\\(?:\\s_\\|\\sw\\)+\\)\\*\\([^A-Za-z.}]\\)" "\\1@strong{\\2}\\3" nil) + (goto-char p) + (query-replace-regexp "\\(\\(\\s_\\|\\sw\\)+()\\)\\([^}]\\)" "@code{\\1}\\3" nil) + (goto-char p) + (query-replace-regexp "\\(\\(\\s_\\|\\sw\\)+\\.[A-Za-z]+\\)\\([^A-Za-z.}]\\)" "@file{\\1}\\3" nil) + )))) 4. Adding new sections: ----------------------- @@ -1238,7 +1242,7 @@ derived from GNU Emacs, a program written by Richard Stallman of the Free Software Foundation. GNU Emacs dates back to 1985 and was modelled after Unipress Emacs, an editor written by James Gosling in -1981 and based on a series of other "Emacs"-like editors, including +1981 and based on a series of other ``Emacs''-like editors, including EINE (EINE Is Not EMACS), c. 1976, by Dan Weinreb, which run on the MIT Lisp Machine and was the first Emacs written in Lisp; ZWEI (ZWEI Was EINE Initially), c. 1978, by Dan Weinreb and Mike McMahon; Multics @@ -1248,7 +1252,7 @@ later, TI Explorer (1983-1989). These in turn were inspired by the first Emacs, a package called EMACS, written in 1976 by Richard Stallman, Guy Steele, and Dave Moon. This was a merger of TECMAC and -TMACS, a pair of "TECO-macro realtime editors" written by Guy Steele, +TMACS, a pair of ``TECO-macro realtime editors'' written by Guy Steele, Dave Moon, Richard Greenblatt, Charles Frankston, et al., and added a dynamic loader and Meta-key cmds. It ran under ITS (the Incompatible Timesharing System) on a DEC PDP 10 and under TWENEX on a Tops-20 and @@ -1286,7 +1290,7 @@ the basis for the early versions of GNU Emacs and also for Gosling's Unipress Emacs, a commercial product. Because of bad blood between the two over the issue of commercialism, RMS pretty much disowned this -collaboration, referring to it as "Gosling Emacs". +collaboration, referring to it as ``Gosling Emacs''. At this point we pick up with a time line of events. (A broader timeline is available at @uref{http://www.jwz.org/doc/emacs-timeline.html, @@ -1577,9 +1581,9 @@ @item Version 19.9 released January 12, 1994. (Scrollbars, Athena.) @item -Version 19.10 released May 27, 1994. (Uses `configure'; code merged +Version 19.10 released May 27, 1994. (Uses @code{configure}; code merged from GNU Emacs 19.23 beta and further merging with Epoch 4.0) Known as -"Lucid Emacs" when shipped by Lucid, and as "XEmacs" when shipped by +``Lucid Emacs'' when shipped by Lucid, and as ``XEmacs'' when shipped by Sun; but Lucid went out of business a few days later and it's unclear very many copies of 19.10 were released by Lucid. (Last release by Jamie Zawinski.) @@ -1889,7 +1893,7 @@ Lucid scrollbar widget, 3-d modeline, stay-up Lucid menus, resizable minibuffer, echo area is a true buffer, MD5 hashing support, expanded menubar, redone menu specification format (including menu filters), -rewritten extents, renamed "screen" to "frame", misc-user events, +rewritten extents, renamed ``screen'' to ``frame'', misc-user events, rewritten face code, rewritten mouse code, warnings system, CL backquote syntax, critical C-g, code merging with GNU Emacs 19.28. New packages Hyperbole, OOBR, hm--html-menus, viper, lazy-lock, @@ -1937,9 +1941,9 @@ version 21.0.60 released December 10, 1998. (The version naming scheme was changed at this point: [a] the second version number is odd for stable versions, even for beta versions; [b] a third version number is added, -replacing the "beta xxx" ending for beta versions and allowing for +replacing the ``beta xxx'' ending for beta versions and allowing for periodic maintenance releases for stable versions. Therefore, 21.0 was -never "officially" released; similarly for 21.2, etc.) +never ``officially'' released; similarly for 21.2, etc.) @item version 21.0.61 released January 4, 1999. @item @@ -1955,7 +1959,7 @@ @item version 21.1.2 released May 14, 1999. (This is the followup to 21.0.67. The second version number was bumped to indicate the beginning of the -"stable" series.) +``stable'' series.) @item version 21.1.3 released June 26, 1999. @item @@ -2045,91 +2049,91 @@ @item version 21.2.40 released January 8, 2001. @item -version 21.2.41 "Polyhymnia" released January 17, 2001. -@item -version 21.2.42 "Poseidon" released January 20, 2001. -@item -version 21.2.43 "Terspichore" released January 26, 2001. -@item -version 21.2.44 "Thalia" released February 8, 2001. -@item -version 21.2.45 "Thelxepeia" released February 23, 2001. -@item -version 21.2.46 "Urania" released March 21, 2001. -@item -version 21.2.47 "Zephir" released April 14, 2001. -@item -XEmacs 21.4.0 "Solid Vapor" released April 16, 2001. -@item -XEmacs 21.4.1 "Copyleft" released April 19, 2001. -@item -XEmacs 21.4.2 "Developer-Friendly Unix APIs" released May 10, 2001. -@item -XEmacs 21.4.3 "Academic Rigor" released May 17, 2001. -@item -XEmacs 21.4.4 "Artificial Intelligence" released July 28, 2001. -@item -XEmacs 21.4.5 "Civil Service" released October 23, 2001. -@item -XEmacs 21.4.6 "Common Lisp" released December 17, 2001. -@item -XEmacs 21.4.7 "Economic Science" released May 4, 2002. -@item -XEmacs 21.4.8 "Honest Recruiter" released May 9, 2002. -@item -XEmacs 21.4.9 "Informed Management" released August 23, 2002. -@item -XEmacs 21.4.10 "Military Intelligence" released November 2, 2002. -@item -XEmacs 21.4.11 "Native Windows TTY Support" released January 3, 2003. -@item -XEmacs 21.4.12 "Portable Code" released January 15, 2003. -@item -XEmacs 21.4.13 "Rational FORTRAN" released May 25, 2003. -@item -XEmacs 21.4.14 "Reasonable Discussion" released September 3, 2003. -@item -XEmacs 21.4.15 "Security Through Obscurity" released February 2, 2004. -@item -XEmacs 21.4.16 "Successful IPO" released December 5, 2004. -@item -version 21.5.0 "alfalfa" released April 18, 2001. -@item -version 21.5.1 "anise" released May 9, 2001. -@item -version 21.5.2 "artichoke" released July 28, 2001. -@item -version 21.5.3 "asparagus" released September 7, 2001. -@item -version 21.5.4 "bamboo" released January 8, 2002. -@item -version 21.5.5 "beets" released March 5, 2002. -@item -version 21.5.6 "bok choi" released April 5, 2002. -@item -version 21.5.7 "broccoflower" released July 2, 2002. -@item -version 21.5.8 "broccoli" released July 27, 2002. -@item -version 21.5.9 "brussels sprouts" released August 30, 2002. -@item -version 21.5.10 "burdock" released January 4, 2003. -@item -version 21.5.11 "cabbage" released February 16, 2003. -@item -version 21.5.12 "carrot" released April 24, 2003. -@item -version 21.5.13 "cauliflower" released May 10, 2003. -@item -version 21.5.14 "cassava" released June 1, 2003. -@item -version 21.5.15 "celery" released September 3, 2003. -@item -version 21.5.16 "celeriac" released September 26, 2003. -@item -version 21.5.17 "chayote" released March 22, 2004. -@item -version 21.5.18 "chestnut" released October 22, 2004. +version 21.2.41 ``Polyhymnia'' released January 17, 2001. +@item +version 21.2.42 ``Poseidon'' released January 20, 2001. +@item +version 21.2.43 ``Terspichore'' released January 26, 2001. +@item +version 21.2.44 ``Thalia'' released February 8, 2001. +@item +version 21.2.45 ``Thelxepeia'' released February 23, 2001. +@item +version 21.2.46 ``Urania'' released March 21, 2001. +@item +version 21.2.47 ``Zephir'' released April 14, 2001. +@item +XEmacs 21.4.0 ``Solid Vapor'' released April 16, 2001. +@item +XEmacs 21.4.1 ``Copyleft'' released April 19, 2001. +@item +XEmacs 21.4.2 ``Developer-Friendly Unix APIs'' released May 10, 2001. +@item +XEmacs 21.4.3 ``Academic Rigor'' released May 17, 2001. +@item +XEmacs 21.4.4 ``Artificial Intelligence'' released July 28, 2001. +@item +XEmacs 21.4.5 ``Civil Service'' released October 23, 2001. +@item +XEmacs 21.4.6 ``Common Lisp'' released December 17, 2001. +@item +XEmacs 21.4.7 ``Economic Science'' released May 4, 2002. +@item +XEmacs 21.4.8 ``Honest Recruiter'' released May 9, 2002. +@item +XEmacs 21.4.9 ``Informed Management'' released August 23, 2002. +@item +XEmacs 21.4.10 ``Military Intelligence'' released November 2, 2002. +@item +XEmacs 21.4.11 ``Native Windows TTY Support'' released January 3, 2003. +@item +XEmacs 21.4.12 ``Portable Code'' released January 15, 2003. +@item +XEmacs 21.4.13 ``Rational FORTRAN'' released May 25, 2003. +@item +XEmacs 21.4.14 ``Reasonable Discussion'' released September 3, 2003. +@item +XEmacs 21.4.15 ``Security Through Obscurity'' released February 2, 2004. +@item +XEmacs 21.4.16 ``Successful IPO'' released December 5, 2004. +@item +version 21.5.0 ``alfalfa'' released April 18, 2001. +@item +version 21.5.1 ``anise'' released May 9, 2001. +@item +version 21.5.2 ``artichoke'' released July 28, 2001. +@item +version 21.5.3 ``asparagus'' released September 7, 2001. +@item +version 21.5.4 ``bamboo'' released January 8, 2002. +@item +version 21.5.5 ``beets'' released March 5, 2002. +@item +version 21.5.6 ``bok choi'' released April 5, 2002. +@item +version 21.5.7 ``broccoflower'' released July 2, 2002. +@item +version 21.5.8 ``broccoli'' released July 27, 2002. +@item +version 21.5.9 ``brussels sprouts'' released August 30, 2002. +@item +version 21.5.10 ``burdock'' released January 4, 2003. +@item +version 21.5.11 ``cabbage'' released February 16, 2003. +@item +version 21.5.12 ``carrot'' released April 24, 2003. +@item +version 21.5.13 ``cauliflower'' released May 10, 2003. +@item +version 21.5.14 ``cassava'' released June 1, 2003. +@item +version 21.5.15 ``celery'' released September 3, 2003. +@item +version 21.5.16 ``celeriac'' released September 26, 2003. +@item +version 21.5.17 ``chayote'' released March 22, 2004. +@item +version 21.5.18 ``chestnut'' released October 22, 2004. @end itemize @node The XEmacs Split, XEmacs from the Outside, A History of Emacs, Top @@ -2153,7 +2157,7 @@ hundreds of messages long and all of them coming from the XEmacs side. All have failed because they have eventually come to the same conclusion, which is that RMS has no real interest in cooperation at all. If you work with -him, you have to do it his way -- "my way or the highway". Specifically: +him, you have to do it his way -- ``my way or the highway''. Specifically: @enumerate @item @@ -4048,8 +4052,8 @@ @end display Then, the problem is that now we can't say that a sequence of -word-constituents makes up a word. For instance, both Hiragana "A" -and Kanji "KAN" are word-constituents but the sequence of these two +word-constituents makes up a word. For instance, both Hiragana ``A'' +and Kanji ``KAN'' are word-constituents but the sequence of these two letters can't be a single word. So, we introduced Sextword for Japanese letters. @@ -5008,7 +5012,7 @@ struct foobar; -go into the "types" section of lisp.h. +go into the ``types'' section of @file{lisp.h}. @end itemize @node Writing New Modules, Working with Lisp Objects, Introduction to Writing C Code, Rules When Writing New C Code @@ -5271,8 +5275,8 @@ returned (created using @samp{wrap_<type>}, if necessary). @c #### declaration -@item DECLARE_LRECORD (<type>, Lisp_<Type>) -Declares an @samp{lrecord} for @samp{<Type>}, which is the unit of +@item DECLARE_LISP_OBJECT (<type>, Lisp_<Type>) +Declares a Lisp object for @samp{<Type>}, which is the unit of allocation. @item #define X<TYPE>(x) XRECORD (x, <type>, Lisp_<Type>) @@ -5338,24 +5342,24 @@ @enumerate @item -create @var{foo}.h -@item -create @var{foo}.c -@item -add definitions of @code{syms_of_@var{foo}}, etc. to @file{@var{foo}.c} -@item -add declarations of @code{syms_of_@var{foo}}, etc. to @file{symsinit.h} -@item -add calls to @code{syms_of_@var{foo}}, etc. to @file{emacs.c} -@item -add definitions of macros like @code{CHECK_@var{FOO}} and +Create @var{foo}.h +@item +Create @var{foo}.c +@item +Add definitions of @code{syms_of_@var{foo}}, etc. to @file{@var{foo}.c} +@item +Add declarations of @code{syms_of_@var{foo}}, etc. to @file{symsinit.h} +@item +Add calls to @code{syms_of_@var{foo}}, etc. to @file{emacs.c} +@item +Add definitions of macros like @code{CHECK_@var{FOO}} and @code{@var{FOO}P} to @file{@var{foo}.h} @item -add the new type index to @code{enum lrecord_type} -@item -add a DEFINE_LRECORD_IMPLEMENTATION call to @file{@var{foo}.c} -@item -add an INIT_LRECORD_IMPLEMENTATION call to @code{syms_of_@var{foo}.c} +Add the new type index to @code{enum lrecord_type} +@item +Add a @code{DEFINE_*_LISP_OBJECT()} to @file{@var{foo}.c} +@item +Add an @code{INIT_LISP_OBJECT} call to @code{syms_of_@var{foo}.c} @end enumerate @@ -5666,7 +5670,7 @@ sure to update any comments to be correct -- or, at the very least, flag them as incorrect. -To indicate a "todo" or other problem, use four pound signs -- +To indicate a ``todo'' or other problem, use four pound signs -- i.e. @samp{####}. @node Adding Global Lisp Variables, Writing Macros, Writing Good Comments, Rules When Writing New C Code @@ -5838,11 +5842,12 @@ @cindex inline functions, headers @cindex header files, inline functions Every header which contains inline functions, either directly by using -@code{DECLARE_INLINE_HEADER} or indirectly by using @code{DECLARE_LRECORD} must -be added to @file{inline.c}'s includes to make the optimization -described above work. (Optimization note: if all INLINE_HEADER -functions are in fact inlined in all translation units, then the linker -can just discard @code{inline.o}, since it contains only unreferenced code). +@code{DECLARE_INLINE_HEADER} or indirectly by using +@code{DECLARE_LISP_OBJECT} must be added to @file{inline.c}'s includes +to make the optimization described above work. (Optimization note: if +all INLINE_HEADER functions are in fact inlined in all translation +units, then the linker can just discard @code{inline.o}, since it +contains only unreferenced code). The three golden rules of macros: @@ -5851,7 +5856,7 @@ Anything that's an lvalue can be evaluated more than once. @item Macros where anything else can be evaluated more than once should -have the word "unsafe" in their name (exceptions may be made for +have the word ``unsafe'' in their name (exceptions may be made for large sets of macros that evaluate arguments of certain types more than once, e.g. struct buffer * arguments, when clearly indicated in the macro documentation). These macros are generally meant to be @@ -5883,7 +5888,7 @@ reference. @item Capitalize macros that evaluate @strong{any} argument more than once regardless -of whether that's "allowed" (e.g. buffer arguments). +of whether that's ``allowed'' (e.g. buffer arguments). @item Capitalize macros that directly access a field in a Lisp_Object or its equivalent underlying structure. In such cases, access through the @@ -5938,8 +5943,8 @@ will just lead to headaches. But it's important to keep the code clean and understandable, and consistent naming goes a long way towards this. -An example of the right way to do this was the so-called "great integral -type renaming". +An example of the right way to do this was the so-called ``great integral +type renaming''. @menu * Great Integral Type Renaming:: @@ -5966,13 +5971,13 @@ people disagree vociferously with this, but their arguments are mostly theoretical, and are vastly outweighed by the practical headaches of mixing signed and unsigned values, and more importantly by the far -increased likelihood of inadvertent bugs: Because of the broken "viral" +increased likelihood of inadvertent bugs: Because of the broken ``viral'' nature of unsigned quantities in C (operations involving mixed signed/unsigned are done unsigned, when exactly the opposite is nearly always wanted), even a single error in declaring a quantity unsigned that should be signed, or even the even more subtle error of comparing signed and unsigned values and forgetting the necessary cast, can be -catastrophic, as comparisons will yield wrong results. -Wsign-compare +catastrophic, as comparisons will yield wrong results. @samp{-Wsign-compare} is turned on specifically to catch this, but this tends to result in a great number of warnings when mixing signed and unsigned, and the casts are annoying. More has been written on this elsewhere. @@ -5991,17 +5996,17 @@ all be avoided. @item -"count" == a zero-based measurement of some quantity. Includes sizes, +``count'' == a zero-based measurement of some quantity. Includes sizes, offsets, and indexes. @item -"bpos" == a one-based measurement of a position in a buffer. "Charbpos" -and "Bytebpos" count text in the buffer, rather than bytes in memory; +``bpos'' == a one-based measurement of a position in a buffer. ``Charbpos'' +and ``Bytebpos'' count text in the buffer, rather than bytes in memory; thus Bytebpos does not directly correspond to the memory representation. -Use "Membpos" for this. - -@item -"Char" refers to internal-format characters, not to the C type "char", +Use ``Membpos'' for this. + +@item +``Char'' refers to internal-format characters, not to the C type ``char'', which is really a byte. @end itemize @@ -6096,7 +6101,7 @@ /* The have been some arguments over the what the type should be that specifies a count of bytes in a data block to be written out or read in, using @code{Lstream_read()}, @code{Lstream_write()}, and related functions. - Originally it was long, which worked fine; Martin "corrected" these to + Originally it was long, which worked fine; Martin ``corrected'' these to size_t and ssize_t on the grounds that this is theoretically cleaner and is in keeping with the C standards. Unfortunately, this practice is horribly error-prone due to design flaws in the way that mixed @@ -6471,7 +6476,7 @@ @deffn Macro Known-Bug-Expect-Failure body Arrange for failing tests in @var{body} to generate messages prefixed -with "KNOWN BUG:" instead of "FAIL:". @var{body} is a @code{progn}-like +with ``KNOWN BUG:'' instead of ``FAIL:''. @var{body} is a @code{progn}-like body, and may contain several tests. @end deffn @@ -6652,7 +6657,7 @@ adds and deletes on the main line, which you do not want at all. Therefore, you must undo all adds and deletes. To find out what is added and deleted, use something like @code{cvs -n update >&! -cvs.out}, which does a "dry run". (You did make a backup copy first, +cvs.out}, which does a ``dry run''. (You did make a backup copy first, right? What if you forgot the @samp{-n}, for example, and wasn't prepared for the sudden onslaught of merging action?) Take a look at the output file @file{cvs.out} and check very carefully for newly @@ -6684,7 +6689,7 @@ Note that this doesn't actually do anything to your local workspace! It basically just creates another tag in the repository, identical to -the branch point tag but internally marked as a "branch tag" rather +the branch point tag but internally marked as a ``branch tag'' rather than a regular tag. @item @@ -7018,13 +7023,13 @@ mechanism. -A "dynamic array" is a contiguous array of fixed-size elements where there +A ``dynamic array'' is a contiguous array of fixed-size elements where there is no upper limit (except available memory) on the number of elements in the array. Because the elements are maintained contiguously, space is used efficiently (no per-element pointers necessary) and random access to a particular element is in constant time. At any one point, the block of memory that holds the array has an upper limit; if this limit is exceeded, the -memory is realloc()ed into a new array that is twice as big. Assuming that +memory is @code{realloc()}ed into a new array that is twice as big. Assuming that the time to grow the array is on the order of the new size of the array block, this scheme has a provably constant amortized time (i.e. average time over all additions). @@ -7132,10 +7137,10 @@ addition. -A "block-type object" is used to efficiently allocate and free blocks +A ``block-type object'' is used to efficiently allocate and free blocks of a particular size. Freed blocks are remembered in a free list and are reused as necessary to allocate new blocks, so as to avoid as -much as possible making calls to malloc() and free(). +much as possible making calls to @code{malloc()} and @code{free()}. This is a container object. Declare a block-type object of a specific type as follows: @@ -7752,7 +7757,7 @@ @code{GCPRO}ed. @end itemize - In the remaining two categories, the type is stored in the object +In the remaining two categories, the type is stored in the object itself. The tag for all such objects is the generic @dfn{lrecord} (Lisp_Type_Record) tag. The first bytes of the object's structure are an integer (actually a char) characterising the object's type and some @@ -8277,7 +8282,7 @@ Now, the actual marking is feasible. We do so by once using the macro @code{MARK_RECORD_HEADER} to mark the object itself (actually the special flag in the lrecord header), and calling its special marker -"method" @code{marker} if available. The marker method marks every +``method'' @code{marker} if available. The marker method marks every other object that is in reach from our current object. Note, that these marker methods should not call @code{mark_object} recursively, but instead should return the next object from where further marking has to @@ -8332,7 +8337,7 @@ @code{sweep_symbols}, @code{sweep_extents}, @code{sweep_markers} and @code{sweep_extents}. They are the fixed-size types cons, floats, compiled-functions, symbol, marker, extent, and event stored in -so-called "frob blocks", and therefore we can basically do the same on +so-called ``frob blocks'', and therefore we can basically do the same on every type objects, using the same macros, especially defined only to handle everything with respect to fixed-size blocks. The only fixed-size type that is not handled here are the fixed-size portion of strings, @@ -8488,45 +8493,40 @@ @cindex integers and characters @cindex characters, integers and - Integer and character Lisp objects are created from integers using the -macros @code{XSETINT()} and @code{XSETCHAR()} or the equivalent +Integer and character Lisp objects are created from integers using the functions @code{make_int()} and @code{make_char()}. (These are actually macros on most systems.) These functions basically just do some moving of bits around, since the integral value of the object is stored directly in the @code{Lisp_Object}. - @code{XSETINT()} and the like will truncate values given to them that -are too big; i.e. you won't get the value you expected but the tag bits -will at least be correct. - @node Allocation from Frob Blocks, lrecords, Integers and Characters, Allocation of Objects in XEmacs Lisp @section Allocation from Frob Blocks @cindex allocation from frob blocks @cindex frob blocks, allocation from -The uninitialized memory required by a @code{Lisp_Object} of a particular type -is allocated using -@code{ALLOCATE_FIXED_TYPE()}. This only occurs inside of the -lowest-level object-creating functions in @file{alloc.c}: -@code{Fcons()}, @code{make_float()}, @code{Fmake_byte_code()}, -@code{Fmake_symbol()}, @code{allocate_extent()}, -@code{allocate_event()}, @code{Fmake_marker()}, and -@code{make_uninit_string()}. The idea is that, for each type, there are -a number of frob blocks (each 2K in size); each frob block is divided up -into object-sized chunks. Each frob block will have some of these -chunks that are currently assigned to objects, and perhaps some that are -free. (If a frob block has nothing but free chunks, it is freed at the -end of the garbage collection cycle.) The free chunks are stored in a -free list, which is chained by storing a pointer in the first four bytes -of the chunk. (Except for the free chunks at the end of the last frob -block, which are handled using an index which points past the end of the +The uninitialized memory required by a @code{Lisp_Object} of a +particular type is allocated using @code{ALLOCATE_FIXED_TYPE()}. This +only occurs inside of the lowest-level object-creating functions in +@file{alloc.c}: @code{Fcons()}, @code{make_float()}, +@code{Fmake_byte_code()}, @code{Fmake_symbol()}, +@code{allocate_extent()}, @code{allocate_event()}, +@code{Fmake_marker()}, and @code{make_uninit_string()}. The idea is +that, for each type, there are a number of frob blocks (each 2K in +size); each frob block is divided up into object-sized chunks. Each +frob block will have some of these chunks that are currently assigned +to objects, and perhaps some that are free. (If a frob block has +nothing but free chunks, it is freed at the end of the garbage +collection cycle.) The free chunks are stored in a free list, which +is chained by storing a pointer in the first four bytes of the +chunk. (Except for the free chunks at the end of the last frob block, +which are handled using an index which points past the end of the last-allocated chunk in the last frob block.) @code{ALLOCATE_FIXED_TYPE()} first tries to retrieve a chunk from the free list; if that fails, it calls @code{ALLOCATE_FIXED_TYPE_FROM_BLOCK()}, which looks at the end of the last frob block for space, and creates a new frob block if there is -none. (There are actually two versions of these macros, one of which is -more defensive but less efficient and is used for error-checking.) +none. (There are actually two versions of these macros, one of which +is more defensive but less efficient and is used for error-checking.) @node lrecords, Low-level allocation, Allocation from Frob Blocks, Allocation of Objects in XEmacs Lisp @section lrecords @@ -8537,7 +8537,7 @@ @strong{This node needs updating for the ``new garbage collection algorithms'' (KKCC) and the ``incremental'' collector.} - All lrecords have at the beginning of their structure a @code{struct +All lrecords have at the beginning of their structure a @code{struct lrecord_header}. This just contains a type number and some flags, including the mark bit. All builtin type numbers are defined as constants in @code{enum lrecord_type}, to allow the compiler to generate @@ -8546,39 +8546,35 @@ lrecord_implementation}, which is a structure containing method pointers and such. There is one of these for each type, and it is a global, constant, statically-declared structure that is declared in the -@code{DEFINE_LRECORD_IMPLEMENTATION()} macro. - - Simple lrecords (of type (b) above) just have a @code{struct -lrecord_header} at their beginning. lcrecords, however, actually have a -@code{struct lcrecord_header}. This, in turn, has a @code{struct +@code{DEFINE_*_LISP_OBJECT()} macro. + +Frob-block lrecords just have a @code{struct lrecord_header} at their +beginning. lcrecords, however, actually have a +@code{struct old_lcrecord_header}. This, in turn, has a @code{struct lrecord_header} at its beginning, so sanity is preserved; but it also -has a pointer used to chain all lcrecords together, and a special ID -field used to distinguish one lcrecord from another. (This field is used -only for debugging and could be removed, but the space gain is not -significant.) +has a pointer used to chain all lcrecords together. @strong{lcrecords are now obsolete when using the write-barrier-based collector.} - Simple lrecords are created using @code{ALLOCATE_FIXED_TYPE()}, just -like for other frob blocks. The only change is that the implementation -pointer must be initialized correctly. (The implementation structure for -an lrecord, or rather the pointer to it, is named @code{lrecord_float}, -@code{lrecord_extent}, @code{lrecord_buffer}, etc.) - - lcrecords are created using @code{alloc_lcrecord()}. This takes a -size to allocate and an implementation pointer. (The size needs to be -passed because some lcrecords, such as window configurations, are of -variable size.) This basically just @code{malloc()}s the storage, -initializes the @code{struct lcrecord_header}, and chains the lcrecord -onto the head of the list of all lcrecords, which is stored in the -variable @code{all_lcrecords}. The calls to @code{alloc_lcrecord()} -generally occur in the lowest-level allocation function for each lrecord -type. - -Whenever you create an lrecord, you need to call either -@code{DEFINE_LRECORD_IMPLEMENTATION()} or -@code{DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION()}. This needs to be +Frob-block objects are created using @code{ALLOC_FROB_BLOCK_LISP_OBJECT()}. +All this does is call @code{ALLOCATE_FIXED_TYPE()} to allocate an +object, and @code{set_lheader_implementation()} to initialize the header. + +Normal objects (i.e. lcrecords) are created using +@code{ALLOC_NORMAL_LISP_OBJECT()}, which takes a type name (resolved +internally to a structure named @code{lrecord_foo} for type +@code{foo}). If they are of variable size, however, they are created +with @code{ALLOC_SIZED_LISP_OBJECT()}, which takes a size to allocate +in addition to a type. This basically just @code{malloc()}s the +storage, initializes the @code{struct lcrecord_header}, and chains the +lcrecord onto the head of the list of all lcrecords, which is stored +in the variable @code{all_lcrecords}. The calls to the above +allocation macros generally occur in the lowest-level allocation +function for each lrecord type. + +Whenever you create a normal object, you need to call one of the +@code{DEFINE_*_LISP_OBJECT()} macros. This needs to be specified in a @file{.c} file, at the top level. What this actually does is define and initialize the implementation structure for the lrecord. (And possibly declares a function @code{error_check_foo()} that @@ -8595,26 +8591,73 @@ to add new object types without having to add a specific case for each new type in a bunch of different places. - The difference between @code{DEFINE_LRECORD_IMPLEMENTATION()} and -@code{DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION()} is that the former is -used for fixed-size object types and the latter is for variable-size -object types. Most object types are fixed-size; some complex -types, however (e.g. window configurations), are variable-size. -Variable-size object types have an extra method, which is called -to determine the actual size of a particular object of that type. -(Currently this is only used for keeping allocation statistics.) - - For the purpose of keeping allocation statistics, the allocation +The various macros for defining Lisp objects are as follows: + +@itemize @bullet +@item +@code{DEFINE_*_LISP_OBJECT} is for objects with constant size. (Either +@code{DEFINE_DUMPABLE_LISP_OBJECT} for objects that can be saved in a +dumped executable, or @code{DEFINE_NODUMP_LISP_OBJECT} for objects +that cannot be saved -- e.g. that contain pointers to non-persistent +external objects such as window-system windows.) + +@item +@code{DEFINE_*_SIZABLE_LISP_OBJECT} is for objects whose size varies. +This includes some simple types such as vectors, bit vectors and +opaque objects, as well complex types, especially types such as +specifiers, lstreams or coding systems that have subtypes and include +subtype-specific data attached to the end of the structure. +Variable-size objects have an extra method that returns the size of +the object. This is not used at allocation (rather, the size is +specified in the call to the allocation macro), but is used for +operations such as copying a Lisp object, as well as for keeping +allocation statistics. + +@item +@code{DEFINE_*_FROB_BLOCK_LISP_OBJECT} is for objects that are +allocated in large blocks (``frob blocks''), which are parceled up +individually. Such objects need special handling in @file{alloc.c}. +This does not apply to NEW_GC, because it does this automatically. + +@item +@code{DEFINE_*_INTERNAL_LISP_OBJECT} is for ``internal'' objects that +should never be visible on the Lisp level. This is a shorthand for +the most common type of internal objects, which have no equal or hash +method (since they generally won't appear in hash tables), no +finalizer and @code{internal_object_printer()} as their print method +(which prints that the object is internal and shouldn't be visible +externally). For internal objects needing a finalizer, equal or hash +method, or wanting to customize the print method, use the normal +@code{DEFINE_*_LISP_OBJECT} mechanism for defining these objects. + +@item +@code{DEFINE_*_GENERAL_LISP_OBJECT} is for objects that need to +provide one of the less common methods that are omitted on most +objects. These methods include the methods supporting the unified +property interface using @code{get}, @code{put}, @code{remprop} and +@code{object-plist}, and (for dumpable objects only) the +@code{disksaver} method. + +@item +@code{DEFINE_MODULE_*} is for objects defined in an external module. +@end itemize + +@code{MAKE_LISP_OBJECT} and @code{MAKE_MODULE_LISP_OBJECT} are what +underlies all of these; they define a structure containing pointers to +object methods and other info such as the size of the structure +containing the object. + +For the purpose of keeping allocation statistics, the allocation engine keeps a list of all the different types that exist. Note that, -since @code{DEFINE_LRECORD_IMPLEMENTATION()} is a macro that is -specified at top-level, there is no way for it to initialize the global -data structures containing type information, like +since @code{DEFINE_*_LISP_OBJECT()} is a macro that is +specified at top-level, there is no way for it to initialize the +global data structures containing type information, like @code{lrecord_implementations_table}. For this reason a call to -@code{INIT_LRECORD_IMPLEMENTATION} must be added to the same source file -containing @code{DEFINE_LRECORD_IMPLEMENTATION}, but instead of to the -top level, to one of the init functions, typically -@code{syms_of_@var{foo}.c}. @code{INIT_LRECORD_IMPLEMENTATION} must be -called before an object of this type is used. +@code{INIT_LISP_OBJECT()} must be added to the same source +file containing @code{DEFINE_*_LISP_OBJECT()}, but instead of +to the top level, to one of the init functions, typically +@code{syms_of_@var{foo}.c}. @code{INIT_LISP_OBJECT()} must +be called before an object of this type is used. The type number is also used to index into an array holding the number of objects of each type and the total memory allocated for objects of @@ -8622,24 +8665,25 @@ stage. These statistics are returned by the call to @code{garbage-collect}. - Note that for every type defined with a @code{DEFINE_LRECORD_*()} -macro, there needs to be a @code{DECLARE_LRECORD_IMPLEMENTATION()} -somewhere in a @file{.h} file, and this @file{.h} file needs to be -included by @file{inline.c}. - - Furthermore, there should generally be a set of @code{XFOOBAR()}, -@code{FOOBARP()}, etc. macros in a @file{.h} (or occasionally @file{.c}) -file. To create one of these, copy an existing model and modify as -necessary. - - @strong{Please note:} If you define an lrecord in an external -dynamically-loaded module, you must use @code{DECLARE_EXTERNAL_LRECORD}, -@code{DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION}, and -@code{DEFINE_EXTERNAL_LRECORD_SEQUENCE_IMPLEMENTATION} instead of the -non-EXTERNAL forms. These macros will dynamically add new type numbers -to the global enum that records them, whereas the non-EXTERNAL forms -assume that the programmer has already inserted the correct type numbers -into the enum's code at compile-time. +Note that for every type defined with a @code{DEFINE_*_LISP_OBJECT()} +macro, there needs to be a @code{DECLARE_LISP_OBJECT()} somewhere in a +@file{.h} file, and this @file{.h} file needs to be included by +@file{inline.c}. + +Furthermore, there should generally be a set of @code{XFOOBAR()}, +@code{FOOBARP()}, etc. macros in a @file{.h} (or occasionally +@file{.c}) file. To create one of these, copy an existing model and +modify as necessary. + +@strong{Please note:} If you define an lrecord in an external +dynamically-loaded module, you must use +@code{DECLARE_MODULE_LISP_OBJECT()}, +@code{DEFINE_MODULE_*_LISP_OBJECT()}, and +@code{INIT_MODULE_LISP_OBJECT()} instead of the non-MODULE +forms. These macros will dynamically add new type numbers to the +global enum that records them, whereas the non-MODULE forms assume +that the programmer has already inserted the correct type numbers into +the enum's code at compile-time. The various methods in the lrecord implementation structure are: @@ -8703,25 +8747,18 @@ The finalize method can be NULL if nothing needs to be done. -WARNING #1: The finalize method is also called at the end of the dump -phase; this time with the for_disksave parameter set to non-zero. The -object is @emph{not} about to disappear, so you have to make sure to -@emph{not} free any extra @code{malloc()}ed memory if you're going to -need it later. (Also, signal an error if there are any operating-system -and window-system resources here, because they can't be dumped.) - Finalize methods should, as a rule, set to zero any pointers after -they've been freed, and check to make sure pointers are not zero before -freeing. Although I'm pretty sure that finalize methods are not called -twice on the same object (except for the @code{for_disksave} proviso), -we've gotten nastily burned in some cases by not doing this. - -WARNING #2: The finalize method is @emph{only} called for -lcrecords, @emph{not} for simply lrecords. If you need a -finalize method for simple lrecords, you have to stick +they've been freed, and check to make sure pointers are not zero +before freeing. Although I'm pretty sure that finalize methods are +not called twice on the same object, we've gotten nastily burned in +some cases by not doing this. + +WARNING #1: The finalize method is @emph{only} called for +normal objects, @emph{not} for frob-block objects. If you need a +finalize method for frob-block objects, you have to stick it in the @code{ADDITIONAL_FREE_foo()} macro in @file{alloc.c}. -WARNING #3: Things are in an @emph{extremely} bizarre state +WARNING #2: Things are in an @emph{extremely} bizarre state when @code{ADDITIONAL_FREE_foo()} is called, so you have to be incredibly careful when writing one of these functions. See the comment in @code{gc_sweep()}. If you ever have to add @@ -8761,17 +8798,33 @@ @item @dfn{getprop}, @dfn{putprop}, @dfn{remprop}, and @dfn{plist} methods. -These are used for object types that have properties. I don't feel like -documenting them here. If you create one of these objects, you have to -use different macros to define them, -i.e. @code{DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS()} or -@code{DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS()}. +These are used for object types that have properties, and are called +when @code{get}, @code{put}, @code{remprop}, and @code{object-plist}, +respectively are called on the object. If you create one of these +objects, you have to use a different macro to define them, +i.e. @code{DEFINE_*_GENERAL_LISP_OBJECT()}. @item A @dfn{size_in_bytes} method, when the object is of variable-size. -(i.e. declared with a @code{_SEQUENCE_IMPLEMENTATION} macro.) This should -simply return the object's size in bytes, exactly as you might expect. -For an example, see the methods for window configurations and opaques. +(i.e. declared with a @code{DEFINE_*_SIZABLE_*_LISP_OBJECT} macro.) +This should simply return the object's size in bytes, exactly as you +might expect. For an example, see the methods for lstreams and opaques. + +@item +A @dfn{disksave} method. This is called at the end of the dump phase. +It is used for objects that contain pointers or handles to objects +created in external libraries, such as window-system windows or file +handles. Such external objects cannot be dumped, so it is necessary +to release them at dump time and arrange somehow or other for them to +be resurrected if necessary later on. + +It seems that even non-dumpable objects may be around at dump time, +and a disksaver may be provided. (In fact, the only object currently +with a disksaver, lstream, is non-dumpable.) + +Objects rarely need to provide this method; most of the time it will +be NULL. If you want to provide this method, you have to use the +@code{DEFINE_*_GENERAL_LISP_OBJECT()} macro to define your object. @end enumerate @node Low-level allocation, Cons, lrecords, Allocation of Objects in XEmacs Lisp @@ -10006,7 +10059,7 @@ BEGV, and ZV, and in addition to this we cache 16 positions where the conversion is known. We only look in the cache or update it when we need to move the known region more than a certain amount (currently 50 -chars), and then we throw away a "random" value and replace it with the +chars), and then we throw away a ``random'' value and replace it with the newly calculated value. Finally, we maintain an extra flag that tracks whether the buffer is @@ -10042,7 +10095,7 @@ original value. Dividing by 3, alas, cannot be implemented in any simple shift/subtract method, as far as I know; so we just do a table lookup. For simplicity, we use a table of size 128K, which indexes the -"divide-by-3" values for the first 64K non-negative numbers. (Note that +``divide-by-3'' values for the first 64K non-negative numbers. (Note that we can increase the size up to 384K, i.e. indexing the first 192K non-negative numbers, while still using shorts in the array.) This also means that the size of the known region can be at most 64K for @@ -10072,7 +10125,7 @@ @item the last value we computed @item -a set of positions that are "far away" from previously computed positions +a set of positions that are ``far away'' from previously computed positions (5000 chars currently; #### perhaps should be smaller) @end itemize @@ -10098,7 +10151,7 @@ @code{charcount_to_bytecount_down()}. (The latter two I added for this purpose.) These scan 4 or 8 bytes at a time through purely single-byte characters. -If the amount we had to scan was more than our "far away" distance (5000 +If the amount we had to scan was more than our ``far away'' distance (5000 characters, see above), then cache the new position. #### Things to do: @@ -10108,7 +10161,7 @@ Look at the most recent GNU Emacs to see whether anything has changed. @item Think about whether it makes sense to try to implement some sort of -known region or list of "known regions", like we had before. This would +known region or list of ``known regions'', like we had before. This would be a region of entirely single-byte characters that we can check very quickly. (Previously I used a range of same-width characters of any size; but this adds extra complexity and slows down the scanning, and is @@ -10326,7 +10379,7 @@ @enumerate @item -An explicit "failure stack" has been substituted for recursion. +An explicit ``failure stack'' has been substituted for recursion. @item The @code{match_1_operator}, @code{next_p}, and @code{next_b} functions @@ -10339,7 +10392,7 @@ @item Some cases are combined into short preparation for individual cases, and -a "fall-through" into combined code for several cases. +a ``fall-through'' into combined code for several cases. @item The @code{pattern} type is not an explicit @samp{struct}. Instead, the @@ -10358,7 +10411,7 @@ @end example @end enumerate -But if you keep your eye on the "switch in a loop" structure, you +But if you keep your eye on the ``switch in a loop'' structure, you should be able to understand the parts you need. @node Multilingual Support, Consoles; Devices; Frames; Windows, Text, Top @@ -10820,7 +10873,7 @@ its code point. For more complicated charsets, however, things are not so obvious. Unicode version 2, for example, is a large charset with thousands of characters, each indexed by a 16-bit number, often -represented in hex, e.g. 0x05D0 for the Hebrew letter "aleph". One +represented in hex, e.g. 0x05D0 for the Hebrew letter ``aleph''. One obvious encoding uses two bytes per character (actually two encodings, depending on which of the two possible byte orderings is chosen). This encoding is convenient for internal processing of Unicode text; however, @@ -10841,10 +10894,10 @@ There are 256 characters, and each character is represented using the numbers 0 through 255, which fit into a single byte. With a few exceptions (such as case-changing operations or syntax classes like -'whitespace'), "text" is simply an array of indices into a font. You +@code{whitespace}), ``text'' is simply an array of indices into a font. You can get different languages simply by choosing fonts with different 8-bit character sets (ISO-8859-1, -2, special-symbol fonts, etc.), and -everything will "just work" as long as anyone else receiving your text +everything will ``just work'' as long as anyone else receiving your text uses a compatible font. In the multi-lingual world, however, it is much more complicated. There @@ -10894,8 +10947,8 @@ assumptions can reliably be made about the format of this text. You cannot assume, for example, that the end of text is terminated by a null byte. (For example, if the text is Unicode, it will have many null bytes -in it.) You cannot find the next "slash" character by searching through -the bytes until you find a byte that looks like a "slash" character, +in it.) You cannot find the next ``slash'' character by searching through +the bytes until you find a byte that looks like a ``slash'' character, because it might actually be the second byte of a Kanji character. Furthermore, all text in the internal representation must be converted, even if it is known to be completely ASCII, because the external @@ -10925,7 +10978,7 @@ system aliases, which in essence gives a single coding system two different names. It is effectively used in XEmacs to provide a layer of abstraction on top of the actual coding systems. For example, the coding -system alias "file-name" points to whichever coding system is currently +system alias ``file-name'' points to whichever coding system is currently used for encoding and decoding file names as passed to or retrieved from system calls. In general, the actual encoding will differ from system to system, and also on the particular locale that the user is in. The use @@ -11436,8 +11489,8 @@ S = signed @end example -(Formerly I had a comment saying that type (e) "should be replaced with -void *". However, there are in fact many places where an unsigned char +(Formerly I had a comment saying that type (e) ``should be replaced with +void *''. However, there are in fact many places where an unsigned char * might be used -- e.g. for ease in pointer computation, since void * doesn't allow this, and for compatibility with external APIs.) @@ -11458,8 +11511,8 @@ @cindex different ways of seeing internal text There are various ways of representing internal text. The two primary -ways are as an "array" of individual characters; the other is as a -"stream" of bytes. In the ASCII world, where there are only 255 +ways are as an ``array'' of individual characters; the other is as a +``stream'' of bytes. In the ASCII world, where there are only 255 characters at most, things are easy because each character fits into a byte. In general, however, this is not true -- see the above discussion of characters vs. encodings. @@ -11467,12 +11520,12 @@ In some cases, it's also important to distinguish between a stream representation as a series of bytes and as a series of textual units. This is particularly important wrt Unicode. The UTF-16 representation -(sometimes referred to, rather sloppily, as simply the "Unicode" format) +(sometimes referred to, rather sloppily, as simply the ``Unicode'' format) represents text as a series of 16-bit units. Mostly, each unit corresponds to a single character, but not necessarily, as characters -outside of the range 0-65535 (the BMP or "Basic Multilingual Plane" of +outside of the range 0-65535 (the BMP or ``Basic Multilingual Plane'' of Unicode) require two 16-bit units, through the mechanism of -"surrogates". When a series of 16-bit units is serialized into a byte +``surrogates''. When a series of 16-bit units is serialized into a byte stream, there are at least two possible representations, little-endian and big-endian, and which one is used may depend on the native format of 16-bit integers in the CPU of the machine that XEmacs is running @@ -11489,10 +11542,10 @@ @item UTF-32 has 4-byte (32-bit) units. @item -XEmacs-internal encoding (the old "Mule" encoding) has 1-byte (8-bit) +XEmacs-internal encoding (the old ``Mule'' encoding) has 1-byte (8-bit) units. @item -UTF-7 technically has 7-bit units that are within the "mail-safe" range +UTF-7 technically has 7-bit units that are within the ``mail-safe'' range (ASCII 32 - 126 plus a few control characters), but normally is encoded in an 8-bit stream. (UTF-7 is also a modal encoding, since it has a normal mode where printable ASCII characters represent themselves and a @@ -11557,7 +11610,7 @@ The data in a buffer or string is logically made up of Ibyte objects, where a Ibyte takes up the same amount of space as a char. (It is declared differently, though, to catch invalid usages.) Strings stored -using Ibytes are said to be in "internal format". The important +using Ibytes are said to be in ``internal format''. The important characteristics of internal format are @itemize @minus @@ -11610,11 +11663,11 @@ 8-bit representation of ASCII/ISO-8859-1. @item Extbyte -Strings that go in or out of Emacs are in "external format", typedef'ed +Strings that go in or out of Emacs are in ``external format'', typedef'ed as an array of char or a char *. There is more than one external format (JIS, EUC, etc.) but they all have similar properties. They are modal encodings, which is to say that the meaning of particular bytes is not -fixed but depends on what "mode" the string is currently in (e.g. bytes +fixed but depends on what ``mode'' the string is currently in (e.g. bytes in the range 0 - 0x7f might be interpreted as ASCII, or as Hiragana, or as 2-byte Kanji, depending on the current mode). The mode starts out in ASCII/ISO-8859-1 and is switched using escape sequences -- for example, @@ -11644,7 +11697,7 @@ of these are one-based: the beginning of the buffer is position or index 1, and 0 is not a valid position. -As a "buffer position" (typedef Charbpos): +As a ``buffer position'' (typedef Charbpos): This is an index specifying an offset in characters from the beginning of the buffer. Note that buffer positions are @@ -11653,7 +11706,7 @@ characters between those positions. Buffer positions are the only kind of position externally visible to the user. -As a "byte index" (typedef Bytebpos): +As a ``byte index'' (typedef Bytebpos): This is an index over the bytes used to represent the characters in the buffer. If there is no Mule support, this is identical @@ -11663,7 +11716,7 @@ byte index may be greater than the corresponding buffer position. -As a "memory index" (typedef Membpos): +As a ``memory index'' (typedef Membpos): This is the byte index adjusted for the gap. For positions before the gap, this is identical to the byte index. For @@ -11672,7 +11725,7 @@ position; the memory index at the beginning of the gap should always be used, except in code that deals with manipulating the gap, where both indices may be seen. The address of the - character "at" (i.e. following) a particular position can be + character ``at'' (i.e. following) a particular position can be obtained from the formula buffer_start_address + memory_index(position) - 1 @@ -11781,7 +11834,7 @@ Some terminology: -"itext" appearing in the macros means "internal-format text" -- type +itext" appearing in the macros means "internal-format text" -- type @code{Ibyte *}. Operations on such pointers themselves, rather than on the text being pointed to, have "itext" instead of "itext" in the macro name. "ichar" in the macro names means an Ichar -- the representation @@ -11990,7 +12043,7 @@ @end itemize Turned out that all of the above had bugs, all caused by GCC (hence the -comments about "those GCC wankers" and "ream gcc up the ass"). As for +comments about ``those GCC wankers'' and ``ream gcc up the ass''). As for (a), some versions of GCC (especially on Intel platforms), which had buggy implementations of @code{alloca()} that couldn't handle being called inside of a function call -- they just decremented the stack right in the @@ -12973,7 +13026,7 @@ @item Extbyte, UExtbyte Pointer to text in some external format, which can be defined as all formats other than the internal one. The data representing a string -in "external" format (binary or any external encoding) is logically a +in ``external'' format (binary or any external encoding) is logically a set of Extbytes. Extbyte is guaranteed to be just a char, so for example strlen (Extbyte *) is OK. Extbyte is only a documentation device for referring to external text. @@ -13117,7 +13170,7 @@ @subsection Mule-izing Code A lot of code is written without Mule in mind, and needs to be made -Mule-correct or "Mule-ized". There is really no substitute for +Mule-correct or ``Mule-ized''. There is really no substitute for line-by-line analysis when doing this, but the following checklist can help: @@ -13335,23 +13388,23 @@ @end enumerate @node Locales, More about code pages, Microsoft Documentation, Microsoft Windows-Related Multilingual Issues -@subsection Locales, code pages, and other concepts of "language" -@cindex locales, code pages, and other concepts of "language" +@subsection Locales, code pages, and other concepts of ``language'' +@cindex locales, code pages, and other concepts of ``language'' First, make sure you clearly understand the difference between the C runtime library (CRT) and the Win32 API! See win32.c. There are various different ways of representing the vague concept -of "language", and it can be very confusing. So: - -@itemize @bullet -@item -The CRT library has the concept of "locale", which is a +of ``language'', and it can be very confusing. So: + +@itemize @bullet +@item +The CRT library has the concept of ``locale'', which is a combination of language and country, and which controls the way currency and dates are displayed, the encoding of data, etc. @item -XEmacs has the concept of "language environment", more or less +XEmacs has the concept of ``language environment'', more or less like a locale; although currently in most cases it just refers to the language, and no sub-language distinctions are made. (Exceptions are with Chinese, which has different language @@ -13363,23 +13416,23 @@ @enumerate @item -There are "languages" and "sublanguages", which correspond to +There are ``languages'' and ``sublanguages'', which correspond to the languages and countries of the C library -- e.g. LANG_ENGLISH and SUBLANG_ENGLISH_US. These are identified by 8-bit integers, -called the "primary language identifier" and "sublanguage -identifier", respectively. These are combined into a 16-bit -integer or "language identifier" by MAKELANGID(). - -@item -The language identifier in turn is combined with a "sort -identifier" (and optionally a "sort version") to yield a 32-bit -integer called a "locale identifier" (type LCID), which identifies +called the ``primary language identifier'' and ``sublanguage +identifier'', respectively. These are combined into a 16-bit +integer or ``language identifier'' by @code{MAKELANGID()}. + +@item +The language identifier in turn is combined with a ``sort +identifier'' (and optionally a ``sort version'') to yield a 32-bit +integer called a ``locale identifier'' (type LCID), which identifies locales -- the primary means of distinguishing language/regional settings and similar to C library locales. @item -A "code page" combines the XEmacs concepts of "charset" and "coding -system". It logically encompasses +A ``code page'' combines the XEmacs concepts of ``charset'' and ``coding +system''. It logically encompasses @itemize @minus @item @@ -13392,12 +13445,12 @@ a way of encoding a series of characters into a string of bytes @end itemize -Note that the first two properties correspond to an XEmacs "charset" -and the latter an XEmacs "coding system". +Note that the first two properties correspond to an XEmacs ``charset'' +and the latter an XEmacs ``coding system''. Traditional encodings are either simple one-byte encodings, or combination one-byte/two-byte encodings (aka MBCS encodings, where MBCS -stands for "Multibyte Character Set") with the following properties: +stands for ``Multibyte Character Set'') with the following properties: @itemize @minus @item @@ -13407,7 +13460,7 @@ @item the lower 128 bytes are compatible with ASCII @item -in the higher bytes, the value of the first byte ("lead byte") +in the higher bytes, the value of the first byte (``lead byte'') determines whether a second byte follows @item the values used for second bytes may overlap those used for first @@ -13429,22 +13482,22 @@ native code page under Windows), OEM (a DOS encoding, still used in the FAT file system), Mac (an encoding used on the Macintosh) and EBCDIC (a non-ASCII-compatible encoding used on IBM mainframes, originally based -on the BCD or "binary-coded decimal" encoding of numbers). All code +on the BCD or ``binary-coded decimal'' encoding of numbers). All code pages associated with a locale follow (as far as I know) the properties listed above for traditional code pages. More than one locale can share a code page -- e.g. all the Western European languages, including English, do. @item -Windows also has an "input locale identifier" (aka "keyboard -layout id") or HKL, which is a 32-bit integer composed of the -16-bit language identifier and a 16-bit "device identifier", which +Windows also has an ``input locale identifier'' (aka ``keyboard +layout id'') or HKL, which is a 32-bit integer composed of the +16-bit language identifier and a 16-bit ``device identifier'', which originally specified a particular keyboard layout (e.g. the locale -"US English" can have the QWERTY layout, the Dvorak layout, etc.), +``US English'' can have the QWERTY layout, the Dvorak layout, etc.), but has been expanded to include speech-to-text converters and other non-keyboard ways of inputting text. Note that both the HKL and LCID share the language identifier in the lower 16 bits, and in -both cases a 0 in the upper 16 bits means "default" (sort order or +both cases a 0 in the upper 16 bits means ``default'' (sort order or device), providing a way to convert between HKL's, LCID's, and language identifiers (i.e. language/sublanguage pairs). The default keyboard layout for a language is (as far as I can @@ -13462,7 +13515,7 @@ @subsection More about code pages @cindex more about code pages -Here is what MSDN says about code pages (article "Code Pages"): +Here is what MSDN says about code pages (article ``Code Pages''): @quotation A code page is a character set, which can include numbers, @@ -13504,10 +13557,10 @@ which C programs have traditionally executed. The code page for the "C" locale (code page) corresponds to the ASCII character set. For example, in the "C" locale, islower returns true for the -values 0x61 ?0x7A only. In another locale, islower may return true +values 0x61 to 0x7A only. In another locale, islower may return true for these as well as other values, as defined by that locale. -Under "Locale-Dependent Routines" we notice the following setlocale +Under ``Locale-Dependent Routines'' we notice the following setlocale dependencies: atof, atoi, atol (LC_NUMERIC) @@ -13540,8 +13593,8 @@ _wtoi/_wtol (LC_NUMERIC) @end quotation -NOTE: The above documentation doesn't clearly explain the "locale code -page" and "multibyte code page". These are two different values, +NOTE: The above documentation doesn't clearly explain the ``locale code +page'' and ``multibyte code page''. These are two different values, maintained respectively in the CRT global variables __lc_codepage and __mbcodepage. Calling e.g. setlocale (LC_ALL, "JAPANESE") sets @strong{ONLY} __lc_codepage to 932 (the code page for Japanese), and leaves @@ -13551,12 +13604,12 @@ @itemize @bullet @item -from "Interpretation of Multibyte-Character Sequences" it appears that -all "multibyte-character routines" use the multibyte code page except for -mblen(), _mbstrlen(), mbstowcs(), mbtowc(), wcstombs(), and wctomb(). - -@item -from "_setmbcp": "The multibyte code page also affects +from ``Interpretation of Multibyte-Character Sequences'' it appears that +all ``multibyte-character routines'' use the multibyte code page except for +@code{mblen()}, @code{_mbstrlen()}, @code{mbstowcs()}, @code{mbtowc()}, @code{wcstombs()}, and @code{wctomb()}. + +@item +from ``_setmbcp'': ``The multibyte code page also affects multibyte-character processing by the following run-time library routines: _exec functions _mktemp _stat _fullpath _spawn functions _tempnam _makepath _splitpath tmpnam. In addition, all run-time library @@ -13564,7 +13617,7 @@ as parameters (such as the _exec and _spawn families) process these strings according to the multibyte code page. Hence these routines are also affected by a call to _setmbcp that changes the multibyte code -page." +page.'' @end itemize Summary: from looking at the CRT source (which comes with VC++) and @@ -13572,15 +13625,15 @@ @itemize @bullet @item -the "locale code page" is used by all of the routines listed above -under "Locale-Dependent Routines" (EXCEPT _mbccpy() and _mbclen()), +the ``locale code page'' is used by all of the routines listed above +under ``Locale-Dependent Routines'' (EXCEPT @code{_mbccpy()} and @code{_mbclen()}), as well as any other place that converts between multibyte and Unicode strings, e.g. the startup code. @item -the "multibyte code page" is used in all of the *mb*() routines -except mblen(), _mbstrlen(), mbstowcs(), mbtowc(), wcstombs(), -and wctomb(); also _exec*(), _spawn*(), _mktemp(), _stat(), _fullpath(), -_tempnam(), _makepath(), _splitpath(), tmpnam(), and similar functions +the ``multibyte code page'' is used in all of the @code{mb*()} routines +except @code{mblen()}, @code{_mbstrlen()}, @code{mbstowcs()}, @code{mbtowc()}, @code{wcstombs()}, +and @code{wctomb()}; also @code{_exec*()}, @code{_spawn*()}, @code{_mktemp()}, @code{_stat()}, @code{_fullpath()}, +@code{_tempnam()}, @code{_makepath()}, @code{_splitpath()}, @code{tmpnam()}, and similar functions without the leading underscore. @end itemize @@ -13593,16 +13646,16 @@ @itemize @bullet @item -The system-default locale is the locale defined under "Language -settings for the system" in the "Regional Options" control panel. This +The system-default locale is the locale defined under ``Language +settings for the system'' in the ``Regional Options'' control panel. This is NOT user-specific, and changing it requires a reboot (at least under Windows 2000). The ANSI code page of the system-default locale is -returned by GetACP(), and you can specify this code page in calls +returned by @code{GetACP()}, and you can specify this code page in calls e.g. to MultiByteToWideChar with the constant CP_ACP. @item -The user-default locale is the locale defined under "Settings for the -current user" in the "Regional Options" control panel. +The user-default locale is the locale defined under ``Settings for the +current user'' in the ``Regional Options'' control panel. @item There is a thread-local locale set by SetThreadLocale. #### What is this @@ -13610,11 +13663,11 @@ @end itemize The Win32 API has a bunch of multibyte functions -- all of those that -end with ...A(), and on which we spend so much effort in +end with ...@code{A()}, and on which we spend so much effort in intl-encap-win32.c. These appear to ALWAYS use the ANSI code page of -the system-default locale (GetACP(), CP_ACP). Note that this applies +the system-default locale (@code{GetACP()}, CP_ACP). Note that this applies also, for example, to the encoding of filenames in all file-handling -routines, including the CRT ones such as open(), because they pass their +routines, including the CRT ones such as @code{open()}, because they pass their args unchanged to the Win32 API. @node Unicode support under Windows, The golden rules of writing Unicode-safe code, More about locales, Microsoft Windows-Related Multilingual Issues @@ -13632,20 +13685,20 @@ Under Windows there are two different versions of all library routines that accept or return text, those that handle Unicode text and those handling -"multibyte" text, i.e. variable-width ASCII-compatible text in some +``multibyte'' text, i.e. variable-width ASCII-compatible text in some national format such as EUC or Shift-JIS. Because Windows 95 basically doesn't support Unicode but Windows NT does, and Microsoft doesn't provide any way of writing a single binary that will work on both systems and still use Unicode when it's available (although see below, Microsoft Layer for Unicode), we need to provide a way of run-time conditionalizing so you -could have one binary for both systems. "Unicode-splitting" refers to +could have one binary for both systems. ``Unicode-splitting'' refers to writing code that will handle this properly. This means using Qmswindows_tstr as the external conversion format, calling the appropriate qxe...() Unicode-split version of library functions, and doing other things -in certain cases, e.g. when a qxe() function is not present. +in certain cases, e.g. when a @code{qxe()} function is not present. Unicode support also requires that the various Windows APIs be -"Unicode-encapsulated", so that they automatically call the ANSI or +``Unicode-encapsulated'', so that they automatically call the ANSI or Unicode version of the API call appropriately and handle the size differences in structures. What this means is: @@ -13653,7 +13706,7 @@ @item first, note that Windows already provides a sort of encapsulation of all APIs that deal with text. All such APIs are underlyingly -provided in two versions, with an A or W suffix (ANSI or "wide" +provided in two versions, with an A or W suffix (ANSI or ``wide'' i.e. Unicode), and the compile-time constant UNICODE controls which is selected by the unsuffixed API. Same thing happens with structures, and also with types, where the generic types have names beginning with T -- @@ -13672,7 +13725,7 @@ @item what we do is provide an encapsulation of each standard Windows API call that is split into A and W versions. current theory is to avoid all -preprocessor games; so we name the function with a prefix -- "qxe" +preprocessor games; so we name the function with a prefix -- ``qxe'' currently -- and require callers to use the prefixed name. Callers need to explicitly use the W version of all structures, and convert text themselves using Qmswindows_tstr. the qxe encapsulated version will @@ -13732,8 +13785,8 @@ think twice before doing this. According to Microsoft documentation, only the following functions are -provided under Windows 9x to support Unicode (see MSDN page "Windows -95/98/Me General Limitations"): +provided under Windows 9x to support Unicode (see MSDN page ``Windows +95/98/Me General Limitations''): EnumResourceLanguagesW EnumResourceNamesW @@ -13754,8 +13807,8 @@ TextOutW WideCharToMultiByte -also maybe GetTextExtentExPoint? (KB Q125671 "Unicode Functions Supported -by Windows 95") +also maybe GetTextExtentExPoint? (KB Q125671 ``Unicode Functions Supported +by Windows 95'') Q210341 says this in addition: @@ -13780,7 +13833,7 @@ The Unicode standard offers application developers an opportunity to work with text without the limitations of character set based systems. For more information on the Unicode standard see the -"References" section of this article. Windows NT is a fully Unicode +References" section of this article. Windows NT is a fully Unicode capable operating system so it may be desirable to write software that supports Unicode on Windows 95. @@ -13863,12 +13916,12 @@ wmain() is completely supported, and appropriate Unicode-formatted argv and envp will always be passed. @item -Likewise, wWinMain() is completely supported. (NOTE: The docs are not at +Likewise, @code{wWinMain()} is completely supported. (NOTE: The docs are not at all clear on how these various entry points interact, and implies that -a windows-subsystem program "must" use WinMain(), while a console- -subsystem program "must" use main(), and a program compiled with UNICODE -(which we don't, see above) "must" use the w*() versions, while a program -not compiled this way "must" use the plain versions. In fact it appears +a windows-subsystem program ``must'' use @code{WinMain()}, while a console- +subsystem program ``must'' use @code{main()}, and a program compiled with UNICODE +(which we don't, see above) ``must'' use the @code{w*()} versions, while a program +not compiled this way ``must'' use the plain versions. In fact it appears that the CRT provides four different compiler entry points, namely w?(main|WinMain)CRTStartup, and we simply choose the one we like using the appropriate link flag. @@ -17890,69 +17943,72 @@ | ###################################################################### | | # toolbar # | | #--------------------------------------------------------------------# | -| # | gutter | # | -| # |--------------------------------------------------------------| # | -| # | | internal border width | | # | -| # | | ******************************************************** | | # | -|w# | | * |s|v* |s* | | #w| -|i# | | * |c|e* |c* | | #i| -|n# | | * |r|r* |r* | | #n| -|d# | | * |o|t* |o* | | #d| -|o# | | * text area |l|.* text area |l* | | #o| -|w# | |i* |l| * |l*i| | #w| -|-# | |n* |b|d* |b*n| | #-| -|m# | |t* |a|i* |a*t| | #m| -|a# | |.* |r|v* |r*.| | #a| -|n# t| | *-------------------------+-|i*----------------------+-* | |t #n| -|a# o|g|b* scrollbar | |d* scrollbar | *b|g|o #a| -|g# o|u|o*-------------------------+-|e*----------------------+-*o|u|o #g| -|e# l|t|r* modeline |r* modeline *r|t|l #e| -|r# b|t|d********************************************************d|t|b #r| -| # a|e|e* =..texttexttex....= |s|v* |s*e|e|a # | -|d# r|r|r*o m=..texttexttextt..=o m|c|e* |c*r|r|r #d| -|e# | | *u a=.exttexttextte...=u a|r|r* |r* | | #e| -|c# | |w*t r=....texttexttex..=t r|o|t* |o*w| | #c| -|o# | |i*s g= etc. =s g|l|.* text area |l*i| | #o| -|r# | |d*i i= =i i|l| * |l*d| | #r| -|a# | |t*d n= =d n|b|d* |b*t| | #a| -|t# | |h*e = inner text area =e |a|i* |a*h| | #t| +| # | internal border | # | +| # | +----------------------------------------------------------+ | # | +| # | | gutter | | # | +| # | |-********************************************************-| | # | +|w# | | *@| scrollbar |v* |s* | | #w| +|i# | | *-+-------------------------|e* |c* | | #i| +|n# | | *s| |r* |r* | | #n| +|d# | | *c| |t* |o* | | #d| +|o# | | *r| |.* text area |l* | | #o| +|w# |i| *o| | * |l* |i| #w| +|-# |n| *l| text area |d* |b* |n| #-| +|m# |t| *l| |i* |a* |t| #m| +|a# |e| *b| |v* |r* |e| #a| +|n# t|r| *a| |i*----------------------+-* |r|t #n| +|a# o|n|g*r| |d* scrollbar |@*g|n|o #a| +|g# o|a|u*-+-------------------------|e*----------------------+-*u|a|o #g| +|e# l|l|t* modeline |r* modeline *t|l|l #e| +|r# b| |t********************************************************t| |b #r| +| # a|b|e* =..texttexttex....= |s|v* |s*e|b|a # | +|d# r|o|r*o m=..texttexttextt..=o m|c|e* |c*r|o|r #d| +|e# |r| *u a=.exttexttextte...=u a|r|r* |r* |r| #e| +|c# |d| *t r=....texttexttex..=t r|o|t* |o* |d| #c| +|o# |e| *s g= etc. =s g|l|.* text area |l* |e| #o| +|r# |r| *i i= =i i|l| * |l* |r| #r| +|a# | | *d n= =d n|b|d* |b* | | #a| +|t# | | *e = inner text area =e |a|i* |a* | | #t| |i# | | * = = |r|v* |r* | | #i| |o# | | *---===================---+-|i*----------------------+-* | | #o| -|n# | | * scrollbar | |d* scrollbar | * | | #n| +|n# | | * scrollbar |@|d* scrollbar |@* | | #n| | # | | *-------------------------+-|e*----------------------+-* | | # | | # | | * modeline |r* modeline * | | # | -| # | | ******************************************************** | | # | -| # | | * minibuffer * | | # | -| # | | ******************************************************** | | # | -| # | | internal border width | | # | -| # |--------------------------------------------------------------| # | -| # | gutter | # | +| # | |-********************************************************-| | # | +| # | | gutter | | # | +| # | |-********************************************************-| | # | +| # | |@* minibuffer *@| | # | +| # | +-********************************************************-+ | # | +| # | internal border | # | | #--------------------------------------------------------------------# | | # toolbar # | | ###################################################################### | | window manager decoration | +------------------------------------------------------------------------+ - # = boundary of client area; * = window boundaries, boundary of paned area - = = boundary of inner text area; . = inside margin area -@end example - -Note in particular what happens at the corners, where a "corner box" +# = boundary of client area; * = window boundaries, boundary of paned area += = boundary of inner text area; . = inside margin area; @ = dead boxes +@end example + +Note in particular what happens at the corners, where a ``corner box'' occurs. Top and bottom toolbars take precedence over left and right toolbars, extending out horizontally into the corner boxes. Gutters work the same way. The corner box where the scrollbars meet, however, -is assigned to neither scrollbar, and is known as the "dead box"; it is -an area that must be cleared specially. +is assigned to neither scrollbar, and is known as the ``dead box''; it is +an area that must be cleared specially. There are similar dead boxes at +the bottom-right and bottom-left corners where the minibuffer and +left/right gutters meet, but there is currently a bug in that these dead +boxes are not explicitly cleared and may contain junk. @node The Frame, The Non-Client Area, Intro to Window and Frame Geometry, Window and Frame Geometry @section The Frame -The "top-level window area" is the entire area of a top-level window (or -"frame"). The "client area" (a term from MS Windows) is the area of a +The ``top-level window area'' is the entire area of a top-level window (or +``frame''). The ``client area'' (a term from MS Windows) is the area of a top-level window that XEmacs draws into and manages with redisplay. This includes the toolbar, scrollbars, gutters, dividers, text area, modeline and minibuffer. It does not include the menubar, title or -outer borders. The "non-client area" is the area of a top-level window +outer borders. The ``non-client area'' is the area of a top-level window outside of the client area and includes the menubar, title and outer borders. Internally, all frame coordinates are relative to the client area. @@ -17969,7 +18025,7 @@ borders. These are controlled by the window manager, a separate process that controls the desktop, the location of icons, etc. When a process tries to create a window, the window manager intercepts this action and -"reparents" the window, placing another window around it which contains +``reparents'' the window, placing another window around it which contains the window decorations, including the title bar, outer borders used for resizing, etc. The window manager also implements any actions involving the decorations, such as the ability to resize a window by dragging its @@ -17979,12 +18035,12 @@ move or resize them. @item -Inside of the window-manager decorations is the "shell", which is +Inside of the window-manager decorations is the ``shell'', which is managed by the toolkit and widget libraries your program is linked with. The code in @file{*-x.c} uses the Xt toolkit and various possible widget -libraries built on top of Xt, such as Motif, Athena, the "Lucid" +libraries built on top of Xt, such as Motif, Athena, the ``Lucid'' widgets, etc. Another possibility is GTK (@file{*-gtk.c}), which implements -both the toolkit and widgets. Under Xt, the "shell" window is an +both the toolkit and widgets. Under Xt, the ``shell'' window is an EmacsShell widget, containing an EmacsManager widget of the same size, which in turn contains a menubar widget and an EmacsFrame widget, inside of which is the client area. (The division into EmacsShell and @@ -18000,10 +18056,10 @@ There is no division such as under X. Part of the window-system API (@file{USER.DLL}) of Win32 includes functions to control the menubars, title, etc. and implements the move and resize behavior. There @strong{is} an -equivalent of the window manager, called the "shell", but it manages +equivalent of the window manager, called the ``shell'', but it manages only the desktop, not the windows themselves. The normal shell under Windows is @file{EXPLORER.EXE}; if you kill this, you will lose the bar -containing the "Start" menu and tray and such, but the windows +containing the ``Start'' menu and tray and such, but the windows themselves will not be affected or lose their decorations. @@ -18012,14 +18068,14 @@ Inside of the client area is the toolbars, the gutters (where the buffer tabs are displayed), the minibuffer, the internal border width, and one -or more non-overlapping "windows" (this is old Emacs terminology, from +or more non-overlapping ``windows'' (this is old Emacs terminology, from before the time when frames existed at all; the standard terminology for -this would be "pane"). Each window can contain a modeline, horizontal +this would be ``pane''). Each window can contain a modeline, horizontal and/or vertical scrollbars, and (for non-rightmost windows) a vertical divider, surrounding a text area. The dimensions of the toolbars and gutters are determined by the formula -(THICKNESS + 2 * BORDER-THICKNESS), where "thickness" is a cover term +(THICKNESS + 2 * BORDER-THICKNESS), where ``thickness'' is a cover term for height or width, as appropriate. The height and width come from @code{default-toolbar-height} and @code{default-toolbar-width} and the specific versions of these (@code{top-toolbar-height}, @code{left-toolbar-width}, etc.). @@ -18044,13 +18100,19 @@ @node The Paned Area, Text Areas, The Client Area, Window and Frame Geometry @section The Paned Area -The area occupied by the "windows" is called the paned area. Note that -this includes the minibuffer, which is just another window but is -special-cased in XEmacs. Each window can include a horizontal and/or -vertical scrollbar, a modeline and a vertical divider to its right, as -well as the text area. Only non-rightmost windows can include a -vertical divider. (The minibuffer normally does not include either -modeline or scrollbars.) +The area occupied by the ``windows'' is called the paned area. +Unfortunately, because of the presence of the gutter @strong{between} the +minibuffer and other windows, the bottom of the paned area is not +well-defined -- does it include the minibuffer (in which case it also +includes the bottom gutter, but none others) or does it not include +the minibuffer? (In which case not all windows are included.) It would +be cleaner to put the bottom gutter @strong{below} the minibuffer instead of +above it. + +Each window can include a horizontal and/or vertical scrollbar, a +modeline and a vertical divider to its right, as well as the text area. +Only non-rightmost windows can include a vertical divider. (The +minibuffer normally does not include either modeline or scrollbars.) Note that, because the toolbars and gutters are controlled by specifiers, and specifiers can have window-specific and buffer-specific @@ -18073,7 +18135,7 @@ In addition, it is possible to set margins in the text area using the specifiers @code{left-margin-width} and @code{right-margin-width}. When this is -done, only the "inner text area" (the area inside of the margins) will +done, only the ``inner text area'' (the area inside of the margins) will be used for normal display of text; the margins will be used for glyphs with a layout policy of @code{outside-margin} (as set on an extent containing the glyph by @code{set-extent-begin-glyph-layout} or @@ -18084,7 +18146,7 @@ etc.), using the left and right margins, respectively. Technically, the margins outside of the inner text area are known as the -"outside margins". The "inside margins" are in the inner text area and +``outside margins''. The ``inside margins'' are in the inner text area and constitute the whitespace between the outside margins and the first or last non-whitespace character in a line; their width can vary from line to line. Glyphs will be placed in the inside margin if their layout @@ -18099,31 +18161,36 @@ @node The Displayable Area, Which Functions Use Which?, Text Areas, Window and Frame Geometry @section The Displayable Area -The "displayable area" is not so much an actual area as a convenient +The ``displayable area'' is not so much an actual area as a convenient fiction. It is the area used to convert between pixel and character dimensions for frames. The character dimensions for a frame (e.g. as returned by @code{frame-width} and @code{frame-height} and set by @code{set-frame-width} and @code{set-frame-height}) are determined from the displayable area by dividing by the pixel size of the default font as -instantiated in the frame. (For proportional fonts, the "average" width +instantiated in the frame. (For proportional fonts, the ``average'' width is used. Under Windows, this is a built-in property of the fonts. Under X, this is based on the width of the lowercase 'n', or if this is zero then the width of the default character. [We prefer 'n' to the specified default character because many X fonts have a default character with a zero or otherwise non-representative width.]) -The displayable area is essentially the "theoretical" paned area of the -frame excluding the rightmost and bottom-most scrollbars. In this -context, "theoretical" means that all calculations on based on -frame-level values for toolbar, gutter and scrollbar thicknesses. -Because these thicknesses are controlled by specifiers, and specifiers -can have window-specific and buffer-specific values, these calculations -may or may not reflect the actual size of the paned area or of the -scrollbars when any particular window is selected. Note also that the -"displayable area" may not even be contiguous! In particular, if the -frame-level value of the horizontal scrollbar height is non-zero, then -the displayable area includes the paned area above and below the bottom -horizontal scrollbar but not the scrollbar itself. +The displayable area is essentially the ``theoretical'' gutter area of the +frame, excluding the rightmost and bottom-most scrollbars. That is, it +starts from the client (or ``total'') area and then excludes the +``theoretical'' toolbars and bottom-most/rightmost scrollbars, and the +internal border width. In this context, ``theoretical'' means that all +calculations on based on frame-level values for toolbar and scrollbar +thicknesses. Because these thicknesses are controlled by specifiers, +and specifiers can have window-specific and buffer-specific values, +these calculations may or may not reflect the actual size of the paned +area or of the scrollbars when any particular window is selected. Note +also that the ``displayable area'' may not even be contiguous! In +particular, the gutters are included, but the bottom-most and rightmost +scrollbars are excluded even though they are inside of the gutters. +Furthermore, if the frame-level value of the horizontal scrollbar height +is non-zero, then the displayable area includes the paned area above and +below the bottom horizontal scrollbar (i.e. the modeline and minibuffer) +but not the scrollbar itself. As a further twist, the character-dimension calculations are adjusted so that the truncation and continuation glyphs (see @code{truncation-glyph} and @@ -18136,7 +18203,7 @@ subtraction of the scrollbars, but not the minibuffer or bottom-most modeline, is to maintain compatibility with TTY's.) -Despite all these concerns and kludges, however, the "displayable area" +Despite all these concerns and kludges, however, the ``displayable area'' concept works well in practice and mostly ensures that by default the frame will actually fit 79 characters + continuation/truncation glyph. @@ -19785,7 +19852,7 @@ @cindex queues, event There are two event queues here -- the command event queue (#### which -should be called "deferred event queue" and is in my glyph ws) and the +should be called ``deferred event queue'' and is in my glyph ws) and the dispatch event queue. (MS Windows actually has an extra dispatch queue for non-user events and uses the generic one only for user events. This is because user and non-user events in Windows come through the same @@ -19890,7 +19957,7 @@ XEmacs calls this with an event structure which contains window-system dependent information that XEmacs doesn't need to know about, but which must happen in order. If the @code{next_event_cb} never returns an -event of type "magic", this will never be used. +event of type ``magic'', this will never be used. @item format_magic_event_cb Called with a magic event; print a representation of the innards of the @@ -19922,7 +19989,7 @@ These callbacks tell the underlying implementation to add or remove a file descriptor from the list of fds which are polled for inferior-process input. When input becomes available on the given -process connection, an event of type "process" should be generated. +process connection, an event of type ``process'' should be generated. @item select_console_cb @item unselect_console_cb @@ -20050,7 +20117,7 @@ Ben's capsule lecture on focus: In GNU Emacs @code{select-frame} never changes the window-manager frame -focus. All it does is change the "selected frame". This is similar to +focus. All it does is change the ``selected frame''. This is similar to what happens when we call @code{select-device} or @code{select-console}. Whenever an event comes in (including a keyboard event), its frame is selected; therefore, evaluating @code{select-frame} in @samp{*scratch*} @@ -20085,8 +20152,8 @@ minibuffer. GNU Emacs solves this with the crockish @code{redirect-frame-focus}, -which says "for keyboard events received from FRAME, act like they're -coming from FOCUS-FRAME". I think what this means is that, when a +which says ``for keyboard events received from FRAME, act like they're +coming from FOCUS-FRAME''. I think what this means is that, when a keyboard event comes in and the event manager is about to select the event's frame, if that frame has its focus redirected, the redirected-to frame is selected instead. That way, if you're in a minibufferless @@ -20100,8 +20167,8 @@ @code{select-frame} (but not if @code{handle-switch-frame} is called), and saves and restores the frame focus in window configurations, etc. etc. All of this logic is heavily @code{#if 0}'d, with lots of -comments saying "No, this approach doesn't seem to work, so I'm trying -this ... is it reasonable? Well, I'm not sure ..." that are a red flag +comments saying ``No, this approach doesn't seem to work, so I'm trying +this ... is it reasonable? Well, I'm not sure ...'' that are a red flag indicating crockishness. Because of our way of doing things, we can avoid all this crock. @@ -24884,22 +24951,22 @@ likelihood and a list of additional properties indicating certain features detected in the data. The extra properties returned are defined entirely by the particular coding system type and are used -only in the algorithm described below under "user control." However, +only in the algorithm described below under ``user control.'' However, the levels of likelihood have a standard meaning as follows: -Level 4 means "near certainty" and typically indicates that a +Level 4 means ``near certainty'' and typically indicates that a signature has been detected, usually at the beginning of the data, indicating that the data is encoded in this particular coding system type. An example of this would be the byte order mark at the beginning of UCS2 encoded data or the GZIP mark at the beginning of GZIP data. -Level 3 means "highly likely" and indicates that tell-tale signs have +Level 3 means ``highly likely'' and indicates that tell-tale signs have been discovered in the data that are characteristic of this particular coding system type. Examples of this might be ISO 2022 escape sequences or the current Unicode end of line markers at regular intervals. -Level 2 means "strongly statistically likely" indicating that +Level 2 means ``strongly statistically likely'' indicating that statistical analysis concludes that there's a high chance that this data is encoded according to this particular type. For example, this might mean that for UCS2 data, there is a high proportion of null bytes @@ -24908,7 +24975,7 @@ this might indicate that there were no illegal Shift-JIS sequences and a fairly high occurrence of common Shift-JIS characters. -Level 1 means "weak statistical likelihood" meaning that there is some +Level 1 means ``weak statistical likelihood'' meaning that there is some indication that the data is encoded in this coding system type. In fact, there is a reasonable chance that it may be some other type as well. This means, for example, that no illegal sequences were @@ -24916,17 +24983,17 @@ not in other coding system types. For Shift-JIS data, this might mean that some bytes in the range 128 to 159 were encountered in the data. -Level 0 means "neutral" which is to say that there's either not enough +Level 0 means ``neutral'' which is to say that there's either not enough data to make any decision or that the data could well be interpreted as this type (meaning no illegal sequences), but there is little or no indication of anything particular to this particular type. -Level -1 means "weakly unlikely" meaning that some data was +Level -1 means ``weakly unlikely'' meaning that some data was encountered that could conceivably be part of the coding system type but is probably not. For example, successively long line-lengths or very rarely-encountered sequences. -Level -2 means "strongly unlikely" meaning that typically a number +Level -2 means ``strongly unlikely'' meaning that typically a number of illegal sequences were encountered. The algorithm to determine when to stop and indicate that the data has @@ -24945,8 +25012,8 @@ subtypes). It is perfectly legal and quite common in fact, to list the same subtype more than once in the priority list with successively lower requirements. Other facts that can be listed in the priority -list for a subtype are "reject", meaning that the data should never be -detected as this subtype, or "ask", meaning that if the data is +list for a subtype are ``reject'', meaning that the data should never be +detected as this subtype, or ``ask'', meaning that if the data is detected to be this subtype, the user will be asked whether they actually mean this. This latter property could be used, for example, towards the bottom of the priority list. @@ -24963,7 +25030,7 @@ a status box somewhere. If no positive match is found according to the priority list, or if -the matches that are found have the "ask" property on them, then the +the matches that are found have the ``ask'' property on them, then the user will be presented with a list of choices of possible encodings and asked to choose one. This list is typically sorted first by level of likelihood, and then within this, by the order in which the @@ -24980,10 +25047,10 @@ which may either indicate definitely malformed data but from which it's possible to recover, or simply data that appears rather questionable. If any of these status values are reported during -decoding, the user will be informed of this and asked "are you sure?" -As part of the "are you sure" dialog box or question, the user can +decoding, the user will be informed of this and asked ``are you sure?'' +As part of the ``are you sure'' dialog box or question, the user can display the results of the decoding to make sure it's correct. If the -user says "no, they're not sure," then the same list of choices as +user says ``no, they're not sure,'' then the same list of choices as previously mentioned will be presented. @subheading RFC: Autodetection @@ -25203,7 +25270,7 @@ @item Hopefully a system general enough to handle (2)--(4) will handle these, too, but we should watch out for gotchas like -Unicode "plane 14" tags which (I think _both_ Ben and Olivier +Unicode ``plane 14'' tags which (I think _both_ Ben and Olivier will agree) have no place in the internal representation, and thus must be treated as out-of-band control sequences. I don't know if all such gotchas will be as easy to dispose of. @@ -25244,7 +25311,7 @@ like Hrvoje should have an easily available option to to this default (or an optimized approximation which t actually read the whole file into a buffer) or simply -y everything as binary (with the "font" for binary files +y everything as binary (with the ``font'' for binary files a user option). @item @@ -25353,7 +25420,7 @@ Stephen, thank you very much for writing this up. I think it is a good start, and definitely moving in the direction I would like to see things going: more -proposals, less arguing. (aka "more light, less heat") However, I have some +proposals, less arguing. (aka ``more light, less heat'') However, I have some suggestions for cleaning this up: You should try to make it more layered. For example, you might have one
--- a/man/lispref/extents.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/extents.texi Mon Mar 29 21:28:13 2010 -0500 @@ -850,8 +850,8 @@ copied into the resulting string. @item -When @code{substring} is called on a string, the relevant extents -are copied into the resulting string. +When @code{subseq} (or its alias, @code{substring}) is called on a +string, the relevant extents are copied into the resulting string. @item When a duplicable extent is detached by @code{detach-extent} or string
--- a/man/lispref/functions.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/functions.texi Mon Mar 29 21:28:13 2010 -0500 @@ -290,10 +290,10 @@ arguments, you get a @code{wrong-number-of-arguments} error. It is often convenient to write a function that allows certain -arguments to be omitted. For example, the function @code{substring} -accepts three arguments---a string, the start index and the end +arguments to be omitted. For example, the function @code{subseq} +accepts three arguments---a sequence, the start index and the end index---but the third argument defaults to the @var{length} of the -string if you omit it. It is also convenient for certain functions to +sequence if you omit it. It is also convenient for certain functions to accept an indefinite number of arguments, as the functions @code{list} and @code{+} do. @@ -331,8 +331,8 @@ function to distinguish between an explicit argument of @code{nil} and an omitted argument. However, the body of the function is free to consider @code{nil} an abbreviation for some other meaningful value. -This is what @code{substring} does; @code{nil} as the third argument to -@code{substring} means to use the length of the string supplied. +This is what @code{subseq} does; @code{nil} as the third argument to +@code{subseq} means to use the length of the sequence supplied. @cindex CL note---default optional arg @quotation
--- a/man/lispref/processes.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/processes.texi Mon Mar 29 21:28:13 2010 -0500 @@ -650,7 +650,7 @@ used. If it is @code{nil}, the current buffer's process is used. Optional arguments @var{start} and @var{end} specify part of @var{string}; -see @code{substring}. +see @code{subseq}. The function returns @code{nil}.
--- a/man/lispref/strings.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/strings.texi Mon Mar 29 21:28:13 2010 -0500 @@ -165,6 +165,10 @@ index @var{start} up to (but excluding) the character at the index @var{end}. The first character is at index zero. +In this implementation, @code{substring} is an alias for @code{subseq}, +so @var{string} can be any sequence. In GNU Emacs, @var{string} can be +a string or a vector, and in older XEmacs it can only be a string. + @example @group (substring "abcdefg" 0 3)
--- a/man/lispref/text.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/text.texi Mon Mar 29 21:28:13 2010 -0500 @@ -2118,7 +2118,7 @@ Copying text between strings and buffers preserves the properties along with the characters; this includes such diverse functions as -@code{substring}, @code{insert}, and @code{buffer-substring}. +@code{subseq}, @code{insert}, and @code{buffer-substring}. @menu * Examining Properties:: Looking at the properties of one character.
--- a/man/lispref/tips.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/lispref/tips.texi Mon Mar 29 21:28:13 2010 -0500 @@ -466,7 +466,7 @@ @smallexample @group (setq base-version-list ; there was a base - (assoc (substring fn 0 start-vn) ; version to which + (assoc (subseq fn 0 start-vn) ; version to which file-version-assoc-list)) ; this looks like ; a subversion @end group
--- a/man/xemacs/custom.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/xemacs/custom.texi Mon Mar 29 21:28:13 2010 -0500 @@ -2080,6 +2080,8 @@ Change the background pixmap of the given @var{face}. @item M-x set-face-background-pixmap-file A simpler version but with filename completion. +@item M-x set-face-background-placement +Change the placement of the background pixmap of the given @var{face}. @item M-x set-face-font Change the font of the given @var{face}. @item M-x set-face-foreground @@ -2161,6 +2163,18 @@ as much control on the pixmap instantiator, but provides filename completion. +@findex set-face-background-placement +You can set the placement of the background pixmap of the specified +@var{face} with the function @code{set-face-background-placement}. The +placement argument can be either @code{absolute} or @code{relative} (the +default). A @code{relative} placement means that the pixmap is attached +to the frame and moves with it. An @code{absolute} placement means that +the pixmap is rather attached to the frame's root window, so that when +you move the frame on the screen, it will appear to ``slide'' on the +pixmap. This placement mode can be used to achieve pseudo-translucency +for a frame, for example by setting the default face's background pixmap +to the root window's one. + @findex set-face-font You can set the font of the specified @var{face} with the function @code{set-face-font}. The @var{font} argument should be a string, the
--- a/man/xemacs/startup.texi Tue Feb 23 07:28:35 2010 -0600 +++ b/man/xemacs/startup.texi Mon Mar 29 21:28:13 2010 -0500 @@ -69,10 +69,10 @@ Moreover, XEmacs expects late hierarchies in the subdirectories @file{site-packages}, @file{mule-packages}, and @file{xemacs-packages} -(in that order) of the @file{<root>/lib/xemacs} subdirectory of one of +(in that order) of the @file{<root>/share/xemacs} subdirectory of one of the installation hierarchies. (If you run in-place, these are direct subdirectories of the build directory.) Furthermore, XEmacs will also -search these subdirectories in the @file{<root>/lib/xemacs-<VERSION>} +search these subdirectories in the @file{<root>/share/xemacs-<VERSION>} subdirectory and prefer directories found there. By default, XEmacs does not have a pre-configured last package @@ -113,12 +113,14 @@ @table @code @item version-specific @cindex version-specific directories -directories are specific to the version of XEmacs they belong to and -typically reside under @file{<root>/lib/xemacs-<VERSION>}. +directories (such as @file{etc}, the @file{info} of the installed XEmacs +and its Lisp files in @file{lisp}) are specific to the version of XEmacs +they belong to and typically reside under +@file{<root>/share/xemacs-<VERSION>}. @item site-specific @cindex site-specific directories -directories are independent of the version of XEmacs they belong to and -typically reside under @file{<root>/lib/xemacs} +directories are independent of the version of XEmacs and +typically reside under @file{<root>/share/xemacs}. @item architecture-specific @cindex architecture-specific directories directories are specific both to the version of XEmacs and the
--- a/modules/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,45 @@ +2010-03-12 Ben Wing <ben@xemacs.org> + + * base64/base64.c: + * base64/base64.c (Fbase64_encode): + * base64/base64.c (Fbase64_decode): + * base64/base64.c (syms_of_base64): + Fix file to follow GNU coding standards for indentation, spacing + before parens. + +2010-03-13 Ben Wing <ben@xemacs.org> + + * postgresql/postgresql.c (print_pgconn): + * postgresql/postgresql.c (print_pgresult): + printing_unreadable_object -> printing_unreadable_object_fmt. + +2010-03-13 Ben Wing <ben@xemacs.org> + + * ldap/eldap.c (print_ldap): + printing_unreadable_object -> printing_unreadable_object_fmt. + +2010-03-07 Ben Wing <ben@xemacs.org> + + * postgresql/postgresql.c (finalize_pgconn): + * postgresql/postgresql.c (finalize_pgresult): + * ldap/eldap.c (finalize_ldap): + Fix the finalizers to go with the new calling sequence. Done + previously but somehow got lost. + +2010-03-05 Ben Wing <ben@xemacs.org> + + * postgresql/postgresql.c (allocate_pgconn): + * postgresql/postgresql.c (allocate_pgresult): + * postgresql/postgresql.h (struct Lisp_PGconn): + * postgresql/postgresql.h (struct Lisp_PGresult): + * ldap/eldap.c (allocate_ldap): + * ldap/eldap.h (struct Lisp_LDAP): + Same changes as in src/ dir. See large log there in ChangeLog, + but basically: + + ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT + LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER + 2010-02-06 Ben Wing <ben@xemacs.org> * canna/canna_api.c:
--- a/modules/base64/base64.c Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/base64/base64.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* base64 interface for XEmacs. Copyright (C) 1998, 1999 Free Software Foundation, Inc. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -38,176 +39,170 @@ */ (object, start, end, coding, error_me_not)) { - int cols,bits,char_count; - Lisp_Object instream, outstream,deststream; - Lstream *istr, *ostr, *dstr; - static Extbyte_dynarr *conversion_out_dynarr; - static Extbyte_dynarr *out_dynarr; - char tempbuf[1024]; /* some random amount */ - struct gcpro gcpro1, gcpro2; -#ifdef FILE_CODING - Lisp_Object conv_out_stream, coding_system; - Lstream *costr; - struct gcpro gcpro3; -#endif + int cols,bits,char_count; + Lisp_Object instream, outstream,deststream; + Lstream *istr, *ostr, *dstr; + static Extbyte_dynarr *conversion_out_dynarr; + static Extbyte_dynarr *out_dynarr; + char tempbuf[1024]; /* some random amount */ + struct gcpro gcpro1, gcpro2; + Lisp_Object conv_out_stream, coding_system; + Lstream *costr; + struct gcpro gcpro3; - if (!conversion_out_dynarr) - conversion_out_dynarr = Dynarr_new (Extbyte); - else - Dynarr_reset (conversion_out_dynarr); + if (!conversion_out_dynarr) + conversion_out_dynarr = Dynarr_new (Extbyte); + else + Dynarr_reset (conversion_out_dynarr); + + if (!out_dynarr) + out_dynarr = Dynarr_new (Extbyte); + else + Dynarr_reset (out_dynarr); + + char_count = bits = cols = 0; + + /* set up the in stream */ + if (BUFFERP (object)) + { + struct buffer *b = XBUFFER (object); + Charbpos begv, endv; + /* Figure out where we need to get info from */ + get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); - if (!out_dynarr) - out_dynarr = Dynarr_new(Extbyte); - else - Dynarr_reset (out_dynarr); - - char_count = bits = cols = 0; + instream = make_lisp_buffer_input_stream (b, begv, endv, 0); + } + else + { + Bytecount bstart, bend; + CHECK_STRING (object); + get_string_range_byte (object, start, end, &bstart, &bend, + GB_HISTORICAL_STRING_BEHAVIOR); + instream = make_lisp_string_input_stream (object, bstart, bend); + } + istr = XLSTREAM (instream); - /* set up the in stream */ - if (BUFFERP (object)) + /* Find out what format the buffer will be saved in, so we can make + the digest based on what it will look like on disk */ + if (NILP (coding)) + { + if (BUFFERP (object)) { - struct buffer *b = XBUFFER (object); - Charbpos begv, endv; - /* Figure out where we need to get info from */ - get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); - - instream = make_lisp_buffer_input_stream (b, begv, endv, 0); + /* Use the file coding for this buffer by default */ + coding_system = XBUFFER (object)->buffer_file_coding_system; } - else + else + { + /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ + enum eol_type eol = EOL_AUTODETECT; + coding_system = Fget_coding_system (Qundecided); + determine_real_coding_system (istr, &coding_system, &eol); + } + if (NILP (coding_system)) + coding_system = Fget_coding_system (Qbinary); + else { - Bytecount bstart, bend; - CHECK_STRING (object); - get_string_range_byte (object, start, end, &bstart, &bend, - GB_HISTORICAL_STRING_BEHAVIOR); - instream = make_lisp_string_input_stream (object, bstart, bend); + coding_system = Ffind_coding_system (coding_system); + if (NILP (coding_system)) + coding_system = Fget_coding_system (Qbinary); } - istr = XLSTREAM (instream); + } + else + { + coding_system = Ffind_coding_system (coding); + if (NILP (coding_system)) + { + if (NILP (error_me_not)) + signal_simple_error ("No such coding system", coding); + else + coding_system = Fget_coding_system (Qbinary); /* default to binary */ + } + } -#ifdef FILE_CODING - /* Find out what format the buffer will be saved in, so we can make - the digest based on what it will look like on disk */ - if (NILP(coding)) + /* setup the out stream */ + outstream = make_dynarr_output_stream ((unsigned_char_dynarr *)conversion_out_dynarr); + ostr = XLSTREAM (outstream); + deststream = make_dynarr_output_stream ((unsigned_char_dynarr *)out_dynarr); + dstr = XLSTREAM (deststream); + /* setup the conversion stream */ + conv_out_stream = make_encoding_output_stream (ostr, coding_system); + costr = XLSTREAM (conv_out_stream); + GCPRO3 (instream, outstream, conv_out_stream); + + /* Get the data while doing the conversion */ + while (1) + { + int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); + int l; + if (!size_in_bytes) + break; + /* It does seem the flushes are necessary... */ + Lstream_write (costr, tempbuf, size_in_bytes); + Lstream_flush (costr); + Lstream_flush (ostr); + + /* Update the base64 output buffer */ + for (l = 0; l < size_in_bytes; l++) { - if (BUFFERP(object)) - { - /* Use the file coding for this buffer by default */ - coding_system = XBUFFER(object)->buffer_file_coding_system; - } - else + bits += Dynarr_at (conversion_out_dynarr,l); + char_count++; + if (char_count == 3) { - /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ - enum eol_type eol = EOL_AUTODETECT; - coding_system = Fget_coding_system(Qundecided); - determine_real_coding_system(istr, &coding_system, &eol); + static char obuf[4]; + obuf[0] = alphabet[(bits >> 18)]; + obuf[1] = alphabet[(bits >> 12) & 0x3f]; + obuf[2] = alphabet[(bits >> 6) & 0x3f]; + obuf[3] = alphabet[bits & 0x3f]; + + Lstream_write (dstr,obuf,sizeof (obuf)); + cols += 4; + if (cols == 72) + { + Lstream_write (dstr,"\n",sizeof (unsigned char)); + cols = 0; + } + bits = char_count = 0; } - if (NILP(coding_system)) - coding_system = Fget_coding_system(Qbinary); - else + else { - coding_system = Ffind_coding_system (coding_system); - if (NILP(coding_system)) - coding_system = Fget_coding_system(Qbinary); - } - } - else - { - coding_system = Ffind_coding_system (coding); - if (NILP(coding_system)) - { - if (NILP(error_me_not)) - signal_simple_error("No such coding system", coding); - else - coding_system = Fget_coding_system(Qbinary); /* default to binary */ + bits <<= 8; } } -#endif - - /* setup the out stream */ - outstream = make_dynarr_output_stream((unsigned_char_dynarr *)conversion_out_dynarr); - ostr = XLSTREAM (outstream); - deststream = make_dynarr_output_stream((unsigned_char_dynarr *)out_dynarr); - dstr = XLSTREAM (deststream); -#ifdef FILE_CODING - /* setup the conversion stream */ - conv_out_stream = make_encoding_output_stream (ostr, coding_system); - costr = XLSTREAM (conv_out_stream); - GCPRO3 (instream, outstream, conv_out_stream); -#else - GCPRO2 (instream, outstream); -#endif - - /* Get the data while doing the conversion */ - while (1) { - int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); - int l; - if (!size_in_bytes) - break; - /* It does seem the flushes are necessary... */ -#ifdef FILE_CODING - Lstream_write (costr, tempbuf, size_in_bytes); - Lstream_flush (costr); -#else - Lstream_write (ostr, tempbuf, size_in_bytes); -#endif - Lstream_flush (ostr); - - /* Update the base64 output buffer */ - for (l = 0; l < size_in_bytes; l++) { - bits += Dynarr_at(conversion_out_dynarr,l); - char_count++; - if (char_count == 3) { - static char obuf[4]; - obuf[0] = alphabet[(bits >> 18)]; - obuf[1] = alphabet[(bits >> 12) & 0x3f]; - obuf[2] = alphabet[(bits >> 6) & 0x3f]; - obuf[3] = alphabet[bits & 0x3f]; + /* reset the dynarr */ + Lstream_rewind (ostr); + } + Lstream_close (istr); + Lstream_close (costr); + Lstream_close (ostr); - Lstream_write(dstr,obuf,sizeof(obuf)); - cols += 4; - if (cols == 72) { - Lstream_write(dstr,"\n",sizeof(unsigned char)); - cols = 0; - } - bits = char_count = 0; - } else { - bits <<= 8; - } - } - /* reset the dynarr */ - Lstream_rewind(ostr); + if (char_count != 0) + { + bits <<= 16 - (8 * char_count); + Lstream_write (dstr,&alphabet[bits >> 18],sizeof (unsigned char)); + Lstream_write (dstr,&alphabet[(bits >> 12) & 0x3f],sizeof (unsigned char)); + if (char_count == 1) + { + Lstream_write (dstr,"==",2 * sizeof (unsigned char)); + } else + { + Lstream_write (dstr,&alphabet[(bits >> 6) & 0x3f],sizeof (unsigned char)); + Lstream_write (dstr,"=",sizeof (unsigned char)); } - Lstream_close (istr); -#ifdef FILE_CODING - Lstream_close (costr); + } +#if 0 + if (cols > 0) + { + Lstream_write (dstr,"\n",sizeof (unsigned char)); + } #endif - Lstream_close (ostr); + UNGCPRO; + Lstream_delete (istr); + Lstream_delete (ostr); + Lstream_delete (costr); + Lstream_flush (dstr); + Lstream_delete (dstr); - if (char_count != 0) { - bits <<= 16 - (8 * char_count); - Lstream_write(dstr,&alphabet[bits >> 18],sizeof(unsigned char)); - Lstream_write(dstr,&alphabet[(bits >> 12) & 0x3f],sizeof(unsigned char)); - if (char_count == 1) { - Lstream_write(dstr,"==",2 * sizeof(unsigned char)); - } else { - Lstream_write(dstr,&alphabet[(bits >> 6) & 0x3f],sizeof(unsigned char)); - Lstream_write(dstr,"=",sizeof(unsigned char)); - } - } -#if 0 - if (cols > 0) { - Lstream_write(dstr,"\n",sizeof(unsigned char)); - } -#endif - UNGCPRO; - Lstream_delete (istr); - Lstream_delete (ostr); -#ifdef FILE_CODING - Lstream_delete (costr); -#endif - Lstream_flush(dstr); - Lstream_delete(dstr); - - return(make_string(Dynarr_atp(out_dynarr,0),Dynarr_length(out_dynarr))); + return (make_string (Dynarr_atp (out_dynarr,0),Dynarr_length (out_dynarr))); } DEFUN ("base64-decode", Fbase64_decode, 1, 5, 0, /* @@ -222,196 +217,190 @@ */ (object, start, end, coding, error_me_not)) { - static char inalphabet[256], decoder[256]; - int i,cols,bits,char_count,hit_eof; - Lisp_Object instream, outstream,deststream; - Lstream *istr, *ostr, *dstr; - static Extbyte_dynarr *conversion_out_dynarr; - static Extbyte_dynarr *out_dynarr; - char tempbuf[1024]; /* some random amount */ - struct gcpro gcpro1, gcpro2; -#ifdef FILE_CODING - Lisp_Object conv_out_stream, coding_system; - Lstream *costr; - struct gcpro gcpro3; -#endif + static char inalphabet[256], decoder[256]; + int i,cols,bits,char_count,hit_eof; + Lisp_Object instream, outstream,deststream; + Lstream *istr, *ostr, *dstr; + static Extbyte_dynarr *conversion_out_dynarr; + static Extbyte_dynarr *out_dynarr; + char tempbuf[1024]; /* some random amount */ + struct gcpro gcpro1, gcpro2; + Lisp_Object conv_out_stream, coding_system; + Lstream *costr; + struct gcpro gcpro3; - for (i = (sizeof alphabet) - 1; i >= 0 ; i--) { - inalphabet[alphabet[i]] = 1; - decoder[alphabet[i]] = i; + for (i = (sizeof alphabet) - 1; i >= 0 ; i--) + { + inalphabet[alphabet[i]] = 1; + decoder[alphabet[i]] = i; } - if (!conversion_out_dynarr) - conversion_out_dynarr = Dynarr_new (Extbyte); - else - Dynarr_reset (conversion_out_dynarr); + if (!conversion_out_dynarr) + conversion_out_dynarr = Dynarr_new (Extbyte); + else + Dynarr_reset (conversion_out_dynarr); - if (!out_dynarr) - out_dynarr = Dynarr_new(Extbyte); - else - Dynarr_reset (out_dynarr); + if (!out_dynarr) + out_dynarr = Dynarr_new (Extbyte); + else + Dynarr_reset (out_dynarr); - char_count = bits = cols = hit_eof = 0; + char_count = bits = cols = hit_eof = 0; - /* set up the in stream */ - if (BUFFERP (object)) - { - struct buffer *b = XBUFFER (object); - Charbpos begv, endv; - /* Figure out where we need to get info from */ - get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); + /* set up the in stream */ + if (BUFFERP (object)) + { + struct buffer *b = XBUFFER (object); + Charbpos begv, endv; + /* Figure out where we need to get info from */ + get_buffer_range_char (b, start, end, &begv, &endv, GB_ALLOW_NIL); - instream = make_lisp_buffer_input_stream (b, begv, endv, 0); - } - else - { - Bytecount bstart, bend; - CHECK_STRING (object); - get_string_range_byte (object, start, end, &bstart, &bend, - GB_HISTORICAL_STRING_BEHAVIOR); - instream = make_lisp_string_input_stream (object, bstart, bend); - } - istr = XLSTREAM (instream); + instream = make_lisp_buffer_input_stream (b, begv, endv, 0); + } + else + { + Bytecount bstart, bend; + CHECK_STRING (object); + get_string_range_byte (object, start, end, &bstart, &bend, + GB_HISTORICAL_STRING_BEHAVIOR); + instream = make_lisp_string_input_stream (object, bstart, bend); + } + istr = XLSTREAM (instream); -#ifdef FILE_CODING - /* Find out what format the buffer will be saved in, so we can make - the digest based on what it will look like on disk */ - if (NILP(coding)) + /* Find out what format the buffer will be saved in, so we can make + the digest based on what it will look like on disk */ + if (NILP (coding)) + { + if (BUFFERP (object)) + { + /* Use the file coding for this buffer by default */ + coding_system = XBUFFER (object)->buffer_file_coding_system; + } + else + { + /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ + enum eol_type eol = EOL_AUTODETECT; + coding_system = Fget_coding_system (Qundecided); + determine_real_coding_system (istr, &coding_system, &eol); + } + if (NILP (coding_system)) + coding_system = Fget_coding_system (Qbinary); + else + { + coding_system = Ffind_coding_system (coding_system); + if (NILP (coding_system)) + coding_system = Fget_coding_system (Qbinary); + } + } + else + { + coding_system = Ffind_coding_system (coding); + if (NILP (coding_system)) { - if (BUFFERP(object)) + if (NILP (error_me_not)) + signal_simple_error ("No such coding system", coding); + else + coding_system = Fget_coding_system (Qbinary); /* default to binary */ + } + } + + /* setup the out stream */ + outstream = make_dynarr_output_stream ((unsigned_char_dynarr *)conversion_out_dynarr); + ostr = XLSTREAM (outstream); + deststream = make_dynarr_output_stream ((unsigned_char_dynarr *)out_dynarr); + dstr = XLSTREAM (deststream); + /* setup the conversion stream */ + conv_out_stream = make_encoding_output_stream (ostr, coding_system); + costr = XLSTREAM (conv_out_stream); + GCPRO3 (instream, outstream, conv_out_stream); + + /* Get the data while doing the conversion */ + while (1) + { + int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); + int l; + if (!size_in_bytes) + { + hit_eof = 1; + break; + } + /* It does seem the flushes are necessary... */ + Lstream_write (costr, tempbuf, size_in_bytes); + Lstream_flush (costr); + Lstream_flush (ostr); + + /* Update the base64 output buffer */ + for (l = 0; l < size_in_bytes; l++) + { + if (Dynarr_at (conversion_out_dynarr,l) == '=') + goto decoder_out; + bits += decoder[Dynarr_at (conversion_out_dynarr,l)]; + fprintf (stderr,"%d\n",bits); + char_count++; + if (char_count == 4) { - /* Use the file coding for this buffer by default */ - coding_system = XBUFFER(object)->buffer_file_coding_system; - } - else - { - /* attempt to autodetect the coding of the string. Note: this VERY hit-and-miss */ - enum eol_type eol = EOL_AUTODETECT; - coding_system = Fget_coding_system(Qundecided); - determine_real_coding_system(istr, &coding_system, &eol); + static unsigned char obuf[3]; + obuf[0] = (bits >> 16); + obuf[1] = (bits >> 8) & 0xff; + obuf[2] = (bits & 0xff); + + Lstream_write (dstr,obuf,sizeof (obuf)); + bits = char_count = 0; } - if (NILP(coding_system)) - coding_system = Fget_coding_system(Qbinary); - else + else { - coding_system = Ffind_coding_system (coding_system); - if (NILP(coding_system)) - coding_system = Fget_coding_system(Qbinary); - } - } - else - { - coding_system = Ffind_coding_system (coding); - if (NILP(coding_system)) - { - if (NILP(error_me_not)) - signal_simple_error("No such coding system", coding); - else - coding_system = Fget_coding_system(Qbinary); /* default to binary */ + bits <<= 6; } } -#endif - - /* setup the out stream */ - outstream = make_dynarr_output_stream((unsigned_char_dynarr *)conversion_out_dynarr); - ostr = XLSTREAM (outstream); - deststream = make_dynarr_output_stream((unsigned_char_dynarr *)out_dynarr); - dstr = XLSTREAM (deststream); -#ifdef FILE_CODING - /* setup the conversion stream */ - conv_out_stream = make_encoding_output_stream (ostr, coding_system); - costr = XLSTREAM (conv_out_stream); - GCPRO3 (instream, outstream, conv_out_stream); -#else - GCPRO2 (instream, outstream); -#endif - - /* Get the data while doing the conversion */ - while (1) { - int size_in_bytes = Lstream_read (istr, tempbuf, sizeof (tempbuf)); - int l; - if (!size_in_bytes) { - hit_eof = 1; - break; - } - /* It does seem the flushes are necessary... */ -#ifdef FILE_CODING - Lstream_write (costr, tempbuf, size_in_bytes); - Lstream_flush (costr); -#else - Lstream_write (ostr, tempbuf, size_in_bytes); -#endif - Lstream_flush (ostr); - - /* Update the base64 output buffer */ - for (l = 0; l < size_in_bytes; l++) { - if (Dynarr_at(conversion_out_dynarr,l) == '=') - goto decoder_out; - bits += decoder[Dynarr_at(conversion_out_dynarr,l)]; - fprintf(stderr,"%d\n",bits); - char_count++; - if (char_count == 4) { - static unsigned char obuf[3]; - obuf[0] = (bits >> 16); - obuf[1] = (bits >> 8) & 0xff; - obuf[2] = (bits & 0xff); + /* reset the dynarr */ + Lstream_rewind (ostr); + } + decoder_out: + Lstream_close (istr); + Lstream_close (costr); + Lstream_close (ostr); - Lstream_write(dstr,obuf,sizeof(obuf)); - bits = char_count = 0; - } else { - bits <<= 6; - } - } - /* reset the dynarr */ - Lstream_rewind(ostr); - } - decoder_out: - Lstream_close (istr); -#ifdef FILE_CODING - Lstream_close (costr); -#endif - Lstream_close (ostr); - - if (hit_eof) { - if (char_count) { - error_with_frob(object,"base64-decode failed: at least %d bits truncated",((4 - char_count) * 6)); - } + if (hit_eof) + { + if (char_count) + { + error_with_frob (object,"base64-decode failed: at least %d bits truncated",((4 - char_count) * 6)); } - switch(char_count) { - case 1: - error_with_frob(object, "base64 encoding incomplete: at least 2 bits missing"); - break; - case 2: - char_count = bits >> 10; - Lstream_write(dstr,&char_count,sizeof(char_count)); - break; - case 3: - { - unsigned char buf[2]; - buf[0] = (bits >> 16); - buf[1] = (bits >> 8) & 0xff; - Lstream_write(dstr,buf,sizeof(buf)); - break; - } - } + } + switch (char_count) + { + case 1: + error_with_frob (object, "base64 encoding incomplete: at least 2 bits missing"); + break; + case 2: + char_count = bits >> 10; + Lstream_write (dstr,&char_count,sizeof (char_count)); + break; + case 3: + { + unsigned char buf[2]; + buf[0] = (bits >> 16); + buf[1] = (bits >> 8) & 0xff; + Lstream_write (dstr,buf,sizeof (buf)); + break; + } + } - UNGCPRO; - Lstream_delete (istr); - Lstream_delete (ostr); -#ifdef FILE_CODING - Lstream_delete (costr); -#endif - Lstream_flush(dstr); - Lstream_delete(dstr); + UNGCPRO; + Lstream_delete (istr); + Lstream_delete (ostr); + Lstream_delete (costr); + Lstream_flush (dstr); + Lstream_delete (dstr); - return(make_string(Dynarr_atp(out_dynarr,0),Dynarr_length(out_dynarr))); + return (make_string (Dynarr_atp (out_dynarr,0),Dynarr_length (out_dynarr))); } void syms_of_base64 (void) { - DEFSUBR(Fbase64_encode); - DEFSUBR(Fbase64_decode); + DEFSUBR (Fbase64_encode); + DEFSUBR (Fbase64_decode); } void
--- a/modules/ldap/eldap.c Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/ldap/eldap.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* LDAP client interface for XEmacs. Copyright (C) 1998 Free Software Foundation, Inc. - Copyright (C) 2004 Ben Wing. + Copyright (C) 2004, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -130,7 +130,7 @@ Lisp_LDAP *ldap = XLDAP (obj); if (print_readably) - printing_unreadable_object ("#<ldap %s>", XSTRING_DATA (ldap->host)); + printing_unreadable_object_fmt ("#<ldap %s>", XSTRING_DATA (ldap->host)); write_fmt_string_lisp (printcharfun, "#<ldap %S", 1, ldap->host); if (!ldap->ld) @@ -141,7 +141,7 @@ static Lisp_LDAP * allocate_ldap (void) { - Lisp_LDAP *ldap = ALLOC_LCRECORD_TYPE (Lisp_LDAP, &lrecord_ldap); + Lisp_LDAP *ldap = XLDAP (ALLOC_NORMAL_LISP_OBJECT (ldap)); ldap->ld = NULL; ldap->host = Qnil; @@ -149,23 +149,19 @@ } static void -finalize_ldap (void *header, int for_disksave) +finalize_ldap (Lisp_Object obj) { - Lisp_LDAP *ldap = (Lisp_LDAP *) header; - - if (for_disksave) - invalid_operation ("Can't dump an emacs containing LDAP objects", - make_ldap (ldap)); + Lisp_LDAP *ldap = XLDAP (obj); if (ldap->ld) ldap_unbind (ldap->ld); ldap->ld = NULL; } -DEFINE_LRECORD_IMPLEMENTATION ("ldap", ldap, 0, - mark_ldap, print_ldap, finalize_ldap, - NULL, NULL, ldap_description, Lisp_LDAP); - +DEFINE_NODUMP_LISP_OBJECT ("ldap", ldap, mark_ldap, + print_ldap, finalize_ldap, + NULL, NULL, ldap_description, + Lisp_LDAP); /************************************************************************/ /* Basic ldap accessors */ @@ -616,7 +612,6 @@ int rc; int i, j; Elemcount len; - Lisp_Object values = Qnil; struct gcpro gcpro1; @@ -715,7 +710,6 @@ int i, j, rc; Lisp_Object mod_op; Elemcount len; - Lisp_Object values = Qnil; struct gcpro gcpro1; @@ -816,7 +810,7 @@ void syms_of_eldap (void) { - INIT_LRECORD_IMPLEMENTATION (ldap); + INIT_LISP_OBJECT (ldap); DEFSYMBOL (Qeldap); DEFSYMBOL (Qldapp); @@ -878,7 +872,7 @@ unload_eldap (void) { /* Remove defined types */ - UNDEF_LRECORD_IMPLEMENTATION (ldap); + UNDEF_LISP_OBJECT (ldap); /* Remove staticpro'ing of symbols */ unstaticpro_nodump (&Qeldap);
--- a/modules/ldap/eldap.h Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/ldap/eldap.h Mon Mar 29 21:28:13 2010 -0500 @@ -38,7 +38,7 @@ struct Lisp_LDAP { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* The LDAP connection handle used by the LDAP API */ LDAP *ld; /* Name of the host we connected to */ @@ -47,7 +47,7 @@ typedef struct Lisp_LDAP Lisp_LDAP; -DECLARE_LRECORD (ldap, Lisp_LDAP); +DECLARE_LISP_OBJECT (ldap, Lisp_LDAP); #define XLDAP(x) XRECORD (x, ldap, Lisp_LDAP) #define wrap_ldap(p) wrap_record (p, ldap) #define LDAPP(x) RECORDP (x, ldap)
--- a/modules/postgresql/postgresql.c Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/postgresql/postgresql.c Mon Mar 29 21:28:13 2010 -0500 @@ -90,8 +90,10 @@ interface to lcrecord handling has changed with 21.2, so unfortunately we will need a few snippets of backwards compatibility code. */ -#if (EMACS_MAJOR_VERSION == 21) && (EMACS_MINOR_VERSION < 2) +#if (EMACS_MAJOR_VERSION == 21) && (EMACS_MINOR_VERSION <= 1) #define RUNNING_XEMACS_21_1 1 +#elif (EMACS_MAJOR_VERSION == 21) && (EMACS_MINOR_VERSION <= 4) +#define RUNNING_XEMACS_21_4 1 #endif /* #define POSTGRES_LO_IMPORT_IS_VOID 1 */ @@ -251,7 +253,7 @@ strcpy (buf, "#<PGconn connecting>"); /* evil! */ if (print_readably) - printing_unreadable_object ("%s", buf); + printing_unreadable_object_fmt ("%s", buf); else write_cistring (printcharfun, buf); } @@ -262,14 +264,18 @@ #ifdef RUNNING_XEMACS_21_1 Lisp_PGconn *pgconn = ALLOC_LCRECORD_TYPE (Lisp_PGconn, lrecord_pgconn); -#else +#elif defined (RUNNING_XEMACS_21_4) Lisp_PGconn *pgconn = ALLOC_LCRECORD_TYPE (Lisp_PGconn, &lrecord_pgconn); +#else + Lisp_PGconn *pgconn = XPGCONN (ALLOC_NORMAL_LISP_OBJECT (pgconn)); #endif pgconn->pgconn = (PGconn *)NULL; return pgconn; } +#ifdef RUNNING_XEMACS_21_4 + static void finalize_pgconn (void *header, int for_disksave) { @@ -286,18 +292,41 @@ } } +#else /* not RUNNING_XEMACS_21_4 */ + +static void +finalize_pgconn (Lisp_Object obj) +{ + Lisp_PGconn *pgconn = XPGCONN (obj); + + if (pgconn->pgconn) + { + PQfinish (pgconn->pgconn); + pgconn->pgconn = (PGconn *)NULL; + } +} + +#endif /* (not) RUNNING_XEMACS_21_4 */ + #ifdef RUNNING_XEMACS_21_1 DEFINE_LRECORD_IMPLEMENTATION ("pgconn", pgconn, mark_pgconn, print_pgconn, finalize_pgconn, NULL, NULL, Lisp_PGconn); -#else +#elif defined (RUNNING_XEMACS_21_4) DEFINE_LRECORD_IMPLEMENTATION ("pgconn", pgconn, 0, /*dumpable-flag*/ mark_pgconn, print_pgconn, finalize_pgconn, NULL, NULL, pgconn_description, Lisp_PGconn); +#else +DEFINE_NODUMP_LISP_OBJECT ("pgconn", pgconn, + mark_pgconn, print_pgconn, + finalize_pgconn, + NULL, NULL, + pgconn_description, + Lisp_PGconn); #endif /****/ @@ -372,7 +401,7 @@ strcpy (buf, "#<PGresult DEAD>"); /* evil! */ if (print_readably) - printing_unreadable_object ("%s", buf); + printing_unreadable_object_fmt ("%s", buf); else write_cistring (printcharfun, buf); } @@ -387,14 +416,18 @@ #ifdef RUNNING_XEMACS_21_1 Lisp_PGresult *pgresult = ALLOC_LCRECORD_TYPE (Lisp_PGresult, lrecord_pgresult); -#else +#elif defined (RUNNING_XEMACS_21_4) Lisp_PGresult *pgresult = ALLOC_LCRECORD_TYPE (Lisp_PGresult, &lrecord_pgresult); +#else + Lisp_PGresult *pgresult = XPGRESULT (ALLOC_NORMAL_LISP_OBJECT (pgresult)); #endif pgresult->pgresult = (PGresult *)NULL; return pgresult; } +#ifdef RUNNING_XEMACS_21_4 + static void finalize_pgresult (void *header, int for_disksave) { @@ -411,18 +444,40 @@ } } +#else /* not RUNNING_XEMACS_21_4 */ + +static void +finalize_pgresult (Lisp_Object obj) +{ + Lisp_PGresult *pgresult = XPGRESULT (obj); + + if (pgresult->pgresult) + { + PQclear (pgresult->pgresult); + pgresult->pgresult = (PGresult *)NULL; + } +} + +#endif /* (not) RUNNING_XEMACS_21_4 */ + #ifdef RUNNING_XEMACS_21_1 DEFINE_LRECORD_IMPLEMENTATION ("pgresult", pgresult, mark_pgresult, print_pgresult, finalize_pgresult, NULL, NULL, Lisp_PGresult); -#else +#elif defined (RUNNING_XEMACS_21_4) DEFINE_LRECORD_IMPLEMENTATION ("pgresult", pgresult, 0, /*dumpable-flag*/ mark_pgresult, print_pgresult, finalize_pgresult, NULL, NULL, pgresult_description, Lisp_PGresult); +#else +DEFINE_NODUMP_LISP_OBJECT ("pgresult", pgresult, + mark_pgresult, print_pgresult, finalize_pgresult, + NULL, NULL, + pgresult_description, + Lisp_PGresult); #endif /***********************/ @@ -1597,8 +1652,8 @@ syms_of_postgresql(void) { #ifndef RUNNING_XEMACS_21_1 - INIT_LRECORD_IMPLEMENTATION (pgconn); - INIT_LRECORD_IMPLEMENTATION (pgresult); + INIT_LISP_OBJECT (pgconn); + INIT_LISP_OBJECT (pgresult); #endif DEFSYMBOL (Qpostgresql); @@ -1870,8 +1925,8 @@ { #ifndef RUNNING_XEMACS_21_1 /* Remove defined types */ - UNDEF_LRECORD_IMPLEMENTATION (pgconn); - UNDEF_LRECORD_IMPLEMENTATION (pgresult); + UNDEF_LISP_OBJECT (pgconn); + UNDEF_LISP_OBJECT (pgresult); #endif /* Remove staticpro'ing of symbols */
--- a/modules/postgresql/postgresql.h Tue Feb 23 07:28:35 2010 -0600 +++ b/modules/postgresql/postgresql.h Mon Mar 29 21:28:13 2010 -0500 @@ -28,12 +28,12 @@ */ struct Lisp_PGconn { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; PGconn *pgconn; }; typedef struct Lisp_PGconn Lisp_PGconn; -DECLARE_LRECORD (pgconn, Lisp_PGconn); +DECLARE_LISP_OBJECT (pgconn, Lisp_PGconn); #define XPGCONN(x) XRECORD (x, pgconn, Lisp_PGconn) #define wrap_pgconn(p) wrap_record (p, pgconn) @@ -48,12 +48,12 @@ */ struct Lisp_PGresult { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; PGresult *pgresult; }; typedef struct Lisp_PGresult Lisp_PGresult; -DECLARE_LRECORD (pgresult, Lisp_PGresult); +DECLARE_LISP_OBJECT (pgresult, Lisp_PGresult); #define XPGRESULT(x) XRECORD (x, pgresult, Lisp_PGresult) #define wrap_pgresult(p) wrap_record (p, pgresult)
--- a/nt/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/nt/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -5,6 +5,20 @@ * xemacs.mak (OPT_OBJS): objects*.[ch] -> fontcolor*.[ch]. +2010-03-29 Vin Shelton <acs@xemacs.org> + + * xemacs.mak (TEMACS_COMMON_OBJS): Add array.obj and remove + dynarr.obj, to catch up with Ben's changes of 2010-03-28. + +2010-03-08 Vin Shelton <acs@xemacs.org> + + * xemacs.mak (batch_test_emacs): The test harness no longer + resides in $(testdir), per Ben's changes of 2010-02-22. + +2010-03-02 Jerry James <james@xemacs.org> + + * xemacs.mak (INFO_FILES): Removed custom.info. + 2010-02-18 Vin Shelton <acs@xemacs.org> * xemacs.mak (INFO_FILES): Removed term.info.
--- a/nt/xemacs.mak Tue Feb 23 07:28:35 2010 -0600 +++ b/nt/xemacs.mak Mon Mar 29 21:28:13 2010 -0500 @@ -840,6 +840,7 @@ $(OUTDIR)\abbrev.obj \ $(OUTDIR)\alloc.obj \ $(OUTDIR)\alloca.obj \ + $(OUTDIR)\array.obj \ $(OUTDIR)\blocktype.obj \ $(OUTDIR)\buffer.obj \ $(OUTDIR)\bytecode.obj \ @@ -857,7 +858,6 @@ $(OUTDIR)\doc.obj \ $(OUTDIR)\doprnt.obj \ $(OUTDIR)\dragdrop.obj \ - $(OUTDIR)\dynarr.obj \ $(OUTDIR)\editfns.obj \ $(OUTDIR)\elhash.obj \ $(OUTDIR)\emacs.obj \ @@ -1488,7 +1488,6 @@ INFO_FILES= \ $(INFODIR)\beta.info \ $(INFODIR)\cl.info \ - $(INFODIR)\custom.info \ $(INFODIR)\emodules.info \ $(INFODIR)\external-widget.info \ $(INFODIR)\info.info \ @@ -1659,7 +1658,7 @@ ########################### Automated tests testdir = ../tests/automated -batch_test_emacs = $(BATCH_PACKAGES) -l $(testdir)/test-harness.el -f batch-test-emacs $(testdir) +batch_test_emacs = $(BATCH_PACKAGES) -l test-harness -f batch-test-emacs $(testdir) check: cd $(BLDSRC)
--- a/src/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/src/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,2044 @@ +2010-03-28 Ben Wing <ben@xemacs.org> + + * window.c (find_window_mirror_internal): + Stop looking if no window mirror, and return 0. + + * window.c (window_display_lines): + * window.c (window_display_buffer): + * window.c (set_window_display_buffer): + Don't need to update window mirror before calling find_window_mirror + because does the updating automatically. + +2010-03-25 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (struct): + * alloc.c (finish_object_memory_usage_stats): + * alloc.c (object_memory_usage_stats): + * alloc.c (Fobject_memory_usage): + * alloc.c (lisp_object_memory_usage_full): + * alloc.c (compute_memusage_stats_length): + * lrecord.h: + * lrecord.h (struct lrecord_implementation): + Add fields to the `lrecord_implementation' structure to list an + offset into the array of extra statistics in a + `struct generic_usage_stats' and a length, listing the first slice + of ancillary Lisp-object memory. Compute automatically in + compute_memusage_stats_length(). Use to add an entry + `FOO-lisp-ancillary-storage' for object type FOO. + + Don't crash when an int or char is given to object-memory-usage, + signal an error instead. + + Add functions lisp_object_memory_usage_full() and + lisp_object_memory_usage() to compute the total memory usage of an + object (sum of object, non-Lisp attached, and Lisp ancillary + memory). + + * array.c: + * array.c (gap_array_memory_usage): + * array.h: + Add function to return memory usage of a gap array. + + * buffer.c (struct buffer_stats): + * buffer.c (compute_buffer_usage): + * buffer.c (vars_of_buffer): + * extents.c (compute_buffer_extent_usage): + * marker.c: + * marker.c (compute_buffer_marker_usage): + * extents.h: + * lisp.h: + Remove `struct usage_stats' arg from compute_buffer_marker_usage() + and compute_buffer_extent_usage() -- these are ancillary Lisp + objects and don't get accumulated into `struct usage_stats'; + change the value of `memusage_stats_list' so that `markers' and + `extents' memory is in Lisp-ancillary, where it belongs. + + In compute_buffer_marker_usage(), use lisp_object_memory_usage() + rather than lisp_object_storage_size(). + + * casetab.c: + * casetab.c (case_table_memory_usage): + * casetab.c (vars_of_casetab): + * emacs.c (main_1): + Add memory usage stats for case tables. + + * lisp.h: + Add comment explaining the `struct generic_usage_stats' more, + as well as the new fields in lrecord_implementation. + + * console-impl.h: + * console-impl.h (struct console_methods): + * scrollbar-gtk.c: + * scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): + * scrollbar-msw.c: + * scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage): + * scrollbar-x.c: + * scrollbar-x.c (x_compute_scrollbar_instance_usage): + * scrollbar.c: + * scrollbar.c (struct scrollbar_instance_stats): + * scrollbar.c (compute_all_scrollbar_instance_usage): + * scrollbar.c (scrollbar_instance_memory_usage): + * scrollbar.c (scrollbar_objects_create): + * scrollbar.c (vars_of_scrollbar): + * scrollbar.h: + * symsinit.h: + * window.c: + * window.c (find_window_mirror_maybe): + * window.c (struct window_mirror_stats): + * window.c (compute_window_mirror_usage): + * window.c (window_mirror_memory_usage): + * window.c (compute_window_usage): + * window.c (window_objects_create): + * window.c (syms_of_window): + * window.c (vars_of_window): + Redo memory-usage associated with windows, window mirrors, and + scrollbar instances. Should fix crash in find_window_mirror, + among other things. Properly assign memo ry to object memory, + non-Lisp extra memory, and Lisp ancillary memory. For example, + redisplay structures are non-Lisp memory hanging off a window + mirror, not a window; make it an ancillary Lisp-object field. + Window mirrors and scrollbar instances have their own statistics, + among other things. + +2010-03-24 Ben Wing <ben@xemacs.org> + + * array.h: + * array.h (XD_LISP_DYNARR_DESC): + * dumper.c (pdump_register_sub): + * dumper.c (pdump_store_new_pointer_offsets): + * dumper.c (pdump_reloc_one_mc): + * elhash.c: + * gc.c (lispdesc_one_description_line_size): + * gc.c (kkcc_marking): + * lrecord.h: + * lrecord.h (IF_NEW_GC): + * lrecord.h (enum memory_description_type): + * lrecord.h (enum data_description_entry_flags): + * lrecord.h (struct opaque_convert_functions): + Rename XD_LISP_OBJECT_BLOCK_PTR to XD_INLINE_LISP_OBJECT_BLOCK_PTR + and document it in lrecord.h. + + * data.c: + * data.c (finish_marking_weak_lists): + * data.c (continue_marking_ephemerons): + * data.c (finish_marking_ephemerons): + * elhash.c (MARK_OBJ): + * gc.c: + * gc.c (lispdesc_indirect_count_1): + * gc.c (struct): + * gc.c (kkcc_bt_push): + * gc.c (kkcc_gc_stack_push): + * gc.c (kkcc_gc_stack_push_lisp_object): + * gc.c (kkcc_gc_stack_repush_dirty_object): + * gc.c (KKCC_DO_CHECK_FREE): + * gc.c (mark_object_maybe_checking_free): + * gc.c (mark_struct_contents): + * gc.c (mark_lisp_object_block_contents): + * gc.c (register_for_finalization): + * gc.c (mark_object): + * gc.h: + * lisp.h: + * profile.c: + * profile.c (mark_profiling_info_maphash): + Clean up KKCC code related to DEBUG_XEMACS. Rename + kkcc_backtrace() to kkcc_backtrace_1() and add two params: a + `size' arg to control how many stack elements to print and a + `detailed' arg to control whether Lisp objects are printed using + `debug_print()'. Create front-ends to kkcc_backtrace_1() -- + kkcc_detailed_backtrace(), kkcc_short_backtrace(), + kkcc_detailed_backtrace_full(), kkcc_short_backtrace_full(), as + well as shortened versions kbt(), kbts(), kbtf(), kbtsf() -- to + call it with various parameter values. Add an `is_lisp' field to + the stack and backtrace structures and use it to keep track of + whether an object pushed onto the stack is a Lisp object or a + non-Lisp structure; in kkcc_backtrace_1(), don't try to print a + non-Lisp structure as a Lisp object. + + * elhash.c: + * extents.c: + * file-coding.c: + * lrecord.h: + * lrecord.h (IF_NEW_GC): + * marker.c: + * marker.c (Fmarker_buffer): + * mule-coding.c: + * number.c: + * rangetab.c: + * specifier.c: + New macros IF_OLD_GC(), IF_NEW_GC() to simplify declaration of + Lisp objects when a finalizer may exist in one but not the other. + Use them appropriately. + + * extents.c (finalize_extent_info): + Don't zero out data->soe and data->extents before trying to free, + else we get memory leaks. + + * lrecord.h (enum lrecord_type): + Make the first lrecord type have value 1 not 0 so that 0 remains + without implementation and attempts to interpret zeroed memory + as a Lisp object will be more obvious. + + * array.c (Dynarr_free): + * device-msw.c (msprinter_delete_device): + * device-tty.c (free_tty_device_struct): + * device-tty.c (tty_delete_device): + * dialog-msw.c (handle_directory_dialog_box): + * dialog-x.c: + * emacs.c (free_argc_argv): + * emodules.c (attempt_module_delete): + * file-coding.c (chain_finalize_coding_stream_1): + * file-coding.c (chain_finalize_coding_stream): + * glyphs-eimage.c: + * glyphs-eimage.c (jpeg_instantiate_unwind): + * glyphs-eimage.c (gif_instantiate_unwind): + * glyphs-eimage.c (png_instantiate_unwind): + * glyphs-eimage.c (tiff_instantiate_unwind): + * imgproc.c: + * imgproc.c (build_EImage_quantable): + * insdel.c (uninit_buffer_text): + * mule-coding.c (iso2022_finalize_detection_state): + * objects-tty.c (tty_finalize_color_instance): + * objects-tty.c (tty_finalize_font_instance): + * objects-tty.c (tty_font_list): + * process.c: + * process.c (finalize_process): + * redisplay.c (add_propagation_runes): + * scrollbar-gtk.c: + * scrollbar-gtk.c (gtk_free_scrollbar_instance): + * scrollbar-gtk.c (gtk_release_scrollbar_instance): + * scrollbar-msw.c: + * scrollbar-msw.c (mswindows_free_scrollbar_instance): + * scrollbar-msw.c (unshow_that_mofo): + * scrollbar-x.c (x_free_scrollbar_instance): + * scrollbar-x.c (x_release_scrollbar_instance): + * select-x.c: + * select-x.c (x_handle_selection_request): + * syntax.c: + * syntax.c (uninit_buffer_syntax_cache): + * text.h (eifree): + If possible, whenever we call xfree() on a field in a structure, + set the field to 0 afterwards. A lot of code is written so that + it checks the value being freed to see if it is non-zero before + freeing it -- doing this and setting the value to 0 afterwards + ensures (a) we won't try to free twice if the cleanup code is + called twice; (b) if the object itself stays around, KKCC won't + crash when attempting to mark the freed field. + + * rangetab.c: + Add a finalization method when not NEW_GC to avoid memory leaks. + (#### We still get memory leaks when NEW_GC; need to convert gap + array to Lisp object). + +2010-03-22 Ben Wing <ben@xemacs.org> + + * Makefile.in.in (objs): + * array.c: + * array.c (gap_array_adjust_markers): + * array.c (gap_array_move_gap): + * array.c (gap_array_make_gap): + * array.c (gap_array_insert_els): + * array.c (gap_array_delete_els): + * array.c (gap_array_make_marker): + * array.c (gap_array_delete_marker): + * array.c (gap_array_delete_all_markers): + * array.c (gap_array_clone): + * array.h: + * depend: + * emacs.c (main_1): + * extents.c: + * extents.c (EXTENT_GAP_ARRAY_AT): + * extents.c (extent_list_num_els): + * extents.c (extent_list_locate): + * extents.c (extent_list_at): + * extents.c (extent_list_delete_all): + * extents.c (allocate_extent_list): + * extents.c (syms_of_extents): + * extents.h: + * extents.h (XEXTENT_LIST_MARKER): + * lisp.h: + * rangetab.c: + * rangetab.c (mark_range_table): + * rangetab.c (print_range_table): + * rangetab.c (range_table_equal): + * rangetab.c (range_table_hash): + * rangetab.c (verify_range_table): + * rangetab.c (get_range_table_pos): + * rangetab.c (Fmake_range_table): + * rangetab.c (Fcopy_range_table): + * rangetab.c (Fget_range_table): + * rangetab.c (put_range_table): + * rangetab.c (Fclear_range_table): + * rangetab.c (Fmap_range_table): + * rangetab.c (unified_range_table_bytes_needed): + * rangetab.c (unified_range_table_copy_data): + * rangetab.c (unified_range_table_lookup): + * rangetab.h: + * rangetab.h (struct range_table_entry): + * rangetab.h (struct Lisp_Range_Table): + * rangetab.h (rangetab_gap_array_at): + * symsinit.h: + Rename dynarr.c to array.c. Move gap array from extents.c to array.c. + Extract dynarr, gap array and stack-like malloc into new file array.h. + Rename GAP_ARRAY_NUM_ELS -> gap_array_length(). Add gap_array_at(), + gap_array_atp(). + + Rewrite range table code to use gap arrays. Make put_range_table() + smarter so that its operation is O(log n) for adding a localized + range. + + * gc.c (lispdesc_block_size_1): + Don't ABORT() when two elements are located at the same place. + This will happen with a size-0 gap array -- both parts of the array + (before and after gap) are in the same place. + +2010-03-21 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (assert_proper_sizing): + * alloc.c (c_readonly): + * alloc.c (malloced_storage_size): + * alloc.c (fixed_type_block_overhead): + * alloc.c (lisp_object_storage_size): + * alloc.c (inc_lrecord_stats): + * alloc.c (dec_lrecord_stats): + * alloc.c (pluralize_word): + * alloc.c (object_memory_usage_stats): + * alloc.c (Fobject_memory_usage): + * alloc.c (compute_memusage_stats_length): + * alloc.c (disksave_object_finalization_1): + * alloc.c (Fgarbage_collect): + * mc-alloc.c: + * mc-alloc.c (mc_alloced_storage_size): + * mc-alloc.h: + No functionality change here. Collect the allocations-statistics + code that was scattered throughout alloc.c into one place. Add + remaining section headings so that all sections have headings + clearly identifying the start of the section and its purpose. + Expose mc_alloced_storage_size() even when not MEMORY_USAGE_STATS; + this fixes build problems and is related to the export of + lisp_object_storage_size() and malloced_storage_size() when + non-MEMORY_USAGE_STATS in the previous change set. + +2010-03-22 Vin Shelton <acs@xemacs.org> + + * window.c (vars_of_window): Move HAVE_SCROLLBARS test so the code + can compile under Visual Studio 6. + +2010-03-21 Aidan Kehoe <kehoea@parhasard.net> + + * alloc.c (tick_lrecord_stats): + Fix the union build after Ben's last change, don't assume that a + Lisp_Object will fit into a Bytecount. + +2010-03-20 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (init_lrecord_stats): + * alloc.c (free_normal_lisp_object): + * alloc.c (struct): + * alloc.c (clear_lrecord_stats): + * alloc.c (tick_lrecord_stats): + * alloc.c (COUNT_FROB_BLOCK_USAGE): + * alloc.c (COPY_INTO_LRECORD_STATS): + * alloc.c (sweep_strings): + * alloc.c (UNMARK_string): + * alloc.c (gc_sweep_1): + * alloc.c (finish_object_memory_usage_stats): + * alloc.c (object_memory_usage_stats): + * alloc.c (object_dead_p): + * alloc.c (fixed_type_block_overhead): + * alloc.c (lisp_object_storage_size): + * emacs.c (main_1): + * lisp.h: + * lrecord.h: + Export lisp_object_storage_size() and malloced_storage_size() even + when not MEMORY_USAGE_STATS, to get the non-MEMORY_USAGE_STATS + build to compile. + + Don't export fixed_type_block_overhead() any more. + + Some code cleanup, rearrangement, add some section headers. + + Clean up various bugs especially involving computation of overhead + and double-counting certain usage in total_gc_usage. Add + statistics computing the overhead used by all types. Don't add a + special entry for string headers in the object-memory-usage-stats + because it's already present as just "string". But do count the + overhead used by long strings. Don't try to call the + memory_usage() methods when NEW_GC because there's nowhere obvious + in the sweep stage to make the calls. + + * marker.c (compute_buffer_marker_usage): + Just use lisp_object_storage_size() rather than trying to + reimplement it. + +2010-03-19 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (struct): + * alloc.c (tick_lrecord_stats): + * alloc.c (gc_sweep_1): + * alloc.c (finish_object_memory_usage_stats): + * alloc.c (object_memory_usage_stats): + * alloc.c (compute_memusage_stats_length): + Call new memory-usage mechanism at sweep time to compute extra + memory utilization for all objects. Add up the values element-by- + element to get an aggregrate set of statistics, where each is the + sum of the values of a single statistic across different objects + of the same type. At end of sweep time, call + finish_object_memory_usage_stats() to add up all the aggreggrate + stats that are related to non-Lisp memory storage to compute + a single value, and add it to the list of values returned by + `garbage-collect' and `object-memory-usage-stats'. + + * buffer.c (compute_buffer_text_usage): + Don't crash on buffers without text (killed buffers?) and don't + double-count indirect buffers. + + * elhash.c: + * elhash.c (hash_table_objects_create): + * elhash.c (vars_of_elhash): + * symsinit.h: + Add memory-usage method to count the size of `hentries'. + + * emacs.c (main_1): + Call new functions in elhash.c, frame.c at init. + + * frame.c: + * frame.c (compute_frame_usage): + * frame.c (frame_memory_usage): + * frame.c (frame_objects_create): + * symsinit.h: + Add memory-usage method to count gutter display structures, + subwindow exposures. + + * gc.c (gc_finish): + * lisp.h: + Declare finish_object_memory_usage_stats(), call it in gc_finish(). + + * lrecord.h (struct lrecord_implementation): + * lrecord.h (INIT_MEMORY_USAGE_STATS): + New value in implementation struct to track number of non-Lisp-memory + statistics. Computed in alloc.c. + + +2010-03-18 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (disksave_object_finalization_1): + * alloc.c (lisp_object_storage_size): + * alloc.c (listu): + * alloc.c (listn): + * alloc.c (Fobject_memory_usage_stats): + * alloc.c (compute_memusage_stats_length): + * alloc.c (Fobject_memory_usage): + * alloc.c (Ftotal_object_memory_usage): + * alloc.c (malloced_storage_size): + * alloc.c (common_init_alloc_early): + * alloc.c (reinit_alloc_objects_early): + * alloc.c (reinit_alloc_early): + * alloc.c (init_alloc_once_early): + * alloc.c (syms_of_alloc): + * alloc.c (reinit_vars_of_alloc): + * buffer.c: + * buffer.c (struct buffer_stats): + * buffer.c (compute_buffer_text_usage): + * buffer.c (compute_buffer_usage): + * buffer.c (buffer_memory_usage): + * buffer.c (buffer_objects_create): + * buffer.c (syms_of_buffer): + * buffer.c (vars_of_buffer): + * console-impl.h (struct console_methods): + * dynarr.c (Dynarr_memory_usage): + * emacs.c (main_1): + * events.c (clear_event_resource): + * extents.c: + * extents.c (compute_buffer_extent_usage): + * extents.c (extent_objects_create): + * extents.h: + * faces.c: + * faces.c (compute_face_cachel_usage): + * faces.c (face_objects_create): + * faces.h: + * general-slots.h: + * glyphs.c: + * glyphs.c (compute_glyph_cachel_usage): + * glyphs.c (glyph_objects_create): + * glyphs.h: + * lisp.h: + * lisp.h (struct usage_stats): + * lrecord.h: + * lrecord.h (enum lrecord_type): + * lrecord.h (struct lrecord_implementation): + * lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): + * lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (MAKE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT): + * lrecord.h (MAKE_MODULE_LISP_OBJECT): + * lrecord.h (INIT_LISP_OBJECT): + * lrecord.h (INIT_MODULE_LISP_OBJECT): + * lrecord.h (UNDEF_LISP_OBJECT): + * lrecord.h (UNDEF_MODULE_LISP_OBJECT): + * lrecord.h (DECLARE_LISP_OBJECT): + * lrecord.h (DECLARE_MODULE_API_LISP_OBJECT): + * lrecord.h (DECLARE_MODULE_LISP_OBJECT): + * lstream.c: + * lstream.c (syms_of_lstream): + * lstream.c (vars_of_lstream): + * marker.c: + * marker.c (compute_buffer_marker_usage): + * mc-alloc.c (mc_alloced_storage_size): + * mc-alloc.h: + * mule-charset.c: + * mule-charset.c (struct charset_stats): + * mule-charset.c (compute_charset_usage): + * mule-charset.c (charset_memory_usage): + * mule-charset.c (mule_charset_objects_create): + * mule-charset.c (syms_of_mule_charset): + * mule-charset.c (vars_of_mule_charset): + * redisplay.c: + * redisplay.c (compute_rune_dynarr_usage): + * redisplay.c (compute_display_block_dynarr_usage): + * redisplay.c (compute_glyph_block_dynarr_usage): + * redisplay.c (compute_display_line_dynarr_usage): + * redisplay.c (compute_line_start_cache_dynarr_usage): + * redisplay.h: + * scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): + * scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage): + * scrollbar-x.c (x_compute_scrollbar_instance_usage): + * scrollbar.c (compute_scrollbar_instance_usage): + * scrollbar.h: + * symbols.c: + * symbols.c (reinit_symbol_objects_early): + * symbols.c (init_symbols_once_early): + * symbols.c (reinit_symbols_early): + * symbols.c (defsymbol_massage_name_1): + * symsinit.h: + * ui-gtk.c: + * ui-gtk.c (emacs_gtk_object_getprop): + * ui-gtk.c (emacs_gtk_object_putprop): + * ui-gtk.c (ui_gtk_objects_create): + * unicode.c (compute_from_unicode_table_size_1): + * unicode.c (compute_to_unicode_table_size_1): + * unicode.c (compute_from_unicode_table_size): + * unicode.c (compute_to_unicode_table_size): + * window.c: + * window.c (struct window_stats): + * window.c (compute_window_mirror_usage): + * window.c (compute_window_usage): + * window.c (window_memory_usage): + * window.c (window_objects_create): + * window.c (syms_of_window): + * window.c (vars_of_window): + * window.h: + Redo memory-usage mechanism, make it general; add way of dynamically + initializing Lisp object types -- OBJECT_HAS_METHOD(), similar to + CONSOLE_HAS_METHOD(). + + (1) Create OBJECT_HAS_METHOD(), OBJECT_HAS_PROPERTY() etc. for + specifying that a Lisp object type has a particular method or + property. Call such methods with OBJECT_METH, MAYBE_OBJECT_METH, + OBJECT_METH_OR_GIVEN; retrieve properties with OBJECT_PROPERTY. + Methods that formerly required a DEFINE_*GENERAL_LISP_OBJECT() to + specify them (getprop, putprop, remprop, plist, disksave) now + instead use the dynamic-method mechanism. The main benefit of + this is that new methods or properties can be added without + requiring that the declaration statements of all existing methods + be modified. We have to make the `struct lrecord_implementation' + non-const, but I don't think this should have any effect on speed -- + the only possible method that's really speed-critical is the + mark method, and we already extract those out into a separate + (non-const) array for increased cache locality. + + Object methods need to be reinitialized after pdump, so we put + them in separate functions such as face_objects_create(), + extent_objects_create() and call them appropriately from emacs.c + The only current object property (`memusage_stats_list') that + objects can specify is a Lisp object and gets staticpro()ed so it + only needs to be set during dump time, but because it references + symbols that might not exist in a syms_of_() function, we + initialize it in vars_of_(). There is also an object property + (`num_extra_memusage_stats') that is automatically initialized based + on `memusage_stats_list'; we do that in reinit_vars_of_alloc(), + which is called after all vars_of_() functions are called. + + `disksaver' method was renamed `disksave' to correspond with the + name normally given to the function (e.g. disksave_lstream()). + + (2) Generalize the memory-usage mechanism in `buffer-memory-usage', + `window-memory-usage', `charset-memory-usage' into an object-type- + specific mechanism called by a single function + `object-memory-usage'. (Former function `object-memory-usage' + renamed to `total-object-memory-usage'). Generalize the mechanism + of different "slices" so that we can have different "classes" of + memory described and different "slices" onto each class; `t' + separates classes, `nil' separates slices. Currently we have + three classes defined: the memory of an object itself, + non-Lisp-object memory associated with the object (e.g. arrays or + dynarrs stored as fields in the object), and Lisp-object memory + associated with the object (other internal Lisp objects stored in + the object). This isn't completely finished yet and we might need + to further separate the "other internal Lisp objects" class into + two classes. + + The memory-usage mechanism uses a `struct usage_stats' (renamed + from `struct overhead_stats') to describe a malloc-view onto a set + of allocated memory (listing how much was requested and various + types of overhead) and a more general `struct generic_usage_stats' + (with a `struct usage_stats' in it) to hold all statistics about + object memory. `struct generic_usage_stats' contains an array of + 32 Bytecounts, which are statistics of unspecified semantics. The + intention is that individual types declare a corresponding struct + (e.g. `struct window_stats') with the same structure but with + specific fields in place of the array, corresponding to specific + statistics. The number of such statistics is an object property + computed from the list of tags (Lisp symbols describing the + statistics) stored in `memusage_stats_list'. The idea here is to + allow particular object types to customize the number and + semantics of the statistics where completely avoiding consing. + This doesn't matter so much yet, but the intention is to have the + memory usage of all objects computed at the end of GC, at the same + time as other statistics are currently computed. The values for + all statistics for a single type would be added up to compute + aggregate values for all objects of a specific type. To make this + efficient, we can't allow any memory allocation at all. + + (3) Create some additional functions for creating lists that + specify the elements directly as args rather than indirectly through + an array: listn() (number of args given), listu() (list terminated + by Qunbound). + + (4) Delete a bit of remaining unused C window_config stuff, also + unused lrecord_type_popup_data. + + +2010-03-18 Ben Wing <ben@xemacs.org> + + * tests.c: + * tests.c (Ftest_data_format_conversion): + Need to GCPRO newly created objects or we'll eventually get + a crash due to occurrence of call2(). + +2010-03-16 Ben Wing <ben@xemacs.org> + + * alloc.c (make_lcrecord_list): + * alloc.c (alloc_managed_lcrecord): + Fix compilation problems identified by Robert Delius Royar. + +2010-03-15 Ben Wing <ben@xemacs.org> + + * extents.c (Fprevious_single_property_change): + * extents.c (Fnext_single_char_property_change): + * extents.c (Fprevious_single_char_property_change): + Fix see-also portion of documentation string. + +2010-03-15 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (c_readonly): + * alloc.c (deadbeef_memory): + * alloc.c (make_compiled_function): + * alloc.c (make_button_data): + * alloc.c (make_motion_data): + * alloc.c (make_process_data): + * alloc.c (make_timeout_data): + * alloc.c (make_magic_data): + * alloc.c (make_magic_eval_data): + * alloc.c (make_eval_data): + * alloc.c (make_misc_user_data): + * alloc.c (noseeum_make_marker): + * alloc.c (ADDITIONAL_FREE_string): + * alloc.c (common_init_alloc_early): + * alloc.c (init_alloc_once_early): + * bytecode.c (print_compiled_function): + * bytecode.c (mark_compiled_function): + * casetab.c: + * casetab.c (print_case_table): + * console.c: + * console.c (print_console): + * database.c (print_database): + * database.c (finalize_database): + * device-msw.c (sync_printer_with_devmode): + * device-msw.c (print_devmode): + * device-msw.c (finalize_devmode): + * device.c: + * device.c (print_device): + * elhash.c: + * elhash.c (print_hash_table): + * eval.c (print_multiple_value): + * eval.c (mark_multiple_value): + * events.c (deinitialize_event): + * events.c (print_event): + * events.c (event_equal): + * extents.c: + * extents.c (soe_dump): + * extents.c (soe_insert): + * extents.c (soe_delete): + * extents.c (soe_move): + * extents.c (extent_fragment_update): + * extents.c (print_extent_1): + * extents.c (print_extent): + * extents.c (vars_of_extents): + * frame.c: + * frame.c (print_frame): + * free-hook.c: + * free-hook.c (check_free): + * glyphs.c: + * glyphs.c (print_image_instance): + * glyphs.c (print_glyph): + * gui.c: + * gui.c (copy_gui_item): + * hash.c: + * hash.c (NULL_ENTRY): + * hash.c (KEYS_DIFFER_P): + * keymap.c (print_keymap): + * keymap.c (MARKED_SLOT): + * lisp.h: + * lrecord.h: + * lrecord.h (LISP_OBJECT_UID): + * lrecord.h (set_lheader_implementation): + * lrecord.h (struct old_lcrecord_header): + * lstream.c (print_lstream): + * lstream.c (finalize_lstream): + * marker.c (print_marker): + * marker.c (marker_equal): + * mc-alloc.c (visit_all_used_page_headers): + * mule-charset.c: + * mule-charset.c (print_charset): + * objects.c (print_color_instance): + * objects.c (print_font_instance): + * objects.c (finalize_font_instance): + * opaque.c (print_opaque): + * opaque.c (print_opaque_ptr): + * opaque.c (equal_opaque_ptr): + * print.c (internal_object_printer): + * print.c (enum printing_badness): + * rangetab.c (print_range_table): + * rangetab.c (range_table_equal): + * specifier.c (print_specifier): + * specifier.c (finalize_specifier): + * symbols.c: + * symbols.c (print_symbol_value_magic): + * tooltalk.c: + * tooltalk.c (print_tooltalk_message): + * tooltalk.c (print_tooltalk_pattern): + * window.c (print_window): + * window.c (debug_print_window): + (1) Make lrecord UID's have a separate UID space for each object. + Otherwise, with 20-bit UID's, we rapidly wrap around, especially + when common objects like conses and strings increment the UID value + for every object created. (Originally I tried making two UID spaces, + one for objects that always print readably and hence don't display + the UID, and one for other objects. But certain objects like markers + for which a UID is displayed are still generated rapidly enough that + UID overflow is a serious issue.) This also has the advantage of + making UID values smaller, hence easier to remember -- their main + purpose is to make it easier to keep track of different objects of + the same type when debugging code. Make sure we dump lrecord UID's + so that we don't have problems with pdumped and non-dumped objects + having the same UID. + + (2) Display UID's consistently whenever an object (a) doesn't + consistently print readably (objects like cons and string, which + always print readably, can't display a UID), and (b) doesn't + otherwise have a unique property that makes objects of a + particular type distinguishable. (E.g. buffers didn't and still + don't print an ID, but the buffer name uniquely identifies the + buffer.) Some types, such as event, extent, compiled-function, + didn't always (or didn't ever) display an ID; others (such as + marker, extent, lstream, opaque, opaque-ptr, any object using + internal_object_printer()) used to display the actual machine + pointer instead. + + (3) Rename NORMAL_LISP_OBJECT_UID to LISP_OBJECT_UID; make it work + over all Lisp objects and take a Lisp object, not a struct pointer. + + (4) Some misc cleanups in alloc.c, elhash.c. + + (5) Change code in events.c that "deinitializes" an event so that + it doesn't increment the event UID counter in the process. Also + use deadbeef_memory() to overwrite memory instead of doing the same + with custom code. In the process, make deadbeef_memory() in + alloc.c always available, and delete extraneous copy in mc-alloc.c. + Also capitalize all uses of 0xDEADBEEF. Similarly in elhash.c + call deadbeef_memory(). + + (6) Resurrect "debug SOE" code in extents.c. Make it conditional + on DEBUG_XEMACS and on a `debug-soe' variable, rather than on + SOE_DEBUG. Make it output to stderr, not stdout. + + (7) Delete some custom print methods that were identical to + external_object_printer(). + +2010-03-12 Ben Wing <ben@xemacs.org> + + * lisp.h: + * lisp.h (redo-symbols): Removed. + Put the Lisp variables and symbols where they belong, with other + stuff related to the file they're in. + + * event-Xt.c (THIS_IS_X): + * event-Xt.c (syms_of_event_Xt): + * event-Xt.c (reinit_vars_of_event_Xt): + * event-gtk.c: + * event-gtk.c (syms_of_event_gtk): + * event-gtk.c (reinit_vars_of_event_gtk): + * event-stream.c: + * event-stream.c (syms_of_event_stream): + * event-stream.c (reinit_vars_of_event_stream): + * events.c (reinit_vars_of_events): + * events.c (vars_of_events): + `sans-modifiers' was defsymbol'ed more than once. Move it to + events-stream.c. `self-insert-command' was defsymbol'ed more than once. + Vevent_resource should be staticpro_nodump()ed as it's declared in + a reinit_*() method. + + * lread.c (vars_of_lread): + Vfile_domain wasn't staticpro'ed. + + * minibuf.c: + * minibuf.c (reinit_complex_vars_of_minibuf): + Vminibuffer_zero and Vecho_area_buffer weren't staticpro'ed. + +2010-03-12 Ben Wing <ben@xemacs.org> + + * redisplay-msw.c: + * redisplay-msw.c (mswindows_output_dibitmap_region): + * redisplay-msw.c (mswindows_output_pixmap): + * redisplay-msw.c (mswindows_clear_region): + Have a crack at implementing the `absolute' property for + background pixmaps. It seems to work; however, things don't + work quite right in relation to window sizing/moving. In particular, + ideally when you move the window the background should stay in place + but it doesn't; instead it moves, and when you hit C-l it gets + redrawn in the "proper" place. When resizing you get some serious + jitter, apparently as first the image gets moved then redrawn in + the correct offset position. #### Not sure how to fix this. + +2010-03-13 Ben Wing <ben@xemacs.org> + + * alloc.c (alloc_sized_lrecord_1): + * alloc.c (alloc_sized_lrecord_array): + * alloc.c (old_alloc_sized_lcrecord): + * alloc.c (disksave_object_finalization_1): + * alloc.c (mark_lcrecord_list): + * alloc.c (alloc_managed_lcrecord): + * alloc.c (free_managed_lcrecord): + * alloc.c (tick_lcrecord_stats): + * alloc.c (sweep_lcrecords_1): + * buffer.c (print_buffer): + * buffer.c (DEFVAR_BUFFER_LOCAL_1): + * casetab.c: + * casetab.c (print_case_table): + * console.c (print_console): + * console.c (DEFVAR_CONSOLE_LOCAL_1): + * data.c (print_weak_list): + * data.c (print_weak_box): + * data.c (print_ephemeron): + * data.c (ephemeron_equal): + * database.c (print_database): + * database.c (finalize_database): + * device-msw.c (sync_printer_with_devmode): + * device-msw.c (print_devmode): + * device-msw.c (finalize_devmode): + * device.c: + * device.c (print_device): + * elhash.c: + * elhash.c (print_hash_table): + * eval.c (print_subr): + * eval.c (print_multiple_value): + * event-stream.c (event_stream_resignal_wakeup): + * events.c (clear_event_resource): + * events.c (zero_event): + * events.c (print_event): + * extents.c: + * extents.c (print_extent): + * file-coding.c (print_coding_system): + * font-mgr.c: + * font-mgr.c (Ffc_init): + * frame.c: + * frame.c (print_frame): + * gc.c: + * gc.c (GC_CHECK_NOT_FREE): + * glyphs.c: + * glyphs.c (print_image_instance): + * glyphs.c (print_glyph): + * gui.c (print_gui_item): + * gui.c (copy_gui_item): + * keymap.c (print_keymap): + * keymap.c (MARKED_SLOT): + * lisp.h: + * lisp.h (struct Lisp_String): + * lisp.h (DEFUN): + * lisp.h (DEFUN_NORETURN): + * lrecord.h: + * lrecord.h (NORMAL_LISP_OBJECT_UID): + * lrecord.h (struct lrecord_header): + * lrecord.h (set_lheader_implementation): + * lrecord.h (struct old_lcrecord_header): + * lrecord.h (struct free_lcrecord_header): + * marker.c (print_marker): + * mule-charset.c: + * mule-charset.c (print_charset): + * objects.c (print_color_instance): + * objects.c (print_font_instance): + * objects.c (finalize_font_instance): + * print.c (print_cons): + * print.c (printing_unreadable_object_fmt): + * print.c (printing_unreadable_lisp_object): + * print.c (external_object_printer): + * print.c (internal_object_printer): + * print.c (debug_p4): + * print.c (ext_print_begin): + * process.c (print_process): + * rangetab.c (print_range_table): + * rangetab.c (range_table_equal): + * scrollbar.c (free_scrollbar_instance): + * specifier.c (print_specifier): + * specifier.c (finalize_specifier): + * symbols.c (guts_of_unbound_marker): + * symeval.h: + * symeval.h (DEFVAR_SYMVAL_FWD): + * tooltalk.c: + * tooltalk.c (print_tooltalk_message): + * tooltalk.c (print_tooltalk_pattern): + * ui-gtk.c (ffi_object_printer): + * ui-gtk.c (emacs_gtk_object_printer): + * ui-gtk.c (emacs_gtk_boxed_printer): + * window.c (print_window): + * window.c (free_window_mirror): + * window.c (debug_print_window): + * xemacs.def.in.in: + (1) printing_unreadable_object -> printing_unreadable_object_fmt. + (2) printing_unreadable_lcrecord -> printing_unreadable_lisp_object + and fix up so it no longer requires an lcrecord. + + These previous changes eliminate most of the remaining places where + the terms `lcrecord' and `lrecord' occurred outside of specialized + code. + + (3) Fairly major change: Reduce the number of words in an lcrecord + from 3 to 2. The third word consisted of a uid that duplicated the + lrecord uid, and a single free bit, which was moved into the lrecord + structure. This reduces the size of the `uid' slot from 21 bits to + 20 bits. Arguably this isn't enough -- we could easily have more than + 1,000,000 or so objects created in a session. The answer is + (a) It doesn't really matter if we overflow the uid field because + it's only used for debugging, to identify an object uniquely + (or pretty much so). + (b) If we cared about it overflowing and wanted to reduce this, + we could make it so that cons, string, float and certain other + frob-block types that never print out the uid simply don't + store a uid in them and don't increment the lrecord_uid_counter. + + (4) In conjunction with (3), create new macro NORMAL_LISP_OBJECT_UID() + and use it to abstract out the differences between NEWGC and old-GC + in accessing the `uid' value from a "normal Lisp Object pointer". + + (5) In events.c, use zero_nonsized_lisp_object() in place of custom- + written equivalent. In font-mgr.c use external_object_printer() + in place of custom-written equivalents. +2010-03-07 Ben Wing <ben@xemacs.org> + + * number.c (bignum_finalize): + * number.c (ratio_finalize): + * number.c (bigfloat_finalize): + Fix the finalizers to go with the new calling sequence. Done + previously but somehow got lost. + +2010-03-06 Ben Wing <ben@xemacs.org> + + * frame.c (change_frame_size_1): + Add a comment about where FRAME_PIXWIDTH/FRAME_PIXHEIGHT is set. + +2010-03-05 Ben Wing <ben@xemacs.org> + + * frame.c: + * frame.c (Fframe_pixel_height): + * frame.c (Fframe_displayable_pixel_height): + * frame.c (Fframe_pixel_width): + * frame.c (Fframe_displayable_pixel_width): + * frame.c (Fset_frame_pixel_height): + * frame.c (Fset_frame_displayable_pixel_height): + * frame.c (Fset_frame_pixel_width): + * frame.c (Fset_frame_displayable_pixel_width): + * frame.c (get_frame_char_size): + * frame.c (change_frame_size_1): + Make it so that `frame-pixel-height', `set-frame-pixel-height', etc. + use updated values for the displayable or total pixel size that + will reflect what will happen as of the next redisplay. This + basically means using the character-cell height and converting + on-the-fly to pixel units. In the process, make sure FRAME_CHARWIDTH/ + FRAME_CHARHEIGHT are always correct and change + get_frame_char_size() to simply use them; the old logic in that + function was inlined into change_frame_size_1(), which is the only + place that needs the logic. + +2010-03-05 Ben Wing <ben@xemacs.org> + + * frame.c: + * frame.c (frame_live_p): + * frame.c (Fframep): + * frame.c (Fdisable_frame): + * frame.c (Fenable_frame): + * frame.c (Fraise_frame): + * frame.c (Fframe_name): + * frame.c (Fset_frame_height): + * frame.c (internal_set_frame_size): + * frame.c (adjust_frame_size): + Add documentation on the different types of units used to measure + frame size. + + Add section headers to the various sections. + + Rearrange the location of some functions in the file to keep + related functions together. This especially goes for frame-sizing + functions (internal_set_frame_size() and adjust_frame_size()), + which have been moved so that they form a group with + change_frame_size() and change_frame_size_1(). + + No functionality should change. + +2010-03-05 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (old_alloc_sized_lcrecord): + * alloc.c (very_old_free_lcrecord): + * alloc.c (copy_lisp_object): + * alloc.c (zero_sized_lisp_object): + * alloc.c (zero_nonsized_lisp_object): + * alloc.c (lisp_object_storage_size): + * alloc.c (free_normal_lisp_object): + * alloc.c (FREE_FIXED_TYPE_WHEN_NOT_IN_GC): + * alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT): + * alloc.c (Fcons): + * alloc.c (noseeum_cons): + * alloc.c (make_float): + * alloc.c (make_bignum): + * alloc.c (make_bignum_bg): + * alloc.c (make_ratio): + * alloc.c (make_ratio_bg): + * alloc.c (make_ratio_rt): + * alloc.c (make_bigfloat): + * alloc.c (make_bigfloat_bf): + * alloc.c (size_vector): + * alloc.c (make_compiled_function): + * alloc.c (Fmake_symbol): + * alloc.c (allocate_extent): + * alloc.c (allocate_event): + * alloc.c (make_key_data): + * alloc.c (make_button_data): + * alloc.c (make_motion_data): + * alloc.c (make_process_data): + * alloc.c (make_timeout_data): + * alloc.c (make_magic_data): + * alloc.c (make_magic_eval_data): + * alloc.c (make_eval_data): + * alloc.c (make_misc_user_data): + * alloc.c (Fmake_marker): + * alloc.c (noseeum_make_marker): + * alloc.c (size_string_direct_data): + * alloc.c (make_uninit_string): + * alloc.c (make_string_nocopy): + * alloc.c (mark_lcrecord_list): + * alloc.c (alloc_managed_lcrecord): + * alloc.c (free_managed_lcrecord): + * alloc.c (sweep_lcrecords_1): + * alloc.c (malloced_storage_size): + * buffer.c (allocate_buffer): + * buffer.c (compute_buffer_usage): + * buffer.c (DEFVAR_BUFFER_LOCAL_1): + * buffer.c (nuke_all_buffer_slots): + * buffer.c (common_init_complex_vars_of_buffer): + * buffer.h (struct buffer_text): + * buffer.h (struct buffer): + * bytecode.c: + * bytecode.c (make_compiled_function_args): + * bytecode.c (size_compiled_function_args): + * bytecode.h (struct compiled_function_args): + * casetab.c (allocate_case_table): + * casetab.h (struct Lisp_Case_Table): + * charset.h (struct Lisp_Charset): + * chartab.c (fill_char_table): + * chartab.c (Fmake_char_table): + * chartab.c (make_char_table_entry): + * chartab.c (copy_char_table_entry): + * chartab.c (Fcopy_char_table): + * chartab.c (put_char_table): + * chartab.h (struct Lisp_Char_Table_Entry): + * chartab.h (struct Lisp_Char_Table): + * console-gtk-impl.h (struct gtk_device): + * console-gtk-impl.h (struct gtk_frame): + * console-impl.h (struct console): + * console-msw-impl.h (struct Lisp_Devmode): + * console-msw-impl.h (struct mswindows_device): + * console-msw-impl.h (struct msprinter_device): + * console-msw-impl.h (struct mswindows_frame): + * console-msw-impl.h (struct mswindows_dialog_id): + * console-stream-impl.h (struct stream_console): + * console-stream.c (stream_init_console): + * console-tty-impl.h (struct tty_console): + * console-tty-impl.h (struct tty_device): + * console-tty.c (allocate_tty_console_struct): + * console-x-impl.h (struct x_device): + * console-x-impl.h (struct x_frame): + * console.c (allocate_console): + * console.c (nuke_all_console_slots): + * console.c (DEFVAR_CONSOLE_LOCAL_1): + * console.c (common_init_complex_vars_of_console): + * data.c (make_weak_list): + * data.c (make_weak_box): + * data.c (make_ephemeron): + * database.c: + * database.c (struct Lisp_Database): + * database.c (allocate_database): + * database.c (finalize_database): + * device-gtk.c (allocate_gtk_device_struct): + * device-impl.h (struct device): + * device-msw.c: + * device-msw.c (mswindows_init_device): + * device-msw.c (msprinter_init_device): + * device-msw.c (finalize_devmode): + * device-msw.c (allocate_devmode): + * device-tty.c (allocate_tty_device_struct): + * device-x.c (allocate_x_device_struct): + * device.c: + * device.c (nuke_all_device_slots): + * device.c (allocate_device): + * dialog-msw.c (handle_question_dialog_box): + * elhash.c: + * elhash.c (struct Lisp_Hash_Table): + * elhash.c (finalize_hash_table): + * elhash.c (make_general_lisp_hash_table): + * elhash.c (Fcopy_hash_table): + * elhash.h (htentry): + * emacs.c (main_1): + * eval.c: + * eval.c (size_multiple_value): + * event-stream.c (finalize_command_builder): + * event-stream.c (allocate_command_builder): + * event-stream.c (free_command_builder): + * event-stream.c (event_stream_generate_wakeup): + * event-stream.c (event_stream_resignal_wakeup): + * event-stream.c (event_stream_disable_wakeup): + * event-stream.c (event_stream_wakeup_pending_p): + * events.h (struct Lisp_Timeout): + * events.h (struct command_builder): + * extents-impl.h: + * extents-impl.h (struct extent_auxiliary): + * extents-impl.h (struct extent_info): + * extents-impl.h (set_extent_no_chase_aux_field): + * extents-impl.h (set_extent_no_chase_normal_field): + * extents.c: + * extents.c (gap_array_marker): + * extents.c (gap_array): + * extents.c (extent_list_marker): + * extents.c (extent_list): + * extents.c (stack_of_extents): + * extents.c (gap_array_make_marker): + * extents.c (extent_list_make_marker): + * extents.c (allocate_extent_list): + * extents.c (SLOT): + * extents.c (mark_extent_auxiliary): + * extents.c (allocate_extent_auxiliary): + * extents.c (attach_extent_auxiliary): + * extents.c (size_gap_array): + * extents.c (finalize_extent_info): + * extents.c (allocate_extent_info): + * extents.c (uninit_buffer_extents): + * extents.c (allocate_soe): + * extents.c (copy_extent): + * extents.c (vars_of_extents): + * extents.h: + * faces.c (allocate_face): + * faces.h (struct Lisp_Face): + * faces.h (struct face_cachel): + * file-coding.c: + * file-coding.c (finalize_coding_system): + * file-coding.c (sizeof_coding_system): + * file-coding.c (Fcopy_coding_system): + * file-coding.h (struct Lisp_Coding_System): + * file-coding.h (MARKED_SLOT): + * fns.c (size_bit_vector): + * font-mgr.c: + * font-mgr.c (finalize_fc_pattern): + * font-mgr.c (print_fc_pattern): + * font-mgr.c (Ffc_pattern_p): + * font-mgr.c (Ffc_pattern_create): + * font-mgr.c (Ffc_name_parse): + * font-mgr.c (Ffc_name_unparse): + * font-mgr.c (Ffc_pattern_duplicate): + * font-mgr.c (Ffc_pattern_add): + * font-mgr.c (Ffc_pattern_del): + * font-mgr.c (Ffc_pattern_get): + * font-mgr.c (fc_config_create_using): + * font-mgr.c (fc_strlist_to_lisp_using): + * font-mgr.c (fontset_to_list): + * font-mgr.c (Ffc_config_p): + * font-mgr.c (Ffc_config_up_to_date): + * font-mgr.c (Ffc_config_build_fonts): + * font-mgr.c (Ffc_config_get_cache): + * font-mgr.c (Ffc_config_get_fonts): + * font-mgr.c (Ffc_config_set_current): + * font-mgr.c (Ffc_config_get_blanks): + * font-mgr.c (Ffc_config_get_rescan_interval): + * font-mgr.c (Ffc_config_set_rescan_interval): + * font-mgr.c (Ffc_config_app_font_add_file): + * font-mgr.c (Ffc_config_app_font_add_dir): + * font-mgr.c (Ffc_config_app_font_clear): + * font-mgr.c (size): + * font-mgr.c (Ffc_config_substitute): + * font-mgr.c (Ffc_font_render_prepare): + * font-mgr.c (Ffc_font_match): + * font-mgr.c (Ffc_font_sort): + * font-mgr.c (finalize_fc_config): + * font-mgr.c (print_fc_config): + * font-mgr.h: + * font-mgr.h (struct fc_pattern): + * font-mgr.h (XFC_PATTERN): + * font-mgr.h (struct fc_config): + * font-mgr.h (XFC_CONFIG): + * frame-gtk.c (allocate_gtk_frame_struct): + * frame-impl.h (struct frame): + * frame-msw.c (mswindows_init_frame_1): + * frame-x.c (allocate_x_frame_struct): + * frame.c (nuke_all_frame_slots): + * frame.c (allocate_frame_core): + * gc.c: + * gc.c (GC_CHECK_NOT_FREE): + * glyphs.c (finalize_image_instance): + * glyphs.c (allocate_image_instance): + * glyphs.c (Fcolorize_image_instance): + * glyphs.c (allocate_glyph): + * glyphs.c (unmap_subwindow_instance_cache_mapper): + * glyphs.c (register_ignored_expose): + * glyphs.h (struct Lisp_Image_Instance): + * glyphs.h (struct Lisp_Glyph): + * glyphs.h (struct glyph_cachel): + * glyphs.h (struct expose_ignore): + * gui.c (allocate_gui_item): + * gui.h (struct Lisp_Gui_Item): + * keymap.c (struct Lisp_Keymap): + * keymap.c (make_keymap): + * lisp.h: + * lisp.h (struct Lisp_String_Direct_Data): + * lisp.h (struct Lisp_String_Indirect_Data): + * lisp.h (struct Lisp_Vector): + * lisp.h (struct Lisp_Bit_Vector): + * lisp.h (DECLARE_INLINE_LISP_BIT_VECTOR): + * lisp.h (struct weak_box): + * lisp.h (struct ephemeron): + * lisp.h (struct weak_list): + * lrecord.h: + * lrecord.h (struct lrecord_implementation): + * lrecord.h (MC_ALLOC_CALL_FINALIZER): + * lrecord.h (struct lcrecord_list): + * lstream.c (finalize_lstream): + * lstream.c (sizeof_lstream): + * lstream.c (Lstream_new): + * lstream.c (Lstream_delete): + * lstream.h (struct lstream): + * marker.c: + * marker.c (finalize_marker): + * marker.c (compute_buffer_marker_usage): + * mule-charset.c: + * mule-charset.c (make_charset): + * mule-charset.c (compute_charset_usage): + * objects-impl.h (struct Lisp_Color_Instance): + * objects-impl.h (struct Lisp_Font_Instance): + * objects-tty-impl.h (struct tty_color_instance_data): + * objects-tty-impl.h (struct tty_font_instance_data): + * objects-tty.c (tty_initialize_color_instance): + * objects-tty.c (tty_initialize_font_instance): + * objects.c (finalize_color_instance): + * objects.c (Fmake_color_instance): + * objects.c (finalize_font_instance): + * objects.c (Fmake_font_instance): + * objects.c (reinit_vars_of_objects): + * opaque.c: + * opaque.c (sizeof_opaque): + * opaque.c (make_opaque_ptr): + * opaque.c (free_opaque_ptr): + * opaque.h: + * opaque.h (Lisp_Opaque): + * opaque.h (Lisp_Opaque_Ptr): + * print.c (printing_unreadable_lcrecord): + * print.c (external_object_printer): + * print.c (debug_p4): + * process.c (finalize_process): + * process.c (make_process_internal): + * procimpl.h (struct Lisp_Process): + * rangetab.c (Fmake_range_table): + * rangetab.c (Fcopy_range_table): + * rangetab.h (struct Lisp_Range_Table): + * scrollbar.c: + * scrollbar.c (create_scrollbar_instance): + * scrollbar.c (compute_scrollbar_instance_usage): + * scrollbar.h (struct scrollbar_instance): + * specifier.c (finalize_specifier): + * specifier.c (sizeof_specifier): + * specifier.c (set_specifier_caching): + * specifier.h (struct Lisp_Specifier): + * specifier.h (struct specifier_caching): + * symeval.h: + * symeval.h (SYMBOL_VALUE_MAGIC_P): + * symeval.h (DEFVAR_SYMVAL_FWD): + * symsinit.h: + * syntax.c (init_buffer_syntax_cache): + * syntax.h (struct syntax_cache): + * toolbar.c: + * toolbar.c (allocate_toolbar_button): + * toolbar.c (update_toolbar_button): + * toolbar.h (struct toolbar_button): + * tooltalk.c (struct Lisp_Tooltalk_Message): + * tooltalk.c (make_tooltalk_message): + * tooltalk.c (struct Lisp_Tooltalk_Pattern): + * tooltalk.c (make_tooltalk_pattern): + * ui-gtk.c: + * ui-gtk.c (allocate_ffi_data): + * ui-gtk.c (emacs_gtk_object_finalizer): + * ui-gtk.c (allocate_emacs_gtk_object_data): + * ui-gtk.c (allocate_emacs_gtk_boxed_data): + * ui-gtk.h: + * window-impl.h (struct window): + * window-impl.h (struct window_mirror): + * window.c (finalize_window): + * window.c (allocate_window): + * window.c (new_window_mirror): + * window.c (mark_window_as_deleted): + * window.c (make_dummy_parent): + * window.c (compute_window_mirror_usage): + * window.c (compute_window_usage): + + Overall point of this change and previous ones in this repository: + + (1) Introduce new, clearer terminology: everything other than int + or char is a "record" object, which comes in two types: "normal + objects" and "frob-block objects". Fix up all places that + referred to frob-block objects as "simple", "basic", etc. + + (2) Provide an advertised interface for doing operations on Lisp + objects, including creating new types, that is clean and + consistent in its naming, uses the above-referenced terms and + avoids referencing "lrecords", "old lcrecords", etc., which should + hide under the surface. + + (3) Make the size_in_bytes and finalizer methods take a + Lisp_Object rather than a void * for consistency with other methods. + + (4) Separate finalizer method into finalizer and disksaver, so + that normal finalize methods don't have to worry about disksaving. + + Other specifics: + + (1) Renaming: + + LISP_OBJECT_HEADER -> NORMAL_LISP_OBJECT_HEADER + ALLOC_LISP_OBJECT -> ALLOC_NORMAL_LISP_OBJECT + implementation->basic_p -> implementation->frob_block_p + ALLOCATE_FIXED_TYPE_AND_SET_IMPL -> ALLOC_FROB_BLOCK_LISP_OBJECT + *FCCONFIG*, wrap_fcconfig -> *FC_CONFIG*, wrap_fc_config + *FCPATTERN*, wrap_fcpattern -> *FC_PATTERN*, wrap_fc_pattern + + (the last two changes make the naming of these macros consistent + with the naming of all other macros, since the objects are named + fc-config and fc-pattern with a hyphen) + + (2) Lots of documentation fixes in lrecord.h. + + (3) Eliminate macros for copying, freeing, zeroing objects, getting + their storage size. Instead, new functions: + + zero_sized_lisp_object() + zero_nonsized_lisp_object() + lisp_object_storage_size() + free_normal_lisp_object() + (copy_lisp_object() already exists) + LISP_OBJECT_FROB_BLOCK_P() (actually a macro) + + Eliminated: + + free_lrecord() + zero_lrecord() + copy_lrecord() + copy_sized_lrecord() + old_copy_lcrecord() + old_copy_sized_lcrecord() + old_zero_lcrecord() + old_zero_sized_lcrecord() + LISP_OBJECT_STORAGE_SIZE() + COPY_SIZED_LISP_OBJECT() + COPY_SIZED_LCRECORD() + COPY_LISP_OBJECT() + ZERO_LISP_OBJECT() + FREE_LISP_OBJECT() + + (4) Catch the remaining places where lrecord stuff was used directly + and use the advertised interface, e.g. alloc_sized_lrecord() -> + ALLOC_SIZED_LISP_OBJECT(). + + (5) Make certain statically-declared pseudo-objects + (buffer_local_flags, console_local_flags) have their lheader + initialized correctly, so things like copy_lisp_object() can work + on them. Make extent_auxiliary_defaults a proper heap object + Vextent_auxiliary_defaults, and make extent auxiliaries dumpable + so that this object can be dumped. allocate_extent_auxiliary() + now just creates the object, and attach_extent_auxiliary() + creates an extent auxiliary and attaches to an extent, like the + old allocate_extent_auxiliary(). + + (6) Create EXTENT_AUXILIARY_SLOTS macro, similar to the foo-slots.h + files but in a macro instead of a file. The purpose is to avoid + duplication when iterating over all the slots in an extent auxiliary. + Use it. + + (7) In lstream.c, don't zero out object after allocation because + allocation routines take care of this. + + (8) In marker.c, fix a mistake in computing marker overhead. + + (9) In print.c, clean up printing_unreadable_lcrecord(), + external_object_printer() to avoid lots of ifdef NEW_GC's. + + (10) Separate toolbar-button allocation into a separate + allocate_toolbar_button() function for use in the example code + in lrecord.h. + +2010-01-20 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (very_old_free_lcrecord): + * alloc.c (disksave_object_finalization_1): + * alloc.c (make_lcrecord_list): + * alloc.c (alloc_managed_lcrecord): + * alloc.c (free_managed_lcrecord): + * alloc.c (sweep_lcrecords_1): + * buffer.c: + * bytecode.c: + * bytecode.c (Fcompiled_function_p): + * chartab.c: + * console-impl.h: + * console-impl.h (CONSOLE_TYPE_P): + * console.c: + * console.c (set_quit_events): + * data.c: + * data.c (Fmake_ephemeron): + * database.c: + * database.c (finalize_database): + * database.c (Fclose_database): + * device-msw.c: + * device-msw.c (finalize_devmode): + * device-msw.c (allocate_devmode): + * device.c: + * elhash.c: + * elhash.c (finalize_hash_table): + * eval.c: + * eval.c (bind_multiple_value_limits): + * event-stream.c: + * event-stream.c (finalize_command_builder): + * events.c: + * events.c (mark_event): + * extents.c: + * extents.c (finalize_extent_info): + * extents.c (uninit_buffer_extents): + * faces.c: + * file-coding.c: + * file-coding.c (finalize_coding_system): + * file-coding.h: + * file-coding.h (struct coding_system_methods): + * file-coding.h (struct detector): + * floatfns.c: + * floatfns.c (extract_float): + * fns.c: + * fns.c (Fidentity): + * font-mgr.c (finalize_fc_pattern): + * font-mgr.c (finalize_fc_config): + * frame.c: + * glyphs.c: + * glyphs.c (finalize_image_instance): + * glyphs.c (unmap_subwindow_instance_cache_mapper): + * gui.c: + * gui.c (gui_error): + * keymap.c: + * lisp.h (struct Lisp_Symbol): + * lrecord.h: + * lrecord.h (struct lrecord_implementation): + * lrecord.h (MC_ALLOC_CALL_FINALIZER): + * lrecord.h (MC_ALLOC_CALL_FINALIZER_FOR_DISKSAVE): + * lrecord.h (DEFINE_DUMPABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_SIZABLE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_SIZABLE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_INTERNAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT): + * lrecord.h (MAKE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_DUMPABLE_MODULE_SIZABLE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_GENERAL_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT): + * lrecord.h (DEFINE_NODUMP_MODULE_SIZABLE_GENERAL_LISP_OBJECT): + * lrecord.h (MAKE_MODULE_LISP_OBJECT): + * lstream.c: + * lstream.c (finalize_lstream): + * lstream.c (disksave_lstream): + * marker.c: + * marker.c (finalize_marker): + * mule-charset.c (make_charset): + * number.c: + * objects.c: + * objects.c (finalize_color_instance): + * objects.c (finalize_font_instance): + * opaque.c: + * opaque.c (make_opaque_ptr): + * process-nt.c: + * process-nt.c (nt_finalize_process_data): + * process-nt.c (nt_deactivate_process): + * process.c: + * process.c (finalize_process): + * procimpl.h (struct process_methods): + * scrollbar.c: + * scrollbar.c (free_scrollbar_instance): + * specifier.c (finalize_specifier): + * symbols.c: + * toolbar.c: + * toolbar.c (Ftoolbar_button_p): + * tooltalk.c: + * ui-gtk.c: + * ui-gtk.c (emacs_gtk_object_finalizer): + * ui-gtk.c (allocate_emacs_gtk_boxed_data): + * window.c: + * window.c (finalize_window): + * window.c (mark_window_as_deleted): + + Separate out regular and disksave finalization. Instead of a + FOR_DISKSAVE argument to the finalizer, create a separate object + method `disksaver'. Make `finalizer' have only one argument. + + Go through and separate out all finalize methods into finalize + and disksave. Delete lots of thereby redundant disksave checking. + Delete places that signal an error if we attempt to disksave -- + all of these objects are non-dumpable and we will get an error + from pdump anyway if we attempt to dump them. After this is done, + only one object remains that has a disksave method -- lstream. + + Change DEFINE_*_LISP_OBJECT_WITH_PROPS to DEFINE_*_GENERAL_LISP_OBJECT, + which is used for specifying either property methods or disksave + methods (or in the future, any other less-used methods). + + Remove the for_disksave argument to finalize_process_data. Don't + provide a disksaver for processes because no one currently needs + it. + + Clean up various places where objects didn't provide a print method. + It was made mandatory in previous changes, and all methods now + either provide their own print method or use internal_object_printer + or external_object_printer. + + Change the definition of CONSOLE_LIVE_P to use the contype enum + rather than looking into the conmeths structure -- in some weird + situations with dead objects, the conmeths structure is NULL, + and printing such objects from debug_print() will crash if we try + to look into the conmeths structure. + + +2005-11-22 Ben Wing <ben@xemacs.org> + + * alloc.c: + * alloc.c (assert_proper_sizing): + * alloc.c (alloc_sized_lrecord_1): + * alloc.c (alloc_sized_lrecord): + * alloc.c (noseeum_alloc_sized_lrecord): + * alloc.c (alloc_lrecord): + * alloc.c (old_alloc_sized_lcrecord): + * alloc.c (make_vector_internal): + * alloc.c (make_bit_vector_internal): + * alloc.c (alloc_automanaged_sized_lcrecord): + * buffer.c (allocate_buffer): + * buffer.c (DEFVAR_BUFFER_LOCAL_1): + * buffer.c (common_init_complex_vars_of_buffer): + * casetab.c (allocate_case_table): + * chartab.c (Fmake_char_table): + * chartab.c (make_char_table_entry): + * chartab.c (copy_char_table_entry): + * chartab.c (Fcopy_char_table): + * console.c (allocate_console): + * console.c (DEFVAR_CONSOLE_LOCAL_1): + * console.c (common_init_complex_vars_of_console): + * data.c (make_weak_list): + * data.c (make_weak_box): + * data.c (make_ephemeron): + * database.c (allocate_database): + * device-msw.c (allocate_devmode): + * device.c (allocate_device): + * dialog-msw.c (handle_question_dialog_box): + * elhash.c (make_general_lisp_hash_table): + * elhash.c (Fcopy_hash_table): + * emacs.c (main_1): + * event-stream.c: + * event-stream.c (allocate_command_builder): + * event-stream.c (free_command_builder): + * event-stream.c (mark_timeout): + * event-stream.c (event_stream_generate_wakeup): + * event-stream.c (event_stream_resignal_wakeup): + * event-stream.c (event_stream_disable_wakeup): + * event-stream.c (reinit_vars_of_event_stream): + * extents.c (allocate_extent_auxiliary): + * extents.c (allocate_extent_info): + * extents.c (copy_extent): + * faces.c (allocate_face): + * file-coding.c (allocate_coding_system): + * frame.c (allocate_frame_core): + * glyphs.c (allocate_image_instance): + * glyphs.c (allocate_glyph): + * gui.c (allocate_gui_item): + * keymap.c (make_keymap): + * lrecord.h: + * lrecord.h (ALLOC_LCRECORD): + * lrecord.h (ALLOC_SIZED_LCRECORD): + * lrecord.h (struct old_lcrecord_header): + * lrecord.h (old_alloc_lcrecord_type): + * lrecord.h (alloc_lrecord_type): + * lrecord.h (noseeum_alloc_lrecord_type): + * lstream.c (Lstream_new): + * mule-charset.c (make_charset): + * objects.c (Fmake_color_instance): + * objects.c (Fmake_font_instance): + * objects.c (reinit_vars_of_objects): + * opaque.c (make_opaque): + * opaque.c (make_opaque_ptr): + * process.c (make_process_internal): + * rangetab.c (Fmake_range_table): + * rangetab.c (Fcopy_range_table): + * scrollbar.c (create_scrollbar_instance): + * specifier.c (make_specifier_internal): + * symbols.c (Fdefvaralias): + * toolbar.c (update_toolbar_button): + * tooltalk.c (make_tooltalk_message): + * tooltalk.c (make_tooltalk_pattern): + * ui-gtk.c (allocate_ffi_data): + * ui-gtk.c (allocate_emacs_gtk_object_data): + * ui-gtk.c (allocate_emacs_gtk_boxed_data): + * window.c (allocate_window): + * window.c (new_window_mirror): + * window.c (make_dummy_parent): + Create a simpler interface for allocating/declaring Lisp objects; + documented in lrecord.h. + + ALLOC_LCRECORD_TYPE -> ALLOC_LISP_OBJECT (returns a Lisp object + rather than a pointer), + BASIC_ALLOC_LCRECORD -> ALLOC_SIZED_LISP_OBJECT + DEFINE_LRECORD_IMPLEMENTATION -> DEFINE_*_LISP_OBJECT + DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION -> DEFINE_*SIZABLE_*LISP_OBJECT + DEFINE_LRECORD_*IMPLEMENTATION_WITH_PROPS -> DEFINE_*GENERAL_LISP_OBJECT + DEFINE_BASIC_LRECORD_IMPLEMENTATION -> DEFINE_*FROB_BLOCK_LISP_OBJECT + DEFINE_DUMPABLE_*/DEFINE_NODUMP_* instead of a 0 or 1 dumpable flag + DEFINE_*INTERNAL_* for "internal" Lisp objects (shouldn't escape + to Lisp) + DEFINE_EXTERNAL_* -> DEFINE_MODULE_* + MAKE_LRECORD_IMPLEMENTATION -> MAKE_LISP_OBJECT + MAKE_EXTERNAL_LRECORD_IMPLEMENTATION -> MAKE_MODULE_LISP_OBJECT + DECLARE_LRECORD -> DECLARE_LISP_OBJECT + INIT_LRECORD_IMPLEMENTATION -> INIT_LISP_OBJECT + alloc_lrecord -> alloc_sized_lrecord (since it takes a size) + + Dynarr_newf, Dynarr_lisp_newf: takes a Bytecount instead of an int + +2010-03-05 Ben Wing <ben@xemacs.org> + + * mule-coding.c: + * mule-coding.c (iso2022_encode): + Horrible bug: `escape-quoted' was failing to escape-quote special + characters in the 0x80 - 0x9F range. Who knows what breakage ensued? + SAME BUG IN XEMACS 21.4; MUST BE FIXED THERE TOO. + +2010-03-03 Ben Wing <ben@xemacs.org> + + * lrecord.h: Fix outdated comment. + +2010-03-03 Ben Wing <ben@xemacs.org> + + * emacs.c: + * emacs.c (assert_equal_failed): + * lisp.h: + * lisp.h (assert_equal): + New fun assert_equal, asserting that two values == each other, and + printing out both values upon failure. + + * frame-gtk.c (gtk_initialize_frame_size): + * frame-impl.h: + * frame-impl.h (FRAME_TOP_INTERNAL_BORDER_START): + * frame-impl.h (FRAME_BOTTOM_INTERNAL_BORDER_START): + * frame-impl.h (FRAME_LEFT_INTERNAL_BORDER_START): + * frame-impl.h (FRAME_PANED_TOP_EDGE): + * frame-impl.h (FRAME_NONPANED_SIZE): + * frame-x.c (x_initialize_frame_size): + * frame.c: + * gutter.c (get_gutter_coords): + * gutter.c (calculate_gutter_size): + * gutter.h: + * gutter.h (WINDOW_REAL_TOP_GUTTER_BOUNDS): + * gutter.h (FRAME_TOP_GUTTER_BOUNDS): + * input-method-xlib.c: + * input-method-xlib.c (XIM_SetGeometry): + * redisplay-output.c (clear_left_border): + * redisplay-output.c (clear_right_border): + * redisplay-output.c (redisplay_output_pixmap): + * redisplay-output.c (redisplay_clear_region): + * redisplay-output.c (redisplay_clear_top_of_window): + * redisplay-output.c (redisplay_clear_to_window_end): + * redisplay-xlike-inc.c (XLIKE_clear_frame): + * redisplay.c: + * redisplay.c (UPDATE_CACHE_RETURN): + * redisplay.c (pixel_to_glyph_translation): + * toolbar.c (update_frame_toolbars_geometry): + * window.c (Fwindow_pixel_edges): + Get rid of some redundant macros. Consistently use the + FRAME_TOP_*_START, FRAME_RIGHT_*_END, etc. format. Rename + FRAME_*_BORDER_* to FRAME_*_INTERNAL_BORDER_*. Comment out + FRAME_BOTTOM_* for gutters and the paned area due to the + uncertainty over where the paned area actually begins. (Eventually + we should probably move the gutters outside the minibuffer so that + the paned area is contiguous.) Use FRAME_PANED_* more often in the + code to make things clearer. + + Update the diagram to show that the bottom gutter is inside the + minibuffer (!) and that there are "junk boxes" when you have left + and/or right gutters (dead boxes that are mistakenly left uncleared, + unlike the corresponding scrollbar dead boxes). Update the text + appropriately to cover the bottom gutter position, etc. + + Rewrite gutter-geometry code to use the FRAME_*_GUTTER_* in place of + equivalent expressions referencing other frame elements, to make the + code more portable in case we move around the gutter location. + + Cleanup FRAME_*_GUTTER_BOUNDS() in gutter.h. + + Add some #### GEOM! comments where I think code is incorrect -- + typically, it wasn't fixed up properly when the gutter was added. + + Some cosmetic changes. + +2010-03-02 Ben Wing <ben@xemacs.org> + + * lisp.h: + * text.h: + Move inclusion point of text.h earlier in lisp.h -- just before + the definition of characters, which needs some of the stuff in + text.h. With text.h later, some basic character properties had to + be defined in lisp.h -- put them back into text.h where they belong. + Move some text in lisp.h at the point of text.h inclusion into + text.h -- it serves as a mini-introduction. + +2010-03-02 Ben Wing <ben@xemacs.org> + + * Makefile.in.in: + * Makefile.in.in (objs): + glyphs-shared.o, glyphs-eimage.o only needed when HAVE_WINDOW_SYSTEM. + glyphs-widget.o should be too, but we need a bit of work ifdeffing + out the subwindow stuff from redisplay.c et al. + + * bytecode.c (init_opcode_table_multi_op): + Change var name to avoid shadowing with `basename'. + + * emacs.c (main_1): + Don't call init/etc. routines for glyphs-shared, glyphs-eimage unless + HAVE_WINDOW_SYSTEM is defined. + + * linuxplay.c: + * linuxplay.c (sighandler): + * vdb-posix.c (vdb_fault_handler): + Use const for variables holding string constants to avoid C++ + warnings. + +2010-03-02 Jerry James <james@xemacs.org> + + * lread.c (read_atom): Signal a read error upon encountering a + ratio constant with a zero denominator. + +2010-03-03 Aidan Kehoe <kehoea@parhasard.net> + + * fns.c (Fsubstring): Removed. + * search.c (Freplace_match): + * minibuf.c (Ftry_completion): + * lisp.h: + * keymap.c (ensure_meta_prefix_char_keymapp): + * dired.c (user_name_completion, file_name_completion): + * console-x.c (x_canonicalize_console_connection): + * bytecode.c (Bsubseq): + * bytecode-ops.h (subseq): + Move #'substring to Lisp, as an alias for #'subseq; change all + C Fsubstring() calls to Fsubseq(), change the Bsubstring bytecode + to Bsubseq. + + Motivation; not accepting vectors in #'substring is incompatible + with GNU, and Common Lisp prefers #'subseq, it has no #'substring. + +2010-03-02 Aidan Kehoe <kehoea@parhasard.net> + + * eval.c (print_multiple_value): + Say #<INTERNAL OBJECT (XEmacs bug?) ...> when printing these, for + consistency with the rest of the print code. + +2010-03-01 Aidan Kehoe <kehoea@parhasard.net> + + * lisp.h (PARSE_KEYWORDS): New macro, for parsing keyword + arguments from C subrs. + * elhash.c (Fmake_hash_table): Use it. + * general-slots.h (Q_allow_other_keys): Add this symbol. + * eval.c (non_nil_allow_other_keys_p): + (invalid_keyword_argument): + New functions, called from the keyword argument parsing code. + * data.c (init_errors_once_early): + Add the new invalid-keyword-argument error here. + +2010-02-26 Aidan Kehoe <kehoea@parhasard.net> + + * file-coding.c (Fmake_coding_system_internal): + Be somewhat clearer in this docstring, especially for the sake of + people running non-Mule builds who will see this docstring when + they do F1 f make-coding-system RET. + +2010-02-25 Didier Verna <didier@xemacs.org> + + The background-placement face property. + * console-x-impl.h (struct x_frame): Add new slots x and y. + * console-x-impl.h (FRAME_X_X, FRAME_X_Y): New slot accessors. + * console-gtk-impl.h: Fake something similar for potential port. + * frame-x.c (x_get_frame_text_position): New function. + * frame-x.c (x_init_frame_3): Use it. + * event-Xt.c (emacs_Xt_handle_magic_event): Eat spurious + ConfigureNotify events, get the frame position and mark frame + faces changed. + * objects-impl.h: The face_background_placement_specifier + structure and its accessors. + * objects.c: New symbols Qabsolute and Qrelative. + * objects.c (face_background_placement_create): + * objects.c (face_background_placement_mark): + * objects.c (face_background_placement_instantiate): + * objects.c (face_background_placement_validate): + * objects.c (face_background_placement_after_change): + * objects.c (set_face_background_placement_attached_to): New. + * objects.h (set_face_background_palcement_attached_to): Declare + the one above. + * objects.c (syms_of_objects): + * objects.c (specifier_type_create_objects): + * objects.c (reinit_specifier_type_create_objects): + * objects.c (reinit_vars_of_objects): Update for the modifications + above. + * console-xlike-inc.h (XLIKE_GC_TS_X_ORIGIN, XLIKE_GC_TS_X_ORIGIN): + New X11/Gtk compatibility macros. + * redisplay-xlike-inc.c (XLIKE_get_gc): Add a background placement + argument and handle it. + * gtk-glue.c (face_to_gc): + * redisplay-xlike-inc.c (XLIKE_output_string): + * redisplay-xlike-inc.c (XLIKE_output_pixmap): + * redisplay-xlike-inc.c (XLIKE_output_blank): + * redisplay-xlike-inc.c (XLIKE_output_horizontal_line): + * redisplay-xlike-inc.c (XLIKE_output_eol_cursor): Update + accordingly. + * console-impl.h (struct console_methods): Add a background + placement (Lisp_Object) argument to the clear_region method. + * console-stream.c (stream_clear_region): + * redisplay-tty.c (tty_clear_region): + * redisplay-msw.c (mswindows_clear_region): + * redisplay-xlike-inc.c (XLIKE_clear_region): Update accordingly. + * redisplay-output.c (redisplay_clear_region): Handle the + background placement property and update the call to the + clear_region method. + * faces.h (struct Lisp_Face): + * faces.h (struct face_cachel): Add a background placement slot. + * faces.h (WINDOW_FACE_CACHEL_BACKGROUND_PLACEMENT): New accessor. + * faces.c (mark_face): + * faces.c (face_equal): + * faces.c (face_getprop): + * faces.c (face_putprop): + * faces.c (face_remprop): + * faces.c (face_plist): + * faces.c (reset_face): + * faces.c (mark_face_cachels): + * faces.c (update_face_cachel_data): + * faces.c (merge_face_cachel_data): + * faces.c (reset_face_cachel): + * faces.c (Fmake_face): + * faces.c (Fcopy_face): Handle the background placement property. + * faces.c (syms_of_faces): + * faces.c (vars_of_faces): + * faces.c (complex_vars_of_faces): Update accordingly. + +2010-02-25 Ben Wing <ben@xemacs.org> + + * frame-impl.h: + Create some new macros for more clearly getting the size/edges + of various rectangles surrounding the paned area. + * frame.c (change_frame_size_1): + Use the new macros. Clean up change_frame_size_1 and make sure + the internal border width gets taken into account -- that was what + was causing the clipped bottom and right. + +2010-02-25 Ben Wing <ben@xemacs.org> + + * EmacsFrame.c (EmacsFrameSetValues): + * frame-impl.h: + * frame-impl.h (struct frame): + * frame-impl.h (FRAME_THEORETICAL_TOP_TOOLBAR_HEIGHT): + * frame-impl.h (FRAME_THEORETICAL_TOP_TOOLBAR_BORDER_WIDTH): + * frame-impl.h (FRAME_REAL_TOP_TOOLBAR_HEIGHT): + * frame-impl.h (FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH): + * frame-impl.h (FRAME_REAL_TOP_TOOLBAR_VISIBLE): + * frame-impl.h (FRAME_REAL_TOP_TOOLBAR_BOUNDS): + * frame.h: + * frame.h (enum edge_pos): + * gutter.c: + * gutter.c (get_gutter_coords): + * gutter.c (display_boxes_in_gutter_p): + * gutter.c (construct_window_gutter_spec): + * gutter.c (calculate_gutter_size_from_display_lines): + * gutter.c (calculate_gutter_size): + * gutter.c (output_gutter): + * gutter.c (clear_gutter): + * gutter.c (mark_gutters): + * gutter.c (gutter_extent_signal_changed_region_maybe): + * gutter.c (update_gutter_geometry): + * gutter.c (update_frame_gutter_geometry): + * gutter.c (update_frame_gutters): + * gutter.c (reset_gutter_display_lines): + * gutter.c (redraw_exposed_gutter): + * gutter.c (redraw_exposed_gutters): + * gutter.c (free_frame_gutters): + * gutter.c (decode_gutter_position): + * gutter.c (Fset_default_gutter_position): + * gutter.c (Fgutter_pixel_width): + * gutter.c (Fgutter_pixel_height): + * gutter.c (recompute_overlaying_specifier): + * gutter.c (gutter_specs_changed_1): + * gutter.c (gutter_specs_changed): + * gutter.c (top_gutter_specs_changed): + * gutter.c (bottom_gutter_specs_changed): + * gutter.c (left_gutter_specs_changed): + * gutter.c (right_gutter_specs_changed): + * gutter.c (gutter_geometry_changed_in_window): + * gutter.c (init_frame_gutters): + * gutter.c (specifier_vars_of_gutter): + * gutter.h: + * gutter.h (WINDOW_REAL_TOP_GUTTER_BOUNDS): + * gutter.h (FRAME_TOP_GUTTER_BOUNDS): + * lisp.h (enum edge_style): + * native-gtk-toolbar.c: + * native-gtk-toolbar.c (gtk_output_toolbar): + * native-gtk-toolbar.c (gtk_clear_toolbar): + * native-gtk-toolbar.c (gtk_output_frame_toolbars): + * native-gtk-toolbar.c (gtk_initialize_frame_toolbars): + * toolbar-msw.c: + * toolbar-msw.c (TOOLBAR_HANDLE): + * toolbar-msw.c (allocate_toolbar_item_id): + * toolbar-msw.c (mswindows_clear_toolbar): + * toolbar-msw.c (mswindows_output_toolbar): + * toolbar-msw.c (mswindows_move_toolbar): + * toolbar-msw.c (mswindows_redraw_exposed_toolbars): + * toolbar-msw.c (mswindows_initialize_frame_toolbars): + * toolbar-msw.c (mswindows_output_frame_toolbars): + * toolbar-msw.c (mswindows_clear_frame_toolbars): + * toolbar-msw.c (DELETE_TOOLBAR): + * toolbar-msw.c (mswindows_free_frame_toolbars): + * toolbar-msw.c (mswindows_get_toolbar_button_text): + * toolbar-xlike.c: + * toolbar-xlike.c (__prepare_button_area): + * toolbar-xlike.c (XLIKE_OUTPUT_BUTTONS_LOOP): + * toolbar-xlike.c (xlike_output_toolbar): + * toolbar-xlike.c (xlike_clear_toolbar): + * toolbar-xlike.c (xlike_output_frame_toolbars): + * toolbar-xlike.c (xlike_clear_frame_toolbars): + * toolbar-xlike.c (xlike_redraw_exposed_toolbar): + * toolbar-xlike.c (xlike_redraw_exposed_toolbars): + * toolbar-xlike.c (xlike_redraw_frame_toolbars): + * toolbar.c: + * toolbar.c (decode_toolbar_position): + * toolbar.c (Fset_default_toolbar_position): + * toolbar.c (mark_frame_toolbar_buttons_dirty): + * toolbar.c (compute_frame_toolbar_buttons): + * toolbar.c (set_frame_toolbar): + * toolbar.c (compute_frame_toolbars_data): + * toolbar.c (update_frame_toolbars_geometry): + * toolbar.c (init_frame_toolbars): + * toolbar.c (get_toolbar_coords): + * toolbar.c (CHECK_TOOLBAR): + * toolbar.c (toolbar_buttons_at_pixpos): + * toolbar.c (CTB_ERROR): + * toolbar.c (recompute_overlaying_specifier): + * toolbar.c (specifier_vars_of_toolbar): + * toolbar.h: + * toolbar.h (SET_TOOLBAR_WAS_VISIBLE_FLAG): + Create new enum edge_pos with TOP_EDGE, BOTTOM_EDGE, LEFT_EDGE, + RIGHT_EDGE; subsume TOP_BORDER, TOP_GUTTER, enum toolbar_pos, + enum gutter_pos, etc. + + Create EDGE_POS_LOOP, subsuming GUTTER_POS_LOOP. + + Create NUM_EDGES, use in many places instead of hardcoded '4'. + + Instead of top_toolbar_was_visible, bottom_toolbar_was_visible, + etc. make an array toolbar_was_visible[NUM_EDGES]. This increases + the frame size by 15 bytes or so (could be 3 if we use Boolbytes) + but hardly seems w to matter -- frames are heavy weight objects + anyway. Same with top_gutter_was_visible, etc. + + Remove duplicated SET_TOOLBAR_WAS_VISIBLE_FLAG and put defn in + one place (toolbar.h). + +2010-02-24 Didier Verna <didier@xemacs.org> + + Modify XLIKE_get_gc's prototype. + * redisplay-xlike-inc.c (XLIKE_get_gc): Take a frame instead of a + device as first argument. + * redisplay-xlike-inc.c (XLIKE_output_string): Update caller. + * redisplay-xlike-inc.c (XLIKE_output_pixmap): Ditto. + * redisplay-xlike-inc.c (XLIKE_output_blank): Ditto. + * redisplay-xlike-inc.c (XLIKE_output_horizontal_line): Ditto. + * redisplay-xlike-inc.c (XLIKE_clear_region): Ditto. + * redisplay-xlike-inc.c (XLIKE_output_eol_cursor): Ditto. + * console-gtk.h (gtk_get_gc): Take a frame instead of a device as + first argument. + * gtk-glue.c (face_to_gc): Update caller. + +2010-02-24 Didier Verna <didier@xemacs.org> + + * glyphs.c: Clarify comment about potential_pixmap_file_instantiator. + * glyphs.c (xbm_mask_file_munging): Clarify comment, remove + unreachable condition and provide a cuple of assertions. + * glyphs.c (xbm_normalize): Clarify comments, error on mask file + not found. + * glyphs.c (xface_normalize): Ditto, and handle inline data properly. + 2010-02-22 Ben Wing <ben@xemacs.org> * EmacsFrame.c:
--- a/src/EmacsFrame.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/EmacsFrame.c Mon Mar 29 21:28:13 2010 -0500 @@ -411,49 +411,49 @@ if (cur->emacs_frame.top_toolbar_height != new_->emacs_frame.top_toolbar_height) Fadd_spec_to_specifier - (Vtoolbar_size[TOP_TOOLBAR], + (Vtoolbar_size[TOP_EDGE], make_int (new_->emacs_frame.top_toolbar_height), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.bottom_toolbar_height != new_->emacs_frame.bottom_toolbar_height) Fadd_spec_to_specifier - (Vtoolbar_size[BOTTOM_TOOLBAR], + (Vtoolbar_size[BOTTOM_EDGE], make_int (new_->emacs_frame.bottom_toolbar_height), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.left_toolbar_width != new_->emacs_frame.left_toolbar_width) Fadd_spec_to_specifier - (Vtoolbar_size[LEFT_TOOLBAR], + (Vtoolbar_size[LEFT_EDGE], make_int (new_->emacs_frame.left_toolbar_width), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.right_toolbar_width != new_->emacs_frame.right_toolbar_width) Fadd_spec_to_specifier - (Vtoolbar_size[RIGHT_TOOLBAR], + (Vtoolbar_size[RIGHT_EDGE], make_int (new_->emacs_frame.right_toolbar_width), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.top_toolbar_border_width != new_->emacs_frame.top_toolbar_border_width) Fadd_spec_to_specifier - (Vtoolbar_border_width[TOP_TOOLBAR], + (Vtoolbar_border_width[TOP_EDGE], make_int (new_->emacs_frame.top_toolbar_border_width), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.bottom_toolbar_border_width != new_->emacs_frame.bottom_toolbar_border_width) Fadd_spec_to_specifier - (Vtoolbar_border_width[BOTTOM_TOOLBAR], + (Vtoolbar_border_width[BOTTOM_EDGE], make_int (new_->emacs_frame.bottom_toolbar_border_width), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.left_toolbar_border_width != new_->emacs_frame.left_toolbar_border_width) Fadd_spec_to_specifier - (Vtoolbar_border_width[LEFT_TOOLBAR], + (Vtoolbar_border_width[LEFT_EDGE], make_int (new_->emacs_frame.left_toolbar_border_width), wrap_frame (f), Qnil, Qnil); if (cur->emacs_frame.right_toolbar_border_width != new_->emacs_frame.right_toolbar_border_width) Fadd_spec_to_specifier - (Vtoolbar_border_width[RIGHT_TOOLBAR], + (Vtoolbar_border_width[RIGHT_EDGE], make_int (new_->emacs_frame.right_toolbar_border_width), wrap_frame (f), Qnil, Qnil); #endif /* HAVE_TOOLBARS */
--- a/src/Makefile.in.in Tue Feb 23 07:28:35 2010 -0600 +++ b/src/Makefile.in.in Mon Mar 29 21:28:13 2010 -0500 @@ -183,6 +183,10 @@ event_unixoid_objs=event-unixoid.o #endif +#ifdef HAVE_WINDOW_SYSTEM +glyphs_objs=glyphs-eimage.o glyphs-shared.o +#endif + #ifdef HAVE_GPM gpm_objs=gpmevent.o #endif @@ -270,19 +274,18 @@ ## if they all come out null. objs=\ - abbrev.o alloc.o alloca.o \ + abbrev.o alloc.o alloca.o array.o \ $(balloon_help_objs) blocktype.o buffer.o bytecode.o \ callint.o casefiddle.o casetab.o chartab.o \ $(clash_detection_objs) cmdloop.o cmds.o $(coding_system_objs) console.o \ console-stream.o\ data.o $(database_objs) $(debug_objs) device.o dired.o doc.o doprnt.o\ - dynarr.o \ editfns.o elhash.o emacs.o emodules.o eval.o events.o\ event-stream.o $(event_unixoid_objs) $(extra_objs) extents.o\ faces.o file-coding.o fileio.o $(LOCK_OBJ) filemode.o floatfns.o fns.o \ font-lock.o frame.o\ - gc.o general.o glyphs.o glyphs-eimage.o glyphs-shared.o\ - glyphs-widget.o $(gpm_objs) $(gtk_objs) $(gtk_gui_objs) $(gui_objs) \ + gc.o general.o glyphs.o $(glyphs_objs) glyphs-widget.o \ + $(gpm_objs) $(gtk_objs) $(gtk_gui_objs) $(gui_objs) \ gutter.o\ hash.o imgproc.o indent.o insdel.o intl.o\ keymap.o $(RTC_patch_objs) line-number.o $(ldap_objs) lread.o lstream.o\
--- a/src/alloc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/alloc.c Mon Mar 29 21:28:13 2010 -0500 @@ -102,78 +102,25 @@ Bytecount __temp_alloca_size__; Bytecount funcall_alloca_count; -/* Determine now whether we need to garbage collect or not, to make - Ffuncall() faster */ -#define INCREMENT_CONS_COUNTER_1(size) \ -do \ -{ \ - consing_since_gc += (size); \ - total_consing += (size); \ - if (profiling_active) \ - profile_record_consing (size); \ - recompute_need_to_garbage_collect (); \ -} while (0) - -#define debug_allocation_backtrace() \ -do { \ - if (debug_allocation_backtrace_length > 0) \ - debug_short_backtrace (debug_allocation_backtrace_length); \ -} while (0) - -#ifdef DEBUG_XEMACS -#define INCREMENT_CONS_COUNTER(foosize, type) \ - do { \ - if (debug_allocation) \ - { \ - stderr_out ("allocating %s (size %ld)\n", type, \ - (long) foosize); \ - debug_allocation_backtrace (); \ - } \ - INCREMENT_CONS_COUNTER_1 (foosize); \ - } while (0) -#define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \ - do { \ - if (debug_allocation > 1) \ - { \ - stderr_out ("allocating noseeum %s (size %ld)\n", type, \ - (long) foosize); \ - debug_allocation_backtrace (); \ - } \ - INCREMENT_CONS_COUNTER_1 (foosize); \ - } while (0) -#else -#define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) -#define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ - INCREMENT_CONS_COUNTER_1 (size) -#endif - -#ifdef NEW_GC -/* The call to recompute_need_to_garbage_collect is moved to - free_lrecord, since DECREMENT_CONS_COUNTER is extensively called - during sweep and recomputing need_to_garbage_collect all the time - is not needed. */ -#define DECREMENT_CONS_COUNTER(size) do { \ - consing_since_gc -= (size); \ - total_consing -= (size); \ - if (profiling_active) \ - profile_record_unconsing (size); \ - if (consing_since_gc < 0) \ - consing_since_gc = 0; \ -} while (0) -#else /* not NEW_GC */ -#define DECREMENT_CONS_COUNTER(size) do { \ - consing_since_gc -= (size); \ - total_consing -= (size); \ - if (profiling_active) \ - profile_record_unconsing (size); \ - if (consing_since_gc < 0) \ - consing_since_gc = 0; \ - recompute_need_to_garbage_collect (); \ -} while (0) -#endif /*not NEW_GC */ - -/* This is just for use by the printer, to allow things to print uniquely */ -int lrecord_uid_counter; +/* All the built-in lisp object types are enumerated in `enum lrecord_type'. + Additional ones may be defined by a module (none yet). We leave some + room in `lrecord_implementations_table' for such new lisp object types. */ +struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; +int lrecord_type_count = lrecord_type_last_built_in_type; + +/* This is just for use by the printer, to allow things to print uniquely. + We have a separate UID space for each object. (Important because the + UID is only 20 bits in old-GC, and 22 in NEW_GC.) */ +int lrecord_uid_counter[countof (lrecord_implementations_table)]; + +#ifndef USE_KKCC +/* Object marker functions are in the lrecord_implementation structure. + But copying them to a parallel array is much more cache-friendly. + This hack speeds up (garbage-collect) by about 5%. */ +Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); +#endif /* not USE_KKCC */ + +struct gcpro *gcprolist; /* Non-zero means we're in the process of doing the dump */ int purify_flag; @@ -189,26 +136,73 @@ #endif +#ifdef MEMORY_USAGE_STATS +Lisp_Object Qobject_actually_requested, Qobject_malloc_overhead; +Lisp_Object Qother_memory_actually_requested, Qother_memory_malloc_overhead; +Lisp_Object Qother_memory_dynarr_overhead, Qother_memory_gap_overhead; +#endif /* MEMORY_USAGE_STATS */ + +#ifndef NEW_GC +static int gc_count_num_short_string_in_use; +static Bytecount gc_count_string_total_size; +static Bytecount gc_count_short_string_total_size; +static Bytecount gc_count_long_string_storage_including_overhead; +#endif /* not NEW_GC */ + +/* static int gc_count_total_records_used, gc_count_records_total_size; */ + +/* stats on objects in use */ + +#ifdef NEW_GC + +static struct +{ + int instances_in_use; + int bytes_in_use; + int bytes_in_use_including_overhead; +} lrecord_stats [countof (lrecord_implementations_table)]; + +#else /* not NEW_GC */ + +static struct +{ + Elemcount instances_in_use; + Bytecount bytes_in_use; + Bytecount bytes_in_use_overhead; + Elemcount instances_freed; + Bytecount bytes_freed; + Bytecount bytes_freed_overhead; + Elemcount instances_on_free_list; + Bytecount bytes_on_free_list; + Bytecount bytes_on_free_list_overhead; +#ifdef MEMORY_USAGE_STATS + Bytecount nonlisp_bytes_in_use; + Bytecount lisp_ancillary_bytes_in_use; + struct generic_usage_stats stats; +#endif +} lrecord_stats [countof (lrecord_implementations_table)]; + +#endif /* (not) NEW_GC */ + /* Very cheesy ways of figuring out how much memory is being used for data. #### Need better (system-dependent) ways. */ void *minimum_address_seen; void *maximum_address_seen; -#ifndef NEW_GC -int -c_readonly (Lisp_Object obj) -{ - return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); -} -#endif /* not NEW_GC */ - -int -lisp_readonly (Lisp_Object obj) -{ - return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); -} - +/************************************************************************/ +/* Low-level allocation */ +/************************************************************************/ + +void +recompute_funcall_allocation_flag (void) +{ + funcall_allocation_flag = + need_to_garbage_collect || + need_to_check_c_alloca || + need_to_signal_post_gc; +} + /* Maximum amount of C stack to save when a GC happens. */ #ifndef MAX_SAVE_STACK @@ -232,6 +226,22 @@ xfree (tmp); } } + +#if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) +/* If we released our reserve (due to running out of memory), + and we have a fair amount free once again, + try to set aside another reserve in case we run out once more. + + This is called when a relocatable block is freed in ralloc.c. */ +void refill_memory_reserve (void); +void +refill_memory_reserve (void) +{ + if (breathing_space == 0) + breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); +} +#endif /* !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) */ + #endif /* not NEW_GC */ static void @@ -436,10 +446,7 @@ MALLOC_END (); } -#ifdef ERROR_CHECK_GC - -#ifndef NEW_GC -static void +void deadbeef_memory (void *ptr, Bytecount size) { UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; @@ -449,14 +456,6 @@ while (beefs--) (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ } -#endif /* not NEW_GC */ - -#else /* !ERROR_CHECK_GC */ - - -#define deadbeef_memory(ptr, size) - -#endif /* !ERROR_CHECK_GC */ #undef xstrdup char * @@ -478,6 +477,80 @@ #endif /* NEED_STRDUP */ +/************************************************************************/ +/* Lisp object allocation */ +/************************************************************************/ + +/* Determine now whether we need to garbage collect or not, to make + Ffuncall() faster */ +#define INCREMENT_CONS_COUNTER_1(size) \ +do \ +{ \ + consing_since_gc += (size); \ + total_consing += (size); \ + if (profiling_active) \ + profile_record_consing (size); \ + recompute_need_to_garbage_collect (); \ +} while (0) + +#define debug_allocation_backtrace() \ +do { \ + if (debug_allocation_backtrace_length > 0) \ + debug_short_backtrace (debug_allocation_backtrace_length); \ +} while (0) + +#ifdef DEBUG_XEMACS +#define INCREMENT_CONS_COUNTER(foosize, type) \ + do { \ + if (debug_allocation) \ + { \ + stderr_out ("allocating %s (size %ld)\n", type, \ + (long) foosize); \ + debug_allocation_backtrace (); \ + } \ + INCREMENT_CONS_COUNTER_1 (foosize); \ + } while (0) +#define NOSEEUM_INCREMENT_CONS_COUNTER(foosize, type) \ + do { \ + if (debug_allocation > 1) \ + { \ + stderr_out ("allocating noseeum %s (size %ld)\n", type, \ + (long) foosize); \ + debug_allocation_backtrace (); \ + } \ + INCREMENT_CONS_COUNTER_1 (foosize); \ + } while (0) +#else +#define INCREMENT_CONS_COUNTER(size, type) INCREMENT_CONS_COUNTER_1 (size) +#define NOSEEUM_INCREMENT_CONS_COUNTER(size, type) \ + INCREMENT_CONS_COUNTER_1 (size) +#endif + +#ifdef NEW_GC +/* [[ The call to recompute_need_to_garbage_collect is moved to + free_normal_lisp_object, since DECREMENT_CONS_COUNTER is extensively called + during sweep and recomputing need_to_garbage_collect all the time + is not needed. ]] -- not accurate! */ +#define DECREMENT_CONS_COUNTER(size) do { \ + consing_since_gc -= (size); \ + total_consing -= (size); \ + if (profiling_active) \ + profile_record_unconsing (size); \ + if (consing_since_gc < 0) \ + consing_since_gc = 0; \ +} while (0) +#else /* not NEW_GC */ +#define DECREMENT_CONS_COUNTER(size) do { \ + consing_since_gc -= (size); \ + total_consing -= (size); \ + if (profiling_active) \ + profile_record_unconsing (size); \ + if (consing_since_gc < 0) \ + consing_since_gc = 0; \ + recompute_need_to_garbage_collect (); \ +} while (0) +#endif /*not NEW_GC */ + #ifndef NEW_GC static void * allocate_lisp_storage (Bytecount size) @@ -505,62 +578,12 @@ } #endif /* not NEW_GC */ -#if defined (NEW_GC) && defined (ALLOC_TYPE_STATS) -static struct -{ - int instances_in_use; - int bytes_in_use; - int bytes_in_use_including_overhead; -} lrecord_stats [countof (lrecord_implementations_table)]; - -void -init_lrecord_stats () -{ - xzero (lrecord_stats); -} - -void -inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) -{ - int type_index = h->type; - if (!size) - size = detagged_lisp_object_size (h); - - lrecord_stats[type_index].instances_in_use++; - lrecord_stats[type_index].bytes_in_use += size; - lrecord_stats[type_index].bytes_in_use_including_overhead -#ifdef MEMORY_USAGE_STATS - += mc_alloced_storage_size (size, 0); -#else /* not MEMORY_USAGE_STATS */ - += size; -#endif /* not MEMORY_USAGE_STATS */ -} - -void -dec_lrecord_stats (Bytecount size_including_overhead, - const struct lrecord_header *h) -{ - int type_index = h->type; - int size = detagged_lisp_object_size (h); - - lrecord_stats[type_index].instances_in_use--; - lrecord_stats[type_index].bytes_in_use -= size; - lrecord_stats[type_index].bytes_in_use_including_overhead - -= size_including_overhead; - - DECREMENT_CONS_COUNTER (size); -} - -int -lrecord_stats_heap_size (void) -{ - int i; - int size = 0; - for (i = 0; i < countof (lrecord_implementations_table); i++) - size += lrecord_stats[i].bytes_in_use; - return size; -} -#endif /* NEW_GC && ALLOC_TYPE_STATS */ +#define assert_proper_sizing(size) \ + type_checking_assert \ + (implementation->static_size == 0 ? \ + implementation->size_in_bytes_method != NULL : \ + implementation->size_in_bytes_method == NULL && \ + implementation->static_size == size) #ifndef NEW_GC /* lcrecords are chained together through their "next" field. @@ -571,40 +594,14 @@ #ifdef NEW_GC /* The basic lrecord allocation functions. See lrecord.h for details. */ -void * -alloc_lrecord (Bytecount size, - const struct lrecord_implementation *implementation) +static Lisp_Object +alloc_sized_lrecord_1 (Bytecount size, + const struct lrecord_implementation *implementation, + int noseeum) { struct lrecord_header *lheader; - type_checking_assert - ((implementation->static_size == 0 ? - implementation->size_in_bytes_method != NULL : - implementation->static_size == size)); - - lheader = (struct lrecord_header *) mc_alloc (size); - gc_checking_assert (LRECORD_FREE_P (lheader)); - set_lheader_implementation (lheader, implementation); -#ifdef ALLOC_TYPE_STATS - inc_lrecord_stats (size, lheader); -#endif /* ALLOC_TYPE_STATS */ - if (implementation->finalizer) - add_finalizable_obj (wrap_pointer_1 (lheader)); - INCREMENT_CONS_COUNTER (size, implementation->name); - return lheader; -} - - -void * -noseeum_alloc_lrecord (Bytecount size, - const struct lrecord_implementation *implementation) -{ - struct lrecord_header *lheader; - - type_checking_assert - ((implementation->static_size == 0 ? - implementation->size_in_bytes_method != NULL : - implementation->static_size == size)); + assert_proper_sizing (size); lheader = (struct lrecord_header *) mc_alloc (size); gc_checking_assert (LRECORD_FREE_P (lheader)); @@ -614,81 +611,113 @@ #endif /* ALLOC_TYPE_STATS */ if (implementation->finalizer) add_finalizable_obj (wrap_pointer_1 (lheader)); - NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name); - return lheader; -} - -void * -alloc_lrecord_array (Bytecount size, int elemcount, + if (noseeum) + NOSEEUM_INCREMENT_CONS_COUNTER (size, implementation->name); + else + INCREMENT_CONS_COUNTER (size, implementation->name); + return wrap_pointer_1 (lheader); +} + +Lisp_Object +alloc_sized_lrecord (Bytecount size, const struct lrecord_implementation *implementation) { + return alloc_sized_lrecord_1 (size, implementation, 0); +} + +Lisp_Object +noseeum_alloc_sized_lrecord (Bytecount size, + const struct lrecord_implementation * + implementation) +{ + return alloc_sized_lrecord_1 (size, implementation, 1); +} + +Lisp_Object +alloc_lrecord (const struct lrecord_implementation *implementation) +{ + type_checking_assert (implementation->static_size > 0); + return alloc_sized_lrecord (implementation->static_size, implementation); +} + +Lisp_Object +noseeum_alloc_lrecord (const struct lrecord_implementation *implementation) +{ + type_checking_assert (implementation->static_size > 0); + return noseeum_alloc_sized_lrecord (implementation->static_size, implementation); +} + +Lisp_Object +alloc_sized_lrecord_array (Bytecount size, int elemcount, + const struct lrecord_implementation *implementation) +{ struct lrecord_header *lheader; Rawbyte *start, *stop; - type_checking_assert - ((implementation->static_size == 0 ? - implementation->size_in_bytes_method != NULL : - implementation->static_size == size)); + assert_proper_sizing (size); lheader = (struct lrecord_header *) mc_alloc_array (size, elemcount); gc_checking_assert (LRECORD_FREE_P (lheader)); - + for (start = (Rawbyte *) lheader, - stop = ((Rawbyte *) lheader) + (size * elemcount -1); + /* #### FIXME: why is this -1 present? */ + stop = ((Rawbyte *) lheader) + (size * elemcount -1); start < stop; start += size) { struct lrecord_header *lh = (struct lrecord_header *) start; set_lheader_implementation (lh, implementation); - lh->uid = lrecord_uid_counter++; #ifdef ALLOC_TYPE_STATS inc_lrecord_stats (size, lh); #endif /* not ALLOC_TYPE_STATS */ if (implementation->finalizer) add_finalizable_obj (wrap_pointer_1 (lh)); } + INCREMENT_CONS_COUNTER (size * elemcount, implementation->name); - return lheader; -} - -void -free_lrecord (Lisp_Object UNUSED (lrecord)) -{ - /* Manual frees are not allowed with asynchronous finalization */ - return; -} + return wrap_pointer_1 (lheader); +} + +Lisp_Object +alloc_lrecord_array (int elemcount, + const struct lrecord_implementation *implementation) +{ + type_checking_assert (implementation->static_size > 0); + return alloc_sized_lrecord_array (implementation->static_size, elemcount, + implementation); +} + #else /* not NEW_GC */ /* The most basic of the lcrecord allocation functions. Not usually called directly. Allocates an lrecord not managed by any lcrecord-list, of a specified size. See lrecord.h. */ -void * -old_basic_alloc_lcrecord (Bytecount size, +Lisp_Object +old_alloc_sized_lcrecord (Bytecount size, const struct lrecord_implementation *implementation) { struct old_lcrecord_header *lcheader; + assert_proper_sizing (size); type_checking_assert - ((implementation->static_size == 0 ? - implementation->size_in_bytes_method != NULL : - implementation->static_size == size) + (!implementation->frob_block_p && - (! implementation->basic_p) - && - (! (implementation->hash == NULL && implementation->equal != NULL))); + !(implementation->hash == NULL && implementation->equal != NULL)); lcheader = (struct old_lcrecord_header *) allocate_lisp_storage (size); set_lheader_implementation (&lcheader->lheader, implementation); lcheader->next = all_lcrecords; -#if 1 /* mly prefers to see small ID numbers */ - lcheader->uid = lrecord_uid_counter++; -#else /* jwz prefers to see real addrs */ - lcheader->uid = (int) &lcheader; -#endif - lcheader->free = 0; all_lcrecords = lcheader; INCREMENT_CONS_COUNTER (size, implementation->name); - return lcheader; + return wrap_pointer_1 (lcheader); +} + +Lisp_Object +old_alloc_lcrecord (const struct lrecord_implementation *implementation) +{ + type_checking_assert (implementation->static_size > 0); + return old_alloc_sized_lcrecord (implementation->static_size, + implementation); } #if 0 /* Presently unused */ @@ -723,31 +752,13 @@ } } if (lrecord->implementation->finalizer) - lrecord->implementation->finalizer (lrecord, 0); + lrecord->implementation->finalizer (wrap_pointer_1 (lrecord)); xfree (lrecord); return; } #endif /* Unused */ #endif /* not NEW_GC */ - -static void -disksave_object_finalization_1 (void) -{ -#ifdef NEW_GC - mc_finalize_for_disksave (); -#else /* not NEW_GC */ - struct old_lcrecord_header *header; - - for (header = all_lcrecords; header; header = header->next) - { - if (LHEADER_IMPLEMENTATION (&header->lheader)->finalizer && - !header->free) - LHEADER_IMPLEMENTATION (&header->lheader)->finalizer (header, 1); - } -#endif /* not NEW_GC */ -} - /* Bitwise copy all parts of a Lisp object other than the header */ void @@ -765,7 +776,7 @@ (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), size - sizeof (struct lrecord_header)); #else /* not NEW_GC */ - if (imp->basic_p) + if (imp->frob_block_p) memcpy ((char *) XRECORD_LHEADER (dst) + sizeof (struct lrecord_header), (char *) XRECORD_LHEADER (src) + sizeof (struct lrecord_header), size - sizeof (struct lrecord_header)); @@ -778,9 +789,98 @@ #endif /* not NEW_GC */ } +/* Zero out all parts of a Lisp object other than the header, for a + variable-sized object. The size needs to be given explicitly because + at the time this is called, the contents of the object may not be + defined, or may not be set up in such a way that we can reliably + retrieve the size, since it may depend on settings inside of the object. */ + +void +zero_sized_lisp_object (Lisp_Object obj, Bytecount size) +{ +#ifndef NEW_GC + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); +#endif /* not NEW_GC */ + +#ifdef NEW_GC + memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, + size - sizeof (struct lrecord_header)); +#else /* not NEW_GC */ + if (imp->frob_block_p) + memset ((char *) XRECORD_LHEADER (obj) + sizeof (struct lrecord_header), 0, + size - sizeof (struct lrecord_header)); + else + memset ((char *) XRECORD_LHEADER (obj) + + sizeof (struct old_lcrecord_header), 0, + size - sizeof (struct old_lcrecord_header)); +#endif /* not NEW_GC */ +} + +/* Zero out all parts of a Lisp object other than the header, for an object + that isn't variable-size. Objects that are variable-size need to use + zero_sized_lisp_object(). + */ + +void +zero_nonsized_lisp_object (Lisp_Object obj) +{ + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); + assert (!imp->size_in_bytes_method); + + zero_sized_lisp_object (obj, lisp_object_size (obj)); +} + +void +free_normal_lisp_object (Lisp_Object obj) +{ +#ifndef NEW_GC + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); +#endif /* not NEW_GC */ + +#ifdef NEW_GC + /* Manual frees are not allowed with asynchronous finalization */ + return; +#else + assert (!imp->frob_block_p); + assert (!imp->size_in_bytes_method); + old_free_lcrecord (obj); +#endif +} + +#ifndef NEW_GC +int +c_readonly (Lisp_Object obj) +{ + return POINTER_TYPE_P (XTYPE (obj)) && C_READONLY (obj); +} +#endif /* not NEW_GC */ + +int +lisp_readonly (Lisp_Object obj) +{ + return POINTER_TYPE_P (XTYPE (obj)) && LISP_READONLY (obj); +} + +/* #### Should be made into an object method */ + +int +object_dead_p (Lisp_Object obj) +{ + return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || + (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || + (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || + (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || + (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || + (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || + (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); +} + /************************************************************************/ -/* Debugger support */ +/* Debugger support */ /************************************************************************/ /* Give gdb/dbx enough information to decode Lisp Objects. We make sure certain symbols are always defined, so gdb doesn't complain @@ -827,7 +927,7 @@ #define DECLARE_FIXED_TYPE_ALLOC(type, structture) struct __foo__ #else /************************************************************************/ -/* Fixed-size type macros */ +/* Fixed-size type macros */ /************************************************************************/ /* For fixed-size types that are commonly used, we malloc() large blocks @@ -967,21 +1067,6 @@ remain free for the next 1000 (or whatever) times that an object of that type is allocated. */ -#if !defined(HAVE_MMAP) || defined(DOUG_LEA_MALLOC) -/* If we released our reserve (due to running out of memory), - and we have a fair amount free once again, - try to set aside another reserve in case we run out once more. - - This is called when a relocatable block is freed in ralloc.c. */ -void refill_memory_reserve (void); -void -refill_memory_reserve (void) -{ - if (breathing_space == 0) - breathing_space = (char *) malloc (4096 - MALLOC_OVERHEAD); -} -#endif - #ifdef ALLOC_NO_POOLS # define TYPE_ALLOC_SIZE(type, structtype) 1 #else @@ -1154,7 +1239,7 @@ #ifdef NEW_GC #define FREE_FIXED_TYPE_WHEN_NOT_IN_GC(lo, type, structtype, ptr) \ - free_lrecord (lo) + free_normal_lisp_object (lo) #else /* not NEW_GC */ /* Like FREE_FIXED_TYPE() but used when we are explicitly freeing a structure through free_cons(), free_marker(), etc. @@ -1181,23 +1266,23 @@ #endif /* (not) NEW_GC */ #ifdef NEW_GC -#define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \ +#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr)\ do { \ - (var) = alloc_lrecord_type (lisp_type, lrec_ptr); \ + (var) = (lisp_type *) XPNTR (ALLOC_NORMAL_LISP_OBJECT (type)); \ } while (0) -#define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, \ +#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ lrec_ptr) \ do { \ - (var) = noseeum_alloc_lrecord_type (lisp_type, lrec_ptr); \ + (var) = (lisp_type *) XPNTR (noseeum_alloc_lrecord (lrec_ptr)); \ } while (0) #else /* not NEW_GC */ -#define ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, lrec_ptr) \ +#define ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, lrec_ptr) \ do \ { \ ALLOCATE_FIXED_TYPE (type, lisp_type, var); \ set_lheader_implementation (&(var)->lheader, lrec_ptr); \ } while (0) -#define NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL(type, lisp_type, var, \ +#define NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT(type, lisp_type, var, \ lrec_ptr) \ do \ { \ @@ -1247,18 +1332,14 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("cons", cons, - 1, /*dumpable-flag*/ - mark_cons, print_cons, 0, - cons_equal, - /* - * No `hash' method needed. - * internal_hash knows how to - * handle conses. - */ - 0, - cons_description, - Lisp_Cons); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("cons", cons, + mark_cons, print_cons, 0, cons_equal, + /* + * No `hash' method needed. + * internal_hash knows how to + * handle conses. + */ + 0, cons_description, Lisp_Cons); DEFUN ("cons", Fcons, 2, 2, 0, /* Create a new cons cell, give it CAR and CDR as components, and return it. @@ -1278,7 +1359,7 @@ Lisp_Object val; Lisp_Cons *c; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons); + ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); val = wrap_cons (c); XSETCAR (val, car); XSETCDR (val, cdr); @@ -1294,7 +1375,7 @@ Lisp_Object val; Lisp_Cons *c; - NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (cons, Lisp_Cons, c, &lrecord_cons); + NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (cons, Lisp_Cons, c, &lrecord_cons); val = wrap_cons (c); XCAR (val) = car; XCDR (val) = cdr; @@ -1374,6 +1455,46 @@ return Fcons (obj0, Fcons (obj1, Fcons (obj2, Fcons (obj3, Fcons (obj4, Fcons (obj5, Qnil)))))); } +/* Return a list of arbitrary length, terminated by Qunbound. */ + +Lisp_Object +listu (Lisp_Object first, ...) +{ + Lisp_Object obj = Qnil; + Lisp_Object val; + va_list va; + + va_start (va, first); + val = first; + while (!UNBOUNDP (val)) + { + obj = Fcons (val, obj); + val = va_arg (va, Lisp_Object); + } + va_end (va); + return Fnreverse (obj); +} + +/* Return a list of arbitrary length, with length specified and remaining + args making up the list. */ + +Lisp_Object +listn (int num_args, ...) +{ + int i; + Lisp_Object obj = Qnil; + va_list va; + + va_start (va, num_args); + for (i = 0; i < num_args; i++) + obj = Fcons (va_arg (va, Lisp_Object), obj); + va_end (va); + return Fnreverse (obj); +} + +/* Return a list of arbitrary length, with length specified and an array + of elements. */ + DEFUN ("make-list", Fmake_list, 2, 2, 0, /* Return a new list of length LENGTH, with each element being OBJECT. */ @@ -1406,11 +1527,11 @@ { Lisp_Float *f; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (float, Lisp_Float, f, &lrecord_float); + ALLOC_FROB_BLOCK_LISP_OBJECT (float, Lisp_Float, f, &lrecord_float); /* Avoid dump-time `uninitialized memory read' purify warnings. */ if (sizeof (struct lrecord_header) + sizeof (double) != sizeof (*f)) - zero_lrecord (f); + zero_nonsized_lisp_object (wrap_float (f)); float_data (f) = float_value; return wrap_float (f); @@ -1433,7 +1554,7 @@ { Lisp_Bignum *b; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum); + ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); bignum_init (bignum_data (b)); bignum_set_long (bignum_data (b), bignum_value); return wrap_bignum (b); @@ -1446,7 +1567,7 @@ { Lisp_Bignum *b; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bignum, Lisp_Bignum, b, &lrecord_bignum); + ALLOC_FROB_BLOCK_LISP_OBJECT (bignum, Lisp_Bignum, b, &lrecord_bignum); bignum_init (bignum_data (b)); bignum_set (bignum_data (b), bg); return wrap_bignum (b); @@ -1463,7 +1584,7 @@ { Lisp_Ratio *r; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio); + ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); ratio_init (ratio_data (r)); ratio_set_long_ulong (ratio_data (r), numerator, denominator); ratio_canonicalize (ratio_data (r)); @@ -1475,7 +1596,7 @@ { Lisp_Ratio *r; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio); + ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); ratio_init (ratio_data (r)); ratio_set_bignum_bignum (ratio_data (r), numerator, denominator); ratio_canonicalize (ratio_data (r)); @@ -1487,7 +1608,7 @@ { Lisp_Ratio *r; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (ratio, Lisp_Ratio, r, &lrecord_ratio); + ALLOC_FROB_BLOCK_LISP_OBJECT (ratio, Lisp_Ratio, r, &lrecord_ratio); ratio_init (ratio_data (r)); ratio_set (ratio_data (r), rat); return wrap_ratio (r); @@ -1506,7 +1627,7 @@ { Lisp_Bigfloat *f; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); + ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); if (precision == 0UL) bigfloat_init (bigfloat_data (f)); else @@ -1521,7 +1642,7 @@ { Lisp_Bigfloat *f; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); + ALLOC_FROB_BLOCK_LISP_OBJECT (bigfloat, Lisp_Bigfloat, f, &lrecord_bigfloat); bigfloat_init_prec (bigfloat_data (f), bigfloat_get_prec (float_value)); bigfloat_set (bigfloat_data (f), float_value); return wrap_bigfloat (f); @@ -1545,10 +1666,11 @@ } static Bytecount -size_vector (const void *lheader) -{ +size_vector (Lisp_Object obj) +{ + return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, - ((Lisp_Vector *) lheader)->size); + XVECTOR (obj)->size); } static int @@ -1583,13 +1705,12 @@ { XD_END } }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("vector", vector, - 1, /*dumpable-flag*/ - mark_vector, print_vector, 0, - vector_equal, - vector_hash, - vector_description, - size_vector, Lisp_Vector); +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("vector", vector, + mark_vector, print_vector, 0, + vector_equal, + vector_hash, + vector_description, + size_vector, Lisp_Vector); /* #### should allocate `small' vectors from a frob-block */ static Lisp_Vector * make_vector_internal (Elemcount sizei) @@ -1597,8 +1718,8 @@ /* no `next' field; we use lcrecords */ Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Vector, Lisp_Object, contents, sizei); - Lisp_Vector *p = - (Lisp_Vector *) BASIC_ALLOC_LCRECORD (sizem, &lrecord_vector); + Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, vector); + Lisp_Vector *p = XVECTOR (obj); p->size = sizei; return p; @@ -1756,8 +1877,8 @@ Bytecount sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, num_longs); - Lisp_Bit_Vector *p = (Lisp_Bit_Vector *) - BASIC_ALLOC_LCRECORD (sizem, &lrecord_bit_vector); + Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (sizem, bit_vector); + Lisp_Bit_Vector *p = XBIT_VECTOR (obj); bit_vector_length (p) = sizei; return p; @@ -1843,8 +1964,8 @@ { Lisp_Compiled_Function *f; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (compiled_function, Lisp_Compiled_Function, - f, &lrecord_compiled_function); + ALLOC_FROB_BLOCK_LISP_OBJECT (compiled_function, Lisp_Compiled_Function, + f, &lrecord_compiled_function); f->stack_depth = 0; f->specpdl_depth = 0; @@ -1981,7 +2102,7 @@ CHECK_STRING (name); - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (symbol, Lisp_Symbol, p, &lrecord_symbol); + ALLOC_FROB_BLOCK_LISP_OBJECT (symbol, Lisp_Symbol, p, &lrecord_symbol); p->name = name; p->plist = Qnil; p->value = Qunbound; @@ -2003,7 +2124,7 @@ { struct extent *e; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (extent, struct extent, e, &lrecord_extent); + ALLOC_FROB_BLOCK_LISP_OBJECT (extent, struct extent, e, &lrecord_extent); extent_object (e) = Qnil; set_extent_start (e, -1); set_extent_end (e, -1); @@ -2031,7 +2152,7 @@ { Lisp_Event *e; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (event, Lisp_Event, e, &lrecord_event); + ALLOC_FROB_BLOCK_LISP_OBJECT (event, Lisp_Event, e, &lrecord_event); return wrap_event (e); } @@ -2045,9 +2166,9 @@ { Lisp_Key_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (key_data, Lisp_Key_Data, d, + ALLOC_FROB_BLOCK_LISP_OBJECT (key_data, Lisp_Key_Data, d, &lrecord_key_data); - zero_lrecord (d); + zero_nonsized_lisp_object (wrap_key_data (d)); d->keysym = Qnil; return wrap_key_data (d); @@ -2061,8 +2182,9 @@ { Lisp_Button_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (button_data, Lisp_Button_Data, d, &lrecord_button_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (button_data, Lisp_Button_Data, d, + &lrecord_button_data); + zero_nonsized_lisp_object (wrap_button_data (d)); return wrap_button_data (d); } @@ -2074,8 +2196,9 @@ { Lisp_Motion_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (motion_data, Lisp_Motion_Data, d, &lrecord_motion_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (motion_data, Lisp_Motion_Data, d, + &lrecord_motion_data); + zero_nonsized_lisp_object (wrap_motion_data (d)); return wrap_motion_data (d); } @@ -2088,8 +2211,9 @@ { Lisp_Process_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (process_data, Lisp_Process_Data, d, &lrecord_process_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (process_data, Lisp_Process_Data, d, + &lrecord_process_data); + zero_nonsized_lisp_object (wrap_process_data (d)); d->process = Qnil; return wrap_process_data (d); @@ -2103,8 +2227,9 @@ { Lisp_Timeout_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (timeout_data, Lisp_Timeout_Data, d, &lrecord_timeout_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (timeout_data, Lisp_Timeout_Data, d, + &lrecord_timeout_data); + zero_nonsized_lisp_object (wrap_timeout_data (d)); d->function = Qnil; d->object = Qnil; @@ -2119,8 +2244,9 @@ { Lisp_Magic_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_data, Lisp_Magic_Data, d, &lrecord_magic_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (magic_data, Lisp_Magic_Data, d, + &lrecord_magic_data); + zero_nonsized_lisp_object (wrap_magic_data (d)); return wrap_magic_data (d); } @@ -2133,8 +2259,9 @@ { Lisp_Magic_Eval_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (magic_eval_data, Lisp_Magic_Eval_Data, d, &lrecord_magic_eval_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data, d, + &lrecord_magic_eval_data); + zero_nonsized_lisp_object (wrap_magic_eval_data (d)); d->object = Qnil; return wrap_magic_eval_data (d); @@ -2148,8 +2275,9 @@ { Lisp_Eval_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (eval_data, Lisp_Eval_Data, d, &lrecord_eval_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (eval_data, Lisp_Eval_Data, d, + &lrecord_eval_data); + zero_nonsized_lisp_object (wrap_eval_data (d)); d->function = Qnil; d->object = Qnil; @@ -2164,8 +2292,9 @@ { Lisp_Misc_User_Data *d; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (misc_user_data, Lisp_Misc_User_Data, d, &lrecord_misc_user_data); - zero_lrecord (d); + ALLOC_FROB_BLOCK_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data, d, + &lrecord_misc_user_data); + zero_nonsized_lisp_object (wrap_misc_user_data (d)); d->function = Qnil; d->object = Qnil; @@ -2188,7 +2317,7 @@ { Lisp_Marker *p; - ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p, &lrecord_marker); + ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, &lrecord_marker); p->buffer = 0; p->membpos = 0; marker_next (p) = 0; @@ -2202,8 +2331,8 @@ { Lisp_Marker *p; - NOSEEUM_ALLOCATE_FIXED_TYPE_AND_SET_IMPL (marker, Lisp_Marker, p, - &lrecord_marker); + NOSEEUM_ALLOC_FROB_BLOCK_LISP_OBJECT (marker, Lisp_Marker, p, + &lrecord_marker); p->buffer = 0; p->membpos = 0; marker_next (p) = 0; @@ -2219,7 +2348,7 @@ /* The data for "short" strings generally resides inside of structs of type string_chars_block. The Lisp_String structure is allocated just like any - other basic lrecord, and these are freelisted when they get garbage + other frob-block lrecord, and these are freelisted when they get garbage collected. The data for short strings get compacted, but the data for large strings do not. @@ -2320,16 +2449,11 @@ standard way to do finalization when using SWEEP_FIXED_TYPE_BLOCK(). */ -DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, - 1, /*dumpable-flag*/ - mark_string, print_string, - 0, string_equal, 0, - string_description, - string_getprop, - string_putprop, - string_remprop, - string_plist, - Lisp_String); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("string", string, + mark_string, print_string, + 0, string_equal, 0, + string_description, + Lisp_String); #endif /* not NEW_GC */ #ifdef NEW_GC @@ -2370,17 +2494,9 @@ #endif /* not NEW_GC */ #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("string", string, - 1, /*dumpable-flag*/ - mark_string, print_string, - 0, - string_equal, 0, - string_description, - string_getprop, - string_putprop, - string_remprop, - string_plist, - Lisp_String); +DEFINE_DUMPABLE_LISP_OBJECT ("string", string, mark_string, print_string, + 0, string_equal, 0, + string_description, Lisp_String); static const struct memory_description string_direct_data_description[] = { @@ -2389,19 +2505,18 @@ }; static Bytecount -size_string_direct_data (const void *lheader) -{ - return STRING_FULLSIZE (((Lisp_String_Direct_Data *) lheader)->size); -} - - -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("string-direct-data", - string_direct_data, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - string_direct_data_description, - size_string_direct_data, - Lisp_String_Direct_Data); +size_string_direct_data (Lisp_Object obj) +{ + return STRING_FULLSIZE (XSTRING_DIRECT_DATA (obj)->size); +} + + +DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("string-direct-data", + string_direct_data, + 0, + string_direct_data_description, + size_string_direct_data, + Lisp_String_Direct_Data); static const struct memory_description string_indirect_data_description[] = { @@ -2411,12 +2526,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("string-indirect-data", - string_indirect_data, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - string_indirect_data_description, - Lisp_String_Indirect_Data); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("string-indirect-data", + string_indirect_data, + 0, + string_indirect_data_description, + Lisp_String_Indirect_Data); #endif /* NEW_GC */ #ifndef NEW_GC @@ -2520,7 +2634,7 @@ assert (length >= 0 && fullsize > 0); #ifdef NEW_GC - s = alloc_lrecord_type (Lisp_String, &lrecord_string); + s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); #else /* not NEW_GC */ /* Allocate the string header */ ALLOCATE_FIXED_TYPE (string, Lisp_String, s); @@ -2535,8 +2649,7 @@ #ifdef NEW_GC set_lispstringp_direct (s); STRING_DATA_OBJECT (s) = - wrap_string_direct_data (alloc_lrecord (fullsize, - &lrecord_string_direct_data)); + alloc_sized_lrecord (fullsize, &lrecord_string_direct_data); #else /* not NEW_GC */ set_lispstringp_data (s, BIG_STRING_FULLSIZE_P (fullsize) ? allocate_big_string_chars (length + 1) @@ -2983,7 +3096,7 @@ #endif #ifdef NEW_GC - s = alloc_lrecord_type (Lisp_String, &lrecord_string); + s = XSTRING (ALLOC_NORMAL_LISP_OBJECT (string)); mcpro (wrap_pointer_1 (s)); /* otherwise nocopy_strings get collected and static data is tried to be freed. */ @@ -2998,10 +3111,7 @@ s->plist = Qnil; #ifdef NEW_GC set_lispstringp_indirect (s); - STRING_DATA_OBJECT (s) = - wrap_string_indirect_data - (alloc_lrecord_type (Lisp_String_Indirect_Data, - &lrecord_string_indirect_data)); + STRING_DATA_OBJECT (s) = ALLOC_NORMAL_LISP_OBJECT (string_indirect_data); XSTRING_INDIRECT_DATA_DATA (STRING_DATA_OBJECT (s)) = (Ibyte *) contents; XSTRING_INDIRECT_DATA_SIZE (STRING_DATA_OBJECT (s)) = length; #else /* not NEW_GC */ @@ -3022,7 +3132,7 @@ /************************************************************************/ /* Lcrecord lists are used to manage the allocation of particular - sorts of lcrecords, to avoid calling BASIC_ALLOC_LCRECORD() (and thus + sorts of lcrecords, to avoid calling ALLOC_NORMAL_LISP_OBJECT() (and thus malloc() and garbage-collection junk) as much as possible. It is similar to the Blocktype class. @@ -3035,11 +3145,8 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("free", free, - 0, /*dumpable-flag*/ - 0, internal_object_printer, - 0, 0, 0, free_description, - struct free_lcrecord_header); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("free", free, 0, free_description, + struct free_lcrecord_header); const struct memory_description lcrecord_list_description[] = { { XD_LISP_OBJECT, offsetof (struct lcrecord_list, free), 0, { 0 }, @@ -3064,10 +3171,10 @@ ! MARKED_RECORD_HEADER_P (lheader) && /* Only lcrecords should be here. */ - ! list->implementation->basic_p + ! list->implementation->frob_block_p && /* Only free lcrecords should be here. */ - free_header->lcheader.free + lheader->free && /* The type of the lcrecord must be right. */ lheader->type == lrecord_type_free @@ -3084,21 +3191,19 @@ return Qnil; } -DEFINE_LRECORD_IMPLEMENTATION ("lcrecord-list", lcrecord_list, - 0, /*dumpable-flag*/ - mark_lcrecord_list, internal_object_printer, - 0, 0, 0, lcrecord_list_description, - struct lcrecord_list); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("lcrecord-list", lcrecord_list, + mark_lcrecord_list, + lcrecord_list_description, + struct lcrecord_list); Lisp_Object make_lcrecord_list (Elemcount size, const struct lrecord_implementation *implementation) { - /* Don't use old_alloc_lcrecord_type() avoid infinite recursion - allocating this, */ - struct lcrecord_list *p = (struct lcrecord_list *) - old_basic_alloc_lcrecord (sizeof (struct lcrecord_list), - &lrecord_lcrecord_list); + /* Don't use alloc_automanaged_lcrecord() avoid infinite recursion + allocating this. */ + struct lcrecord_list *p = + XLCRECORD_LIST (old_alloc_lcrecord (&lrecord_lcrecord_list)); p->implementation = implementation; p->size = size; @@ -3122,10 +3227,10 @@ /* There should be no other pointers to the free list. */ assert (! MARKED_RECORD_HEADER_P (lheader)); /* Only free lcrecords should be here. */ - assert (free_header->lcheader.free); + assert (lheader->free); assert (lheader->type == lrecord_type_free); /* Only lcrecords should be here. */ - assert (! (list->implementation->basic_p)); + assert (! (list->implementation->frob_block_p)); #if 0 /* Not used anymore, now that we set the type of the header to lrecord_type_free. */ /* The type of the lcrecord must be right. */ @@ -3137,15 +3242,14 @@ #endif /* ERROR_CHECK_GC */ list->free = free_header->chain; - free_header->lcheader.free = 0; + lheader->free = 0; /* Put back the correct type, as we set it to lrecord_type_free. */ lheader->type = list->implementation->lrecord_type_index; - old_zero_sized_lcrecord (free_header, list->size); + zero_sized_lisp_object (val, list->size); return val; } else - return wrap_pointer_1 (old_basic_alloc_lcrecord (list->size, - list->implementation)); + return old_alloc_sized_lcrecord (list->size, list->implementation); } /* "Free" a Lisp object LCRECORD by placing it on its associated free list @@ -3189,15 +3293,15 @@ /* Make sure the size is correct. This will catch, for example, putting a window configuration on the wrong free list. */ - gc_checking_assert (detagged_lisp_object_size (lheader) == list->size); + gc_checking_assert (lisp_object_size (lcrecord) == list->size); /* Make sure the object isn't already freed. */ - gc_checking_assert (!free_header->lcheader.free); + gc_checking_assert (!lheader->free); /* Freeing stuff in dumped memory is bad. If you trip this, you may need to check for this before freeing. */ gc_checking_assert (!OBJECT_DUMPED_P (lcrecord)); if (implementation->finalizer) - implementation->finalizer (lheader, 0); + implementation->finalizer (lcrecord); /* Yes, there are two ways to indicate freeness -- the type is lrecord_type_free or the ->free flag is set. We used to do only the latter; now we do the former as well for KKCC purposes. Probably @@ -3205,22 +3309,28 @@ around an lrecord of apparently correct type but bogus junk in it. */ MARK_LRECORD_AS_FREE (lheader); free_header->chain = list->free; - free_header->lcheader.free = 1; + lheader->free = 1; list->free = lcrecord; } static Lisp_Object all_lcrecord_lists[countof (lrecord_implementations_table)]; -void * -alloc_automanaged_lcrecord (Bytecount size, - const struct lrecord_implementation *imp) +Lisp_Object +alloc_automanaged_sized_lcrecord (Bytecount size, + const struct lrecord_implementation *imp) { if (EQ (all_lcrecord_lists[imp->lrecord_type_index], Qzero)) all_lcrecord_lists[imp->lrecord_type_index] = make_lcrecord_list (size, imp); - return XPNTR (alloc_managed_lcrecord - (all_lcrecord_lists[imp->lrecord_type_index])); + return alloc_managed_lcrecord (all_lcrecord_lists[imp->lrecord_type_index]); +} + +Lisp_Object +alloc_automanaged_lcrecord (const struct lrecord_implementation *imp) +{ + type_checking_assert (imp->static_size > 0); + return alloc_automanaged_sized_lcrecord (imp->static_size, imp); } void @@ -3249,23 +3359,9 @@ /************************************************************************/ -/* Garbage Collection */ +/* Staticpro, MCpro */ /************************************************************************/ -/* All the built-in lisp object types are enumerated in `enum lrecord_type'. - Additional ones may be defined by a module (none yet). We leave some - room in `lrecord_implementations_table' for such new lisp object types. */ -const struct lrecord_implementation *lrecord_implementations_table[(int)lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; -int lrecord_type_count = lrecord_type_last_built_in_type; -#ifndef USE_KKCC -/* Object marker functions are in the lrecord_implementation structure. - But copying them to a parallel array is much more cache-friendly. - This hack speeds up (garbage-collect) by about 5%. */ -Lisp_Object (*lrecord_markers[countof (lrecord_implementations_table)]) (Lisp_Object); -#endif /* not USE_KKCC */ - -struct gcpro *gcprolist; - /* We want the staticpro list relocated, but not the pointers found therein, because they refer to locations in the global data segment, not in the heap; we only dump heap objects. Hence we use a trivial @@ -3403,10 +3499,6 @@ #endif /* not DEBUG_XEMACS */ - - - - #ifdef NEW_GC static const struct memory_description mcpro_description_1[] = { { XD_END } @@ -3468,47 +3560,294 @@ #endif /* not DEBUG_XEMACS */ #endif /* NEW_GC */ - -#ifndef NEW_GC -static int gc_count_num_short_string_in_use; -static Bytecount gc_count_string_total_size; -static Bytecount gc_count_short_string_total_size; - -/* static int gc_count_total_records_used, gc_count_records_total_size; */ +#ifdef ALLOC_TYPE_STATS -/* stats on lcrecords in use - kinda kludgy */ - -static struct -{ - int instances_in_use; - int bytes_in_use; - int instances_freed; - int bytes_freed; - int instances_on_free_list; - int bytes_on_free_list; -} lrecord_stats [countof (lrecord_implementations_table)]; +/************************************************************************/ +/* Determining allocation overhead */ +/************************************************************************/ + +/* Attempt to determine the actual amount of space that is used for + the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". + + It seems that the following holds: + + 1. When using the old allocator (malloc.c): + + -- blocks are always allocated in chunks of powers of two. For + each block, there is an overhead of 8 bytes if rcheck is not + defined, 20 bytes if it is defined. In other words, a + one-byte allocation needs 8 bytes of overhead for a total of + 9 bytes, and needs to have 16 bytes of memory chunked out for + it. + + 2. When using the new allocator (gmalloc.c): + + -- blocks are always allocated in chunks of powers of two up + to 4096 bytes. Larger blocks are allocated in chunks of + an integral multiple of 4096 bytes. The minimum block + size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG + is defined. There is no per-block overhead, but there + is an overhead of 3*sizeof (size_t) for each 4096 bytes + allocated. + + 3. When using the system malloc, anything goes, but they are + generally slower and more space-efficient than the GNU + allocators. One possibly reasonable assumption to make + for want of better data is that sizeof (void *), or maybe + 2 * sizeof (void *), is required as overhead and that + blocks are allocated in the minimum required size except + that some minimum block size is imposed (e.g. 16 bytes). */ + +Bytecount +malloced_storage_size (void * UNUSED (ptr), Bytecount claimed_size, + struct usage_stats *stats) +{ + Bytecount orig_claimed_size = claimed_size; + +#ifndef SYSTEM_MALLOC + if (claimed_size < (Bytecount) (2 * sizeof (void *))) + claimed_size = 2 * sizeof (void *); +# ifdef SUNOS_LOCALTIME_BUG + if (claimed_size < 16) + claimed_size = 16; +# endif + if (claimed_size < 4096) + { + /* fxg: rename log->log2 to supress gcc3 shadow warning */ + int log2 = 1; + + /* compute the log base two, more or less, then use it to compute + the block size needed. */ + claimed_size--; + /* It's big, it's heavy, it's wood! */ + while ((claimed_size /= 2) != 0) + ++log2; + claimed_size = 1; + /* It's better than bad, it's good! */ + while (log2 > 0) + { + claimed_size *= 2; + log2--; + } + /* We have to come up with some average about the amount of + blocks used. */ + if ((Bytecount) (rand () & 4095) < claimed_size) + claimed_size += 3 * sizeof (void *); + } + else + { + claimed_size += 4095; + claimed_size &= ~4095; + claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); + } + +#else + + if (claimed_size < 16) + claimed_size = 16; + claimed_size += 2 * sizeof (void *); + +#endif /* system allocator */ + + if (stats) + { + stats->was_requested += orig_claimed_size; + stats->malloc_overhead += claimed_size - orig_claimed_size; + } + return claimed_size; +} + +#ifndef NEW_GC +static Bytecount +fixed_type_block_overhead (Bytecount size, Bytecount per_block) +{ + Bytecount overhead = 0; + Bytecount storage_size = malloced_storage_size (0, per_block, 0); + while (size >= per_block) + { + size -= per_block; + overhead += storage_size - per_block; + } + if (rand () % per_block < size) + overhead += storage_size - per_block; + return overhead; +} +#endif /* not NEW_GC */ + +Bytecount +lisp_object_storage_size (Lisp_Object obj, struct usage_stats *ustats) +{ +#ifndef NEW_GC + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); +#endif /* not NEW_GC */ + Bytecount size = lisp_object_size (obj); + +#ifdef NEW_GC + return mc_alloced_storage_size (size, ustats); +#else + if (imp->frob_block_p) + { + Bytecount overhead = + /* #### Always using cons_block is incorrect but close; only + string_chars_block is significantly different in size, and + it won't ever be seen in this function */ + fixed_type_block_overhead (size, sizeof (struct cons_block)); + if (ustats) + { + ustats->was_requested += size; + ustats->malloc_overhead += overhead; + } + return size + overhead; + } + else + return malloced_storage_size (XPNTR (obj), size, ustats); +#endif +} + + +/************************************************************************/ +/* Allocation Statistics: Accumulate */ +/************************************************************************/ + +#ifdef NEW_GC + +void +init_lrecord_stats (void) +{ + xzero (lrecord_stats); +} + +void +inc_lrecord_stats (Bytecount size, const struct lrecord_header *h) +{ + int type_index = h->type; + if (!size) + size = detagged_lisp_object_size (h); + + lrecord_stats[type_index].instances_in_use++; + lrecord_stats[type_index].bytes_in_use += size; + lrecord_stats[type_index].bytes_in_use_including_overhead +#ifdef MEMORY_USAGE_STATS + += mc_alloced_storage_size (size, 0); +#else /* not MEMORY_USAGE_STATS */ + += size; +#endif /* not MEMORY_USAGE_STATS */ +} + +void +dec_lrecord_stats (Bytecount size_including_overhead, + const struct lrecord_header *h) +{ + int type_index = h->type; + int size = detagged_lisp_object_size (h); + + lrecord_stats[type_index].instances_in_use--; + lrecord_stats[type_index].bytes_in_use -= size; + lrecord_stats[type_index].bytes_in_use_including_overhead + -= size_including_overhead; + + DECREMENT_CONS_COUNTER (size); +} + +int +lrecord_stats_heap_size (void) +{ + int i; + int size = 0; + for (i = 0; i < countof (lrecord_implementations_table); i++) + size += lrecord_stats[i].bytes_in_use; + return size; +} + +#else /* not NEW_GC */ + +static void +clear_lrecord_stats (void) +{ + xzero (lrecord_stats); + gc_count_num_short_string_in_use = 0; + gc_count_string_total_size = 0; + gc_count_short_string_total_size = 0; + gc_count_long_string_storage_including_overhead = 0; +} + +/* Keep track of extra statistics for strings -- length of the string + characters for short and long strings, number of short and long strings. */ +static void +tick_string_stats (Lisp_String *p, int from_sweep) +{ + Bytecount size = p->size_; + gc_count_string_total_size += size; + if (!BIG_STRING_SIZE_P (size)) + { + gc_count_short_string_total_size += size; + gc_count_num_short_string_in_use++; + } + else + gc_count_long_string_storage_including_overhead += + malloced_storage_size (p->data_, p->size_, NULL); + /* During the sweep stage, we count the total number of strings in use. + This gets those not stored in pdump storage. For pdump storage, we + need to bump the number of strings in use so as to get an accurate + count of all strings in use (pdump or not). But don't do this when + called from the sweep stage, or we will double-count. */ + if (!from_sweep) + gc_count_num_string_in_use++; +} + +/* As objects are sweeped, we record statistics about their memory usage. + Currently, all lcrecords are processed this way as well as any frob-block + objects that were saved and restored as a result of the pdump process. + (See pdump_objects_unmark().) Other frob-block objects do NOT get their + statistics noted this way -- instead, as the frob blocks are swept, + COPY_INTO_LRECORD_STATS() is called, and notes statistics about the + frob blocks. */ void tick_lrecord_stats (const struct lrecord_header *h, enum lrecord_alloc_status status) { int type_index = h->type; - Bytecount sz = detagged_lisp_object_size (h); + Lisp_Object obj = wrap_pointer_1 (h); + Bytecount sz = lisp_object_size (obj); + Bytecount sz_with_overhead = lisp_object_storage_size (obj, NULL); + Bytecount overhead = sz_with_overhead - sz; switch (status) { case ALLOC_IN_USE: lrecord_stats[type_index].instances_in_use++; lrecord_stats[type_index].bytes_in_use += sz; + lrecord_stats[type_index].bytes_in_use_overhead += overhead; + if (STRINGP (obj)) + tick_string_stats (XSTRING (obj), 0); +#ifdef MEMORY_USAGE_STATS + { + struct generic_usage_stats stats; + if (HAS_OBJECT_METH_P (obj, memory_usage)) + { + int i; + int total_stats = OBJECT_PROPERTY (obj, num_extra_memusage_stats); + xzero (stats); + OBJECT_METH (obj, memory_usage, (obj, &stats)); + for (i = 0; i < total_stats; i++) + lrecord_stats[type_index].stats.othervals[i] += + stats.othervals[i]; + } + } +#endif break; case ALLOC_FREE: lrecord_stats[type_index].instances_freed++; lrecord_stats[type_index].bytes_freed += sz; + lrecord_stats[type_index].bytes_freed_overhead += overhead; break; case ALLOC_ON_FREE_LIST: lrecord_stats[type_index].instances_on_free_list++; lrecord_stats[type_index].bytes_on_free_list += sz; + lrecord_stats[type_index].bytes_on_free_list_overhead += overhead; break; default: ABORT (); @@ -3518,7 +3857,7 @@ inline static void tick_lcrecord_stats (const struct lrecord_header *h, int free_p) { - if (((struct old_lcrecord_header *) h)->free) + if (h->free) { gc_checking_assert (!free_p); tick_lrecord_stats (h, ALLOC_ON_FREE_LIST); @@ -3526,9 +3865,554 @@ else tick_lrecord_stats (h, free_p ? ALLOC_FREE : ALLOC_IN_USE); } -#endif /* not NEW_GC */ + +#endif /* (not) NEW_GC */ + +void +finish_object_memory_usage_stats (void) +{ + /* Here we add up the aggregate values for each statistic, previously + computed during tick_lrecord_stats(), to get a single combined value + of non-Lisp memory usage for all objects of each type. We can't + do this if NEW_GC because nothing like tick_lrecord_stats() gets + called -- instead, statistics are computed when objects are allocated, + which is too early to be calling the memory_usage() method. */ +#if defined (MEMORY_USAGE_STATS) && !defined (NEW_GC) + int i; + for (i = 0; i < countof (lrecord_implementations_table); i++) + { + struct lrecord_implementation *imp = lrecord_implementations_table[i]; + if (imp && imp->num_extra_nonlisp_memusage_stats) + { + int j; + for (j = 0; j < imp->num_extra_nonlisp_memusage_stats; j++) + lrecord_stats[i].nonlisp_bytes_in_use += + lrecord_stats[i].stats.othervals[j]; + } + if (imp && imp->num_extra_lisp_ancillary_memusage_stats) + { + int j; + for (j = 0; j < imp->num_extra_lisp_ancillary_memusage_stats; j++) + lrecord_stats[i].lisp_ancillary_bytes_in_use += + lrecord_stats[i].stats.othervals + [j + imp->offset_lisp_ancillary_memusage_stats]; + } + } +#endif /* defined (MEMORY_USAGE_STATS) && !defined (NEW_GC) */ +} + +#define COUNT_FROB_BLOCK_USAGE(type) \ + EMACS_INT s = 0; \ + EMACS_INT s_overhead = 0; \ + struct type##_block *x = current_##type##_block; \ + while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ + s_overhead = fixed_type_block_overhead (s, sizeof (struct type##_block)); \ + DO_NOTHING + +#define COPY_INTO_LRECORD_STATS(type) \ +do { \ + COUNT_FROB_BLOCK_USAGE (type); \ + lrecord_stats[lrecord_type_##type].bytes_in_use += s; \ + lrecord_stats[lrecord_type_##type].bytes_in_use_overhead += \ + s_overhead; \ + lrecord_stats[lrecord_type_##type].instances_on_free_list += \ + gc_count_num_##type##_freelist; \ + lrecord_stats[lrecord_type_##type].instances_in_use += \ + gc_count_num_##type##_in_use; \ +} while (0) +/************************************************************************/ +/* Allocation statistics: format nicely */ +/************************************************************************/ + +static Lisp_Object +gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) +{ + /* C doesn't have local functions (or closures, or GC, or readable syntax, + or portable numeric datatypes, or bit-vectors, or characters, or + arrays, or exceptions, or ...) */ + return cons3 (intern (name), make_int (value), tail); +} + +/* Pluralize a lowercase English word stored in BUF, assuming BUF has + enough space to hold the extra letters (at most 2). */ +static void +pluralize_word (Ascbyte *buf) +{ + Bytecount len = strlen (buf); + int upper = 0; + Ascbyte d, e; + + if (len == 0 || len == 1) + goto pluralize_apostrophe_s; + e = buf[len - 1]; + d = buf[len - 2]; + upper = isupper (e); + e = tolower (e); + d = tolower (d); + if (e == 'y') + { + switch (d) + { + case 'a': + case 'e': + case 'i': + case 'o': + case 'u': + goto pluralize_s; + default: + buf[len - 1] = (upper ? 'I' : 'i'); + goto pluralize_es; + } + } + else if (e == 's' || e == 'x' || (e == 'h' && (d == 's' || d == 'c'))) + { + pluralize_es: + buf[len++] = (upper ? 'E' : 'e'); + } + pluralize_s: + buf[len++] = (upper ? 'S' : 's'); + buf[len] = '\0'; + return; + + pluralize_apostrophe_s: + buf[len++] = '\''; + goto pluralize_s; +} + +static void +pluralize_and_append (Ascbyte *buf, const Ascbyte *name, const Ascbyte *suffix) +{ + strcpy (buf, name); + pluralize_word (buf); + strcat (buf, suffix); +} + +static Lisp_Object +object_memory_usage_stats (int set_total_gc_usage) +{ + Lisp_Object pl = Qnil; + int i; + EMACS_INT tgu_val = 0; + +#ifdef NEW_GC + for (i = 0; i < countof (lrecord_implementations_table); i++) + { + if (lrecord_stats[i].instances_in_use != 0) + { + Ascbyte buf[255]; + const Ascbyte *name = lrecord_implementations_table[i]->name; + + if (lrecord_stats[i].bytes_in_use_including_overhead != + lrecord_stats[i].bytes_in_use) + { + sprintf (buf, "%s-storage-including-overhead", name); + pl = gc_plist_hack (buf, + lrecord_stats[i] + .bytes_in_use_including_overhead, + pl); + } + + sprintf (buf, "%s-storage", name); + pl = gc_plist_hack (buf, + lrecord_stats[i].bytes_in_use, + pl); + tgu_val += lrecord_stats[i].bytes_in_use_including_overhead; + + pluralize_and_append (buf, name, "-used"); + pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); + } + } + +#else /* not NEW_GC */ + + for (i = 0; i < lrecord_type_count; i++) + { + if (lrecord_stats[i].bytes_in_use != 0 + || lrecord_stats[i].bytes_freed != 0 + || lrecord_stats[i].instances_on_free_list != 0) + { + Ascbyte buf[255]; + const Ascbyte *name = lrecord_implementations_table[i]->name; + + sprintf (buf, "%s-storage-overhead", name); + pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use_overhead, pl); + tgu_val += lrecord_stats[i].bytes_in_use_overhead; + sprintf (buf, "%s-storage", name); + pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use, pl); + tgu_val += lrecord_stats[i].bytes_in_use; +#ifdef MEMORY_USAGE_STATS + if (lrecord_stats[i].nonlisp_bytes_in_use) + { + sprintf (buf, "%s-non-lisp-storage", name); + pl = gc_plist_hack (buf, lrecord_stats[i].nonlisp_bytes_in_use, + pl); + tgu_val += lrecord_stats[i].nonlisp_bytes_in_use; + } + if (lrecord_stats[i].lisp_ancillary_bytes_in_use) + { + sprintf (buf, "%s-lisp-ancillary-storage", name); + pl = gc_plist_hack (buf, lrecord_stats[i]. + lisp_ancillary_bytes_in_use, + pl); + tgu_val += lrecord_stats[i].lisp_ancillary_bytes_in_use; + } +#endif /* MEMORY_USAGE_STATS */ + pluralize_and_append (buf, name, "-freed"); + if (lrecord_stats[i].instances_freed != 0) + pl = gc_plist_hack (buf, lrecord_stats[i].instances_freed, pl); + pluralize_and_append (buf, name, "-on-free-list"); + if (lrecord_stats[i].instances_on_free_list != 0) + pl = gc_plist_hack (buf, lrecord_stats[i].instances_on_free_list, + pl); + pluralize_and_append (buf, name, "-used"); + pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); + } + } + + pl = gc_plist_hack ("long-string-chars-storage-overhead", + gc_count_long_string_storage_including_overhead - + (gc_count_string_total_size + - gc_count_short_string_total_size), pl); + pl = gc_plist_hack ("long-string-chars-storage", + gc_count_string_total_size + - gc_count_short_string_total_size, pl); + do + { + COUNT_FROB_BLOCK_USAGE (string_chars); + tgu_val += s + s_overhead; + pl = gc_plist_hack ("short-string-chars-storage-overhead", s_overhead, pl); + pl = gc_plist_hack ("short-string-chars-storage", s, pl); + } + while (0); + + pl = gc_plist_hack ("long-strings-total-length", + gc_count_string_total_size + - gc_count_short_string_total_size, pl); + pl = gc_plist_hack ("short-strings-total-length", + gc_count_short_string_total_size, pl); + pl = gc_plist_hack ("long-strings-used", + gc_count_num_string_in_use + - gc_count_num_short_string_in_use, pl); + pl = gc_plist_hack ("short-strings-used", + gc_count_num_short_string_in_use, pl); + +#endif /* NEW_GC */ + + if (set_total_gc_usage) + { + total_gc_usage = tgu_val; + total_gc_usage_set = 1; + } + + return pl; +} + +static Lisp_Object +garbage_collection_statistics (void) +{ + /* The things we do for backwards-compatibility */ +#ifdef NEW_GC + return + list6 + (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), + make_int (lrecord_stats[lrecord_type_cons] + .bytes_in_use_including_overhead)), + Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), + make_int (lrecord_stats[lrecord_type_symbol] + .bytes_in_use_including_overhead)), + Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), + make_int (lrecord_stats[lrecord_type_marker] + .bytes_in_use_including_overhead)), + make_int (lrecord_stats[lrecord_type_string] + .bytes_in_use_including_overhead), + make_int (lrecord_stats[lrecord_type_vector] + .bytes_in_use_including_overhead), + object_memory_usage_stats (1)); +#else /* not NEW_GC */ + return + list6 (Fcons (make_int (gc_count_num_cons_in_use), + make_int (gc_count_num_cons_freelist)), + Fcons (make_int (gc_count_num_symbol_in_use), + make_int (gc_count_num_symbol_freelist)), + Fcons (make_int (gc_count_num_marker_in_use), + make_int (gc_count_num_marker_freelist)), + make_int (gc_count_string_total_size), + make_int (lrecord_stats[lrecord_type_vector].bytes_in_use + + lrecord_stats[lrecord_type_vector].bytes_freed + + lrecord_stats[lrecord_type_vector].bytes_on_free_list), + object_memory_usage_stats (1)); +#endif /* not NEW_GC */ +} + +DEFUN ("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0, 0, /* +Return statistics about memory usage of Lisp objects. +*/ + ()) +{ + return object_memory_usage_stats (0); +} + +#endif /* ALLOC_TYPE_STATS */ + +#ifdef MEMORY_USAGE_STATS + +DEFUN ("object-memory-usage", Fobject_memory_usage, 1, 1, 0, /* +Return stats about the memory usage of OBJECT. +The values returned are in the form of an alist of usage types and byte +counts. The byte counts attempt to encompass all the memory used +by the object (separate from the memory logically associated with any +other object), including internal structures and any malloc() +overhead associated with them. In practice, the byte counts are +underestimated because certain memory usage is very hard to determine +\(e.g. the amount of memory used inside the Xt library or inside the +X server). + +Multiple slices of the total memory usage may be returned, separated +by a nil. Each slice represents a particular view of the memory, a +particular way of partitioning it into groups. Within a slice, there +is no overlap between the groups of memory, and each slice collectively +represents all the memory concerned. The rightmost slice typically +represents the total memory used plus malloc and dynarr overhead. + +Slices describing other Lisp objects logically associated with the +object may be included, separated from other slices by `t' and from +each other by nil if there is more than one. + +#### We have to figure out how to handle the memory used by the object +itself vs. the memory used by substructures. Probably the memory_usage +method should return info only about substructures and related Lisp +objects, since the caller can always find and all info about the object +itself. +*/ + (object)) +{ + struct generic_usage_stats gustats; + struct usage_stats object_stats; + int i; + Lisp_Object val = Qnil; + Lisp_Object stats_list; + + if (INTP (object) || CHARP (object)) + invalid_argument ("No memory associated with immediate objects (int or char)", + object); + + stats_list = OBJECT_PROPERTY (object, memusage_stats_list); + + xzero (object_stats); + lisp_object_storage_size (object, &object_stats); + + val = acons (Qobject_actually_requested, + make_int (object_stats.was_requested), val); + val = acons (Qobject_malloc_overhead, + make_int (object_stats.malloc_overhead), val); + assert (!object_stats.dynarr_overhead); + assert (!object_stats.gap_overhead); + + if (!NILP (stats_list)) + { + xzero (gustats); + MAYBE_OBJECT_METH (object, memory_usage, (object, &gustats)); + + val = Fcons (Qt, val); + val = acons (Qother_memory_actually_requested, + make_int (gustats.u.was_requested), val); + val = acons (Qother_memory_malloc_overhead, + make_int (gustats.u.malloc_overhead), val); + if (gustats.u.dynarr_overhead) + val = acons (Qother_memory_dynarr_overhead, + make_int (gustats.u.dynarr_overhead), val); + if (gustats.u.gap_overhead) + val = acons (Qother_memory_gap_overhead, + make_int (gustats.u.gap_overhead), val); + val = Fcons (Qnil, val); + + i = 0; + { + LIST_LOOP_2 (item, stats_list) + { + if (NILP (item) || EQ (item, Qt)) + val = Fcons (item, val); + else + { + val = acons (item, make_int (gustats.othervals[i]), val); + i++; + } + } + } + } + + return Fnreverse (val); +} + +/* Compute total memory usage associated with an object, including + + (a) Storage (including overhead) allocated to the object itself + (b) Storage (including overhead) for ancillary non-Lisp structures attached + to the object + (c) Storage (including overhead) for ancillary Lisp objects attached + to the object + + Store the three types of memory into the return values provided they + aren't NULL, and return a sum of the three values. Also store the + structure of individual statistics into STATS if non-zero. + + Note that the value for type (c) is the sum of all three types of + memory associated with the ancillary Lisp objects. +*/ + +Bytecount +lisp_object_memory_usage_full (Lisp_Object object, Bytecount *storage_size, + Bytecount *extra_nonlisp_storage, + Bytecount *extra_lisp_ancillary_storage, + struct generic_usage_stats *stats) +{ + Bytecount total; + struct lrecord_implementation *imp = XRECORD_LHEADER_IMPLEMENTATION (object); + + total = lisp_object_storage_size (object, NULL); + if (storage_size) + *storage_size = total; + + if (HAS_OBJECT_METH_P (object, memory_usage)) + { + int i; + struct generic_usage_stats gustats; + Bytecount sum; + + xzero (gustats); + OBJECT_METH (object, memory_usage, (object, &gustats)); + + if (stats) + *stats = gustats; + + sum = 0; + for (i = 0; i < imp->num_extra_nonlisp_memusage_stats; i++) + sum += gustats.othervals[i]; + total += sum; + if (extra_nonlisp_storage) + *extra_nonlisp_storage = sum; + + sum = 0; + for (i = 0; i < imp->num_extra_lisp_ancillary_memusage_stats; i++) + sum += gustats.othervals[imp->offset_lisp_ancillary_memusage_stats + + i]; + total += sum; + if (extra_lisp_ancillary_storage) + *extra_lisp_ancillary_storage = sum; + } + else + { + if (extra_nonlisp_storage) + *extra_nonlisp_storage = 0; + if (extra_lisp_ancillary_storage) + *extra_lisp_ancillary_storage = 0; + } + + return total; +} + + +Bytecount +lisp_object_memory_usage (Lisp_Object object) +{ + return lisp_object_memory_usage_full (object, NULL, NULL, NULL, NULL); +} + +#endif /* MEMORY_USAGE_STATS */ + +#ifdef ALLOC_TYPE_STATS + +DEFUN ("total-object-memory-usage", Ftotal_object_memory_usage, 0, 0, 0, /* +Return total number of bytes used for object storage in XEmacs. +This may be helpful in debugging XEmacs's memory usage. +See also `consing-since-gc' and `object-memory-usage-stats'. +*/ + ()) +{ + return make_int (total_gc_usage + consing_since_gc); +} + +#endif /* ALLOC_TYPE_STATS */ + + +/************************************************************************/ +/* Allocation statistics: Initialization */ +/************************************************************************/ +#ifdef MEMORY_USAGE_STATS + +/* Compute the number of extra memory-usage statistics associated with an + object. We can't compute this at the time INIT_LISP_OBJECT() is called + because the value of the `memusage_stats_list' property is generally + set afterwards. So we compute the values for all types of objects + after all objects have been initialized. */ + +static void +compute_memusage_stats_length (void) +{ + int i; + + for (i = 0; i < countof (lrecord_implementations_table); i++) + { + struct lrecord_implementation *imp = lrecord_implementations_table[i]; + + if (!imp) + continue; + /* For some of the early objects, Qnil was not yet initialized at + the time of object initialization, so it came up as Qnull_pointer. + Fix that now. */ + if (EQ (imp->memusage_stats_list, Qnull_pointer)) + imp->memusage_stats_list = Qnil; + { + Elemcount len = 0; + Elemcount nonlisp_len = 0; + Elemcount lisp_len = 0; + Elemcount lisp_offset = 0; + int group_num = 0; + int slice_num = 0; + + LIST_LOOP_2 (item, imp->memusage_stats_list) + { + if (EQ (item, Qt)) + { + group_num++; + if (group_num == 1) + lisp_offset = len; + slice_num = 0; + } + else if (EQ (item, Qnil)) + { + slice_num++; + } + else + { + if (slice_num == 0) + { + if (group_num == 0) + nonlisp_len++; + else if (group_num == 1) + lisp_len++; + } + len++; + } + } + + imp->num_extra_memusage_stats = len; + imp->num_extra_nonlisp_memusage_stats = nonlisp_len; + imp->num_extra_lisp_ancillary_memusage_stats = lisp_len; + imp->offset_lisp_ancillary_memusage_stats = lisp_offset; + } + } +} + +#endif /* MEMORY_USAGE_STATS */ + + +/************************************************************************/ +/* Garbage Collection -- Sweep/Compact */ +/************************************************************************/ + #ifndef NEW_GC /* Free all unmarked records */ static void @@ -3554,10 +4438,10 @@ GC_CHECK_LHEADER_INVARIANTS (h); - if (! MARKED_RECORD_HEADER_P (h) && ! header->free) + if (! MARKED_RECORD_HEADER_P (h) && !h->free) { if (LHEADER_IMPLEMENTATION (h)->finalizer) - LHEADER_IMPLEMENTATION (h)->finalizer (h, 0); + LHEADER_IMPLEMENTATION (h)->finalizer (wrap_pointer_1 (h)); } } @@ -3592,22 +4476,6 @@ /* And the Lord said: Thou shalt use the `c-backslash-region' command to make macros prettier. */ -#define COUNT_FROB_BLOCK_USAGE(type) \ - EMACS_INT s = 0; \ - struct type##_block *x = current_##type##_block; \ - while (x) { s += sizeof (*x) + MALLOC_OVERHEAD; x = x->prev; } \ - DO_NOTHING - -#define COPY_INTO_LRECORD_STATS(type) \ -do { \ - COUNT_FROB_BLOCK_USAGE (type); \ - lrecord_stats[lrecord_type_##type].bytes_in_use += s; \ - lrecord_stats[lrecord_type_##type].instances_on_free_list += \ - gc_count_num_##type##_freelist; \ - lrecord_stats[lrecord_type_##type].instances_in_use += \ - gc_count_num_##type##_in_use; \ -} while (0) - #ifdef ERROR_CHECK_GC #define SWEEP_FIXED_TYPE_BLOCK_1(typename, obj_type, lheader) \ @@ -4267,34 +5135,22 @@ static void sweep_strings (void) { - int num_small_used = 0; - Bytecount num_small_bytes = 0, num_bytes = 0; int debug = debug_string_purity; #define UNMARK_string(ptr) do { \ Lisp_String *p = (ptr); \ - Bytecount size = p->size_; \ UNMARK_RECORD_HEADER (&(p->u.lheader)); \ - num_bytes += size; \ - if (!BIG_STRING_SIZE_P (size)) \ - { \ - num_small_bytes += size; \ - num_small_used++; \ - } \ + tick_string_stats (p, 1); \ if (debug) \ debug_string_purity_print (wrap_string (p)); \ } while (0) #define ADDITIONAL_FREE_string(ptr) do { \ Bytecount size = ptr->size_; \ if (BIG_STRING_SIZE_P (size)) \ - xfree (ptr->data_); \ + xfree (ptr->data_); \ } while (0) SWEEP_FIXED_TYPE_BLOCK_1 (string, Lisp_String, u.lheader); - - gc_count_num_short_string_in_use = num_small_used; - gc_count_string_total_size = num_bytes; - gc_count_short_string_total_size = num_small_bytes; } #endif /* not NEW_GC */ @@ -4304,7 +5160,7 @@ { /* Reset all statistics to 0. They will be incremented when sweeping lcrecords, frob-block lrecords and dumped objects. */ - xzero (lrecord_stats); + clear_lrecord_stats (); /* Free all unmarked records. Do this at the very beginning, before anything else, so that the finalize methods can safely @@ -4380,16 +5236,42 @@ sweep_eval_data (); sweep_misc_user_data (); #endif /* EVENT_DATA_AS_OBJECTS */ -#endif /* not NEW_GC */ - -#ifndef NEW_GC + #ifdef PDUMP pdump_objects_unmark (); #endif } #endif /* not NEW_GC */ + -/* Clearing for disksave. */ +/************************************************************************/ +/* "Disksave Finalization" -- Preparing for Dumping */ +/************************************************************************/ + +static void +disksave_object_finalization_1 (void) +{ +#ifdef NEW_GC + mc_finalize_for_disksave (); +#else /* not NEW_GC */ + struct old_lcrecord_header *header; + + for (header = all_lcrecords; header; header = header->next) + { + struct lrecord_header *objh = &header->lheader; + const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (objh); +#if 0 /* possibly useful for debugging */ + if (!RECORD_DUMPABLE (objh) && !objh->free) + { + stderr_out ("Disksaving a non-dumpable object: "); + debug_print (wrap_pointer_1 (header)); + } +#endif + if (imp->disksave && !objh->free) + (imp->disksave) (wrap_pointer_1 (header)); + } +#endif /* not NEW_GC */ +} void disksave_object_finalization (void) @@ -4457,202 +5339,10 @@ } -#ifdef ALLOC_TYPE_STATS - -static Lisp_Object -gc_plist_hack (const Ascbyte *name, EMACS_INT value, Lisp_Object tail) -{ - /* C doesn't have local functions (or closures, or GC, or readable syntax, - or portable numeric datatypes, or bit-vectors, or characters, or - arrays, or exceptions, or ...) */ - return cons3 (intern (name), make_int (value), tail); -} - -/* Pluralize a lowercase English word stored in BUF, assuming BUF has - enough space to hold the extra letters (at most 2). */ -static void -pluralize_word (Ascbyte *buf) -{ - Bytecount len = strlen (buf); - int upper = 0; - Ascbyte d, e; - - if (len == 0 || len == 1) - goto pluralize_apostrophe_s; - e = buf[len - 1]; - d = buf[len - 2]; - upper = isupper (e); - e = tolower (e); - d = tolower (d); - if (e == 'y') - { - switch (d) - { - case 'a': - case 'e': - case 'i': - case 'o': - case 'u': - goto pluralize_s; - default: - buf[len - 1] = (upper ? 'I' : 'i'); - goto pluralize_es; - } - } - else if (e == 's' || e == 'x' || (e == 'h' && (d == 's' || d == 'c'))) - { - pluralize_es: - buf[len++] = (upper ? 'E' : 'e'); - } - pluralize_s: - buf[len++] = (upper ? 'S' : 's'); - buf[len] = '\0'; - return; - - pluralize_apostrophe_s: - buf[len++] = '\''; - goto pluralize_s; -} - -static void -pluralize_and_append (Ascbyte *buf, const Ascbyte *name, const Ascbyte *suffix) -{ - strcpy (buf, name); - pluralize_word (buf); - strcat (buf, suffix); -} - -static Lisp_Object -object_memory_usage_stats (int set_total_gc_usage) -{ - Lisp_Object pl = Qnil; - int i; - EMACS_INT tgu_val = 0; - -#ifdef NEW_GC - - for (i = 0; i < countof (lrecord_implementations_table); i++) - { - if (lrecord_stats[i].instances_in_use != 0) - { - Ascbyte buf[255]; - const Ascbyte *name = lrecord_implementations_table[i]->name; - - if (lrecord_stats[i].bytes_in_use_including_overhead != - lrecord_stats[i].bytes_in_use) - { - sprintf (buf, "%s-storage-including-overhead", name); - pl = gc_plist_hack (buf, - lrecord_stats[i] - .bytes_in_use_including_overhead, - pl); - } - - sprintf (buf, "%s-storage", name); - pl = gc_plist_hack (buf, - lrecord_stats[i].bytes_in_use, - pl); - tgu_val += lrecord_stats[i].bytes_in_use_including_overhead; - - pluralize_and_append (buf, name, "-used"); - pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); - } - } - -#else /* not NEW_GC */ - -#define HACK_O_MATIC(type, name, pl) \ -do { \ - COUNT_FROB_BLOCK_USAGE (type); \ - tgu_val += s; \ - (pl) = gc_plist_hack ((name), s, (pl)); \ -} while (0) - -#define FROB(type) \ -do { \ - COUNT_FROB_BLOCK_USAGE (type); \ - tgu_val += s; \ -} while (0) - - FROB (extent); - FROB (event); - FROB (marker); - FROB (float); -#ifdef HAVE_BIGNUM - FROB (bignum); -#endif /* HAVE_BIGNUM */ -#ifdef HAVE_RATIO - FROB (ratio); -#endif /* HAVE_RATIO */ -#ifdef HAVE_BIGFLOAT - FROB (bigfloat); -#endif /* HAVE_BIGFLOAT */ - FROB (compiled_function); - FROB (symbol); - FROB (cons); - -#undef FROB - - for (i = 0; i < lrecord_type_count; i++) - { - if (lrecord_stats[i].bytes_in_use != 0 - || lrecord_stats[i].bytes_freed != 0 - || lrecord_stats[i].instances_on_free_list != 0) - { - Ascbyte buf[255]; - const Ascbyte *name = lrecord_implementations_table[i]->name; - - sprintf (buf, "%s-storage", name); - pl = gc_plist_hack (buf, lrecord_stats[i].bytes_in_use, pl); - tgu_val += lrecord_stats[i].bytes_in_use; - pluralize_and_append (buf, name, "-freed"); - if (lrecord_stats[i].instances_freed != 0) - pl = gc_plist_hack (buf, lrecord_stats[i].instances_freed, pl); - pluralize_and_append (buf, name, "-on-free-list"); - if (lrecord_stats[i].instances_on_free_list != 0) - pl = gc_plist_hack (buf, lrecord_stats[i].instances_on_free_list, - pl); - pluralize_and_append (buf, name, "-used"); - pl = gc_plist_hack (buf, lrecord_stats[i].instances_in_use, pl); - } - } - - HACK_O_MATIC (string, "string-header-storage", pl); - pl = gc_plist_hack ("long-strings-total-length", - gc_count_string_total_size - - gc_count_short_string_total_size, pl); - HACK_O_MATIC (string_chars, "short-string-storage", pl); - pl = gc_plist_hack ("short-strings-total-length", - gc_count_short_string_total_size, pl); - pl = gc_plist_hack ("strings-free", gc_count_num_string_freelist, pl); - pl = gc_plist_hack ("long-strings-used", - gc_count_num_string_in_use - - gc_count_num_short_string_in_use, pl); - pl = gc_plist_hack ("short-strings-used", - gc_count_num_short_string_in_use, pl); - -#undef HACK_O_MATIC - -#endif /* NEW_GC */ - - if (set_total_gc_usage) - { - total_gc_usage = tgu_val; - total_gc_usage_set = 1; - } - - return pl; -} - -DEFUN("object-memory-usage-stats", Fobject_memory_usage_stats, 0, 0 ,"", /* -Return statistics about memory usage of Lisp objects. -*/ - ()) -{ - return object_memory_usage_stats (0); -} - -#endif /* ALLOC_TYPE_STATS */ + +/************************************************************************/ +/* Lisp interface onto garbage collection */ +/************************************************************************/ /* Debugging aids. */ @@ -4680,41 +5370,10 @@ call to object_memory_usage_stats() -- if ALLOC_TYPE_STATS is enabled. */ total_gc_usage_set = 0; #ifdef ALLOC_TYPE_STATS - /* The things we do for backwards-compatibility */ -#ifdef NEW_GC - return - list6 - (Fcons (make_int (lrecord_stats[lrecord_type_cons].instances_in_use), - make_int (lrecord_stats[lrecord_type_cons] - .bytes_in_use_including_overhead)), - Fcons (make_int (lrecord_stats[lrecord_type_symbol].instances_in_use), - make_int (lrecord_stats[lrecord_type_symbol] - .bytes_in_use_including_overhead)), - Fcons (make_int (lrecord_stats[lrecord_type_marker].instances_in_use), - make_int (lrecord_stats[lrecord_type_marker] - .bytes_in_use_including_overhead)), - make_int (lrecord_stats[lrecord_type_string] - .bytes_in_use_including_overhead), - make_int (lrecord_stats[lrecord_type_vector] - .bytes_in_use_including_overhead), - object_memory_usage_stats (1)); -#else /* not NEW_GC */ - return - list6 (Fcons (make_int (gc_count_num_cons_in_use), - make_int (gc_count_num_cons_freelist)), - Fcons (make_int (gc_count_num_symbol_in_use), - make_int (gc_count_num_symbol_freelist)), - Fcons (make_int (gc_count_num_marker_in_use), - make_int (gc_count_num_marker_freelist)), - make_int (gc_count_string_total_size), - make_int (lrecord_stats[lrecord_type_vector].bytes_in_use + - lrecord_stats[lrecord_type_vector].bytes_freed + - lrecord_stats[lrecord_type_vector].bytes_on_free_list), - object_memory_usage_stats (1)); -#endif /* not NEW_GC */ -#else /* not ALLOC_TYPE_STATS */ + return garbage_collection_statistics (); +#else return Qnil; -#endif /* ALLOC_TYPE_STATS */ +#endif } DEFUN ("consing-since-gc", Fconsing_since_gc, 0, 0, "", /* @@ -4753,18 +5412,6 @@ return make_int (total_data_usage ()); } -#ifdef ALLOC_TYPE_STATS -DEFUN ("object-memory-usage", Fobject_memory_usage, 0, 0, 0, /* -Return total number of bytes used for object storage in XEmacs. -This may be helpful in debugging XEmacs's memory usage. -See also `consing-since-gc' and `object-memory-usage-stats'. -*/ - ()) -{ - return make_int (total_gc_usage + consing_since_gc); -} -#endif /* ALLOC_TYPE_STATS */ - #ifdef USE_VALGRIND DEFUN ("valgrind-leak-check", Fvalgrind_leak_check, 0, 0, "", /* Ask valgrind to perform a memory leak check. @@ -4788,141 +5435,11 @@ } #endif /* USE_VALGRIND */ -void -recompute_funcall_allocation_flag (void) -{ - funcall_allocation_flag = - need_to_garbage_collect || - need_to_check_c_alloca || - need_to_signal_post_gc; -} - -int -object_dead_p (Lisp_Object obj) -{ - return ((BUFFERP (obj) && !BUFFER_LIVE_P (XBUFFER (obj))) || - (FRAMEP (obj) && !FRAME_LIVE_P (XFRAME (obj))) || - (WINDOWP (obj) && !WINDOW_LIVE_P (XWINDOW (obj))) || - (DEVICEP (obj) && !DEVICE_LIVE_P (XDEVICE (obj))) || - (CONSOLEP (obj) && !CONSOLE_LIVE_P (XCONSOLE (obj))) || - (EVENTP (obj) && !EVENT_LIVE_P (XEVENT (obj))) || - (EXTENTP (obj) && !EXTENT_LIVE_P (XEXTENT (obj)))); -} - -#ifdef MEMORY_USAGE_STATS - -/* Attempt to determine the actual amount of space that is used for - the block allocated starting at PTR, supposedly of size "CLAIMED_SIZE". - - It seems that the following holds: - - 1. When using the old allocator (malloc.c): - - -- blocks are always allocated in chunks of powers of two. For - each block, there is an overhead of 8 bytes if rcheck is not - defined, 20 bytes if it is defined. In other words, a - one-byte allocation needs 8 bytes of overhead for a total of - 9 bytes, and needs to have 16 bytes of memory chunked out for - it. - - 2. When using the new allocator (gmalloc.c): - - -- blocks are always allocated in chunks of powers of two up - to 4096 bytes. Larger blocks are allocated in chunks of - an integral multiple of 4096 bytes. The minimum block - size is 2*sizeof (void *), or 16 bytes if SUNOS_LOCALTIME_BUG - is defined. There is no per-block overhead, but there - is an overhead of 3*sizeof (size_t) for each 4096 bytes - allocated. - - 3. When using the system malloc, anything goes, but they are - generally slower and more space-efficient than the GNU - allocators. One possibly reasonable assumption to make - for want of better data is that sizeof (void *), or maybe - 2 * sizeof (void *), is required as overhead and that - blocks are allocated in the minimum required size except - that some minimum block size is imposed (e.g. 16 bytes). */ - -Bytecount -malloced_storage_size (void *UNUSED (ptr), Bytecount claimed_size, - struct overhead_stats *stats) -{ - Bytecount orig_claimed_size = claimed_size; - -#ifndef SYSTEM_MALLOC - if (claimed_size < (Bytecount) (2 * sizeof (void *))) - claimed_size = 2 * sizeof (void *); -# ifdef SUNOS_LOCALTIME_BUG - if (claimed_size < 16) - claimed_size = 16; -# endif - if (claimed_size < 4096) - { - /* fxg: rename log->log2 to supress gcc3 shadow warning */ - int log2 = 1; - - /* compute the log base two, more or less, then use it to compute - the block size needed. */ - claimed_size--; - /* It's big, it's heavy, it's wood! */ - while ((claimed_size /= 2) != 0) - ++log2; - claimed_size = 1; - /* It's better than bad, it's good! */ - while (log2 > 0) - { - claimed_size *= 2; - log2--; - } - /* We have to come up with some average about the amount of - blocks used. */ - if ((Bytecount) (rand () & 4095) < claimed_size) - claimed_size += 3 * sizeof (void *); - } - else - { - claimed_size += 4095; - claimed_size &= ~4095; - claimed_size += (claimed_size / 4096) * 3 * sizeof (size_t); - } - -#else - - if (claimed_size < 16) - claimed_size = 16; - claimed_size += 2 * sizeof (void *); - -#endif /* system allocator */ - - if (stats) - { - stats->was_requested += orig_claimed_size; - stats->malloc_overhead += claimed_size - orig_claimed_size; - } - return claimed_size; -} - -#ifndef NEW_GC -Bytecount -fixed_type_block_overhead (Bytecount size) -{ - Bytecount per_block = TYPE_ALLOC_SIZE (cons, unsigned char); - Bytecount overhead = 0; - Bytecount storage_size = malloced_storage_size (0, per_block, 0); - while (size >= per_block) - { - size -= per_block; - overhead += sizeof (void *) + per_block - storage_size; - } - if (rand () % per_block < size) - overhead += sizeof (void *) + per_block - storage_size; - return overhead; -} -#endif /* not NEW_GC */ -#endif /* MEMORY_USAGE_STATS */ - - +/************************************************************************/ +/* Initialization */ +/************************************************************************/ + /* Initialization */ static void common_init_alloc_early (void) @@ -4952,6 +5469,7 @@ #ifndef NEW_GC init_string_chars_alloc (); init_string_alloc (); + /* #### Is it intentional that this is called twice? --ben */ init_string_chars_alloc (); init_cons_alloc (); init_symbol_alloc (); @@ -5013,7 +5531,6 @@ funcall_allocation_flag = 0; funcall_alloca_count = 0; - lrecord_uid_counter = 259; #ifndef NEW_GC debug_string_purity = 0; #endif /* not NEW_GC */ @@ -5061,6 +5578,15 @@ #endif /* defined (__cplusplus) && defined (ERROR_CHECK_GC) */ } +static void +reinit_alloc_objects_early (void) +{ + OBJECT_HAS_METHOD (string, getprop); + OBJECT_HAS_METHOD (string, putprop); + OBJECT_HAS_METHOD (string, remprop); + OBJECT_HAS_METHOD (string, plist); +} + void reinit_alloc_early (void) { @@ -5068,6 +5594,7 @@ #ifndef NEW_GC init_lcrecord_lists (); #endif /* not NEW_GC */ + reinit_alloc_objects_early (); } void @@ -5081,17 +5608,7 @@ lrecord_implementations_table[i] = 0; } - INIT_LRECORD_IMPLEMENTATION (cons); - INIT_LRECORD_IMPLEMENTATION (vector); - INIT_LRECORD_IMPLEMENTATION (string); -#ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (string_indirect_data); - INIT_LRECORD_IMPLEMENTATION (string_direct_data); -#endif /* NEW_GC */ -#ifndef NEW_GC - INIT_LRECORD_IMPLEMENTATION (lcrecord_list); - INIT_LRECORD_IMPLEMENTATION (free); -#endif /* not NEW_GC */ + dump_add_opaque (lrecord_uid_counter, sizeof (lrecord_uid_counter)); staticpros = Dynarr_new2 (Lisp_Object_ptr_dynarr, Lisp_Object *); Dynarr_resize (staticpros, 1410); /* merely a small optimization */ @@ -5116,6 +5633,21 @@ #else /* not NEW_GC */ init_lcrecord_lists (); #endif /* not NEW_GC */ + + INIT_LISP_OBJECT (cons); + INIT_LISP_OBJECT (vector); + INIT_LISP_OBJECT (string); + +#ifdef NEW_GC + INIT_LISP_OBJECT (string_indirect_data); + INIT_LISP_OBJECT (string_direct_data); +#endif /* NEW_GC */ +#ifndef NEW_GC + INIT_LISP_OBJECT (lcrecord_list); + INIT_LISP_OBJECT (free); +#endif /* not NEW_GC */ + + reinit_alloc_objects_early (); } void @@ -5123,6 +5655,15 @@ { DEFSYMBOL (Qgarbage_collecting); +#ifdef MEMORY_USAGE_STATS + DEFSYMBOL (Qobject_actually_requested); + DEFSYMBOL (Qobject_malloc_overhead); + DEFSYMBOL (Qother_memory_actually_requested); + DEFSYMBOL (Qother_memory_malloc_overhead); + DEFSYMBOL (Qother_memory_dynarr_overhead); + DEFSYMBOL (Qother_memory_gap_overhead); +#endif /* MEMORY_USAGE_STATS */ + DEFSUBR (Fcons); DEFSUBR (Flist); DEFSUBR (Fvector); @@ -5138,8 +5679,11 @@ DEFSUBR (Fpurecopy); #ifdef ALLOC_TYPE_STATS DEFSUBR (Fobject_memory_usage_stats); + DEFSUBR (Ftotal_object_memory_usage); +#endif /* ALLOC_TYPE_STATS */ +#ifdef MEMORY_USAGE_STATS DEFSUBR (Fobject_memory_usage); -#endif /* ALLOC_TYPE_STATS */ +#endif /* MEMORY_USAGE_STATS */ DEFSUBR (Fgarbage_collect); #if 0 DEFSUBR (Fmemory_limit); @@ -5153,6 +5697,14 @@ } void +reinit_vars_of_alloc (void) +{ +#ifdef MEMORY_USAGE_STATS + compute_memusage_stats_length (); +#endif /* MEMORY_USAGE_STATS */ +} + +void vars_of_alloc (void) { #ifdef DEBUG_XEMACS
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/array.c Mon Mar 29 21:28:13 2010 -0500 @@ -0,0 +1,1009 @@ +/* Support for dynarrs and other types of dynamic arrays. + Copyright (c) 1994, 1995 Free Software Foundation, Inc. + Copyright (c) 1993, 1995 Sun Microsystems, Inc. + Copyright (c) 1995, 1996, 2000, 2002, 2003, 2004, 2005, 2010 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute 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. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* Written by Ben Wing, December 1993. */ + +#include <config.h> +#include "lisp.h" + +#include "insdel.h" + + +/*****************************************************************************/ +/* "dynarr" a.k.a. dynamic array */ +/*****************************************************************************/ + +/* +A "dynamic array" or "dynarr" is a contiguous array of fixed-size elements +where there is no upper limit (except available memory) on the number of +elements in the array. Because the elements are maintained contiguously, +space is used efficiently (no per-element pointers necessary) and random +access to a particular element is in constant time. At any one point, the +block of memory that holds the array has an upper limit; if this limit is +exceeded, the memory is realloc()ed into a new array that is twice as big. +Assuming that the time to grow the array is on the order of the new size of +the array block, this scheme has a provably constant amortized time +\(i.e. average time over all additions). + +When you add elements or retrieve elements, pointers are used. Note that +the element itself (of whatever size it is), and not the pointer to it, +is stored in the array; thus you do not have to allocate any heap memory +on your own. Also, returned pointers are only guaranteed to be valid +until the next operation that changes the length of the array. + +This is a container object. Declare a dynamic array of a specific type +as follows: + + typedef struct + { + Dynarr_declare (mytype); + } mytype_dynarr; + +Use the following functions/macros: + + + ************* Dynarr creation ************* + + void *Dynarr_new(type) + [MACRO] Create a new dynamic-array object, with each element of the + specified type. The return value is cast to (type##_dynarr). + This requires following the convention that types are declared in + such a way that this type concatenation works. In particular, TYPE + must be a symbol, not an arbitrary C type. To make dynarrs of + complex types, a typedef must be declared, e.g. + + typedef unsigned char *unsigned_char_ptr; + + and then you can say + + unsigned_char_ptr_dynarr *dyn = Dynarr_new (unsigned_char_ptr); + + void *Dynarr_new2(dynarr_type, type) + [MACRO] Create a new dynamic-array object, with each element of the + specified type. The array itself is of type DYNARR_TYPE. This makes + it possible to create dynarrs over complex types without the need + to create typedefs, as described above. Use is as follows: + + ucharptr_dynarr *dyn = Dynarr_new2 (ucharptr_dynarr *, unsigned char *); + + Dynarr_free(d) + Destroy a dynamic array and the memory allocated to it. + + ************* Dynarr access ************* + + type Dynarr_at(d, i) + [MACRO] Return the element at the specified index. The index must be + between 0 and Dynarr_largest(d), inclusive. With error-checking + enabled, bounds checking on the index is in the form of asserts() -- + an out-of-bounds index causes an abort. The element itself is + returned, not a pointer to it. + + type *Dynarr_atp(d, i) + [MACRO] Return a pointer to the element at the specified index. + Restrictions and bounds checking on the index is as for Dynarr_at. + The pointer may not be valid after an element is added to or + (conceivably) removed from the array, because this may trigger a + realloc() performed on the underlying dynarr storage, which may + involve moving the entire underlying storage to a new location in + memory. + + type *Dynarr_begin(d) + [MACRO] Return a pointer to the first element in the dynarr. See + Dynarr_atp() for warnings about when the pointer might become invalid. + + type *Dynarr_lastp(d) + [MACRO] Return a pointer to the last element in the dynarr. See + Dynarr_atp() for warnings about when the pointer might become invalid. + + type *Dynarr_past_lastp(d) + [MACRO] Return a pointer to the beginning of the element just past the + last one. WARNING: This may not point to valid memory; however, the + byte directly before will be pointer will be valid memory. This macro + might be useful for various reasons, e.g. as a stopping point in a loop + (although Dynarr_lastp() could be used just as well) or as a place to + start writing elements if Dynarr_length() < Dynarr_largest(). + + ************* Dynarr length/size retrieval and setting ************* + + int Dynarr_length(d) + [MACRO] Return the number of elements currently in a dynamic array. + + int Dynarr_largest(d) + [MACRO] Return the maximum value that Dynarr_length(d) would + ever have returned. This is used esp. in the redisplay code, + which reuses dynarrs for performance reasons. + + int Dynarr_max(d) + [MACRO] Return the maximum number of elements that can fit in the + dynarr before it needs to be resized. + + Note that Dynarr_length(d) <= Dynarr_largest(d) <= Dynarr_max(d). + + Bytecount Dynarr_sizeof(d) + [MACRO] Return the total size of the elements currently in dynarr + D. This + + Dynarr_set_lengthr(d, len) + [MACRO] Set the length of D to LEN, which must be between 0 and + Dynarr_largest(d), inclusive. With error-checking enabled, an + assertion failure will result from trying to set the length + to less than zero or greater than Dynarr_largest(d). The + restriction to Dynarr_largest() is to ensure that + + Dynarr_set_length(d, len) + [MACRO] Set the length of D to LEN, resizing the dynarr as + necessary to make sure enough space is available. there are no + restrictions on LEN other than available memory and that it must + be at least 0. Note that + + Dynarr_set_length_and_zero(d, len) + [MACRO] Like Dynarr_set_length(d, len) but also, if increasing + the length, zero out the memory between the old and new lengths, + i.e. starting just past the previous last element and up through + the new last element. + + Dynarr_incrementr(d) + [MACRO] Increments the length of D by 1. Equivalent to + Dynarr_set_lengthr(d, Dynarr_length(d) + 1). + + Dynarr_increment(d) + [MACRO] Increments the length of D by 1. Equivalent to + Dynarr_set_length(d, Dynarr_length(d) + 1). + + Dynarr_reset(d) + [MACRO] Reset the length of a dynamic array to 0. + + Dynarr_resize(d, maxval) + Resize the internal dynarr storage to so that it can hold at least + MAXVAL elements. Resizing is done using a geometric series + (repeatedly multiply the old maximum by a constant, normally 1.5, + till a large enough size is reached), so this will be efficient + even if resizing larger by one element at a time. This is mostly + an internal function. + + + + ************* Adding/deleting elements to/from a dynarr ************* + + Dynarr_add(d, el) + [MACRO] Add an element to the end of a dynamic array. EL is a pointer + to the element; the element itself is stored in the array, however. + No function call is performed unless the array needs to be resized. + + Dynarr_add_many(d, base, len) + [MACRO] Add LEN elements to the end of the dynamic array. The elements + should be contiguous in memory, starting at BASE. If BASE if NULL, + just make space for the elements; don't actually add them. + + Dynarr_prepend_many(d, base, len) + [MACRO] Prepend LEN elements to the beginning of the dynamic array. + The elements should be contiguous in memory, starting at BASE. + If BASE if NULL, just make space for the elements; don't actually + add them. + + Dynarr_insert_many(d, base, len, pos) + Insert LEN elements to the dynamic array starting at position + POS. The elements should be contiguous in memory, starting at BASE. + If BASE if NULL, just make space for the elements; don't actually + add them. + + type Dynarr_pop(d) + [MACRO] Pop the last element off the dynarr and return it. + + Dynarr_delete(d, i) + [MACRO] Delete an element from the dynamic array at position I. + + Dynarr_delete_many(d, pos, len) + Delete LEN elements from the dynamic array starting at position + POS. + + Dynarr_zero_many(d, pos, len) + Zero out LEN elements in the dynarr D starting at position POS. + + Dynarr_delete_by_pointer(d, p) + [MACRO] Delete an element from the dynamic array at pointer P, + which must point within the block of memory that stores the data. + P should be obtained using Dynarr_atp(). + + ************* Dynarr locking ************* + + Dynarr_lock(d) + Lock the dynarr against further locking or writing. With error-checking + enabled, any attempts to write into a locked dynarr or re-lock an + already locked one will cause an assertion failure and abort. + + Dynarr_unlock(d) + Unlock a locked dynarr, allowing writing into it. + + ************* Dynarr global variables ************* + + Dynarr_min_size + Minimum allowable size for a dynamic array when it is resized. + +*/ + +static const struct memory_description const_Ascbyte_ptr_description_1[] = { + { XD_ASCII_STRING, 0 }, + { XD_END } +}; + +const struct sized_memory_description const_Ascbyte_ptr_description = { + sizeof (const Ascbyte *), + const_Ascbyte_ptr_description_1 +}; + +static const struct memory_description const_Ascbyte_ptr_dynarr_description_1[] = { + XD_DYNARR_DESC (const_Ascbyte_ptr_dynarr, &const_Ascbyte_ptr_description), + { XD_END } +}; + +const struct sized_memory_description const_Ascbyte_ptr_dynarr_description = { + sizeof (const_Ascbyte_ptr_dynarr), + const_Ascbyte_ptr_dynarr_description_1 +}; + + +static Elemcount Dynarr_min_size = 8; + +static void +Dynarr_realloc (Dynarr *dy, Elemcount new_size) +{ + if (DUMPEDP (dy->base)) + { + void *new_base = malloc (new_size * Dynarr_elsize (dy)); + memcpy (new_base, dy->base, + (Dynarr_max (dy) < new_size ? Dynarr_max (dy) : new_size) * + Dynarr_elsize (dy)); + dy->base = new_base; + } + else + dy->base = xrealloc (dy->base, new_size * Dynarr_elsize (dy)); +} + +void * +Dynarr_newf (Bytecount elsize) +{ + Dynarr *d = xnew_and_zero (Dynarr); + d->elsize_ = elsize; + + return d; +} + +#ifdef NEW_GC +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("dynarr", dynarr, + 0, 0, + Dynarr); + +static void +Dynarr_lisp_realloc (Dynarr *dy, Elemcount new_size) +{ + void *new_base = + XPNTR (alloc_sized_lrecord_array (Dynarr_elsize (dy), new_size, + dy->lisp_imp)); + if (dy->base) + memcpy (new_base, dy->base, + (Dynarr_max (dy) < new_size ? Dynarr_max (dy) : new_size) * + Dynarr_elsize (dy)); + dy->base = new_base; +} + +void * +Dynarr_lisp_newf (Bytecount elsize, + const struct lrecord_implementation *dynarr_imp, + const struct lrecord_implementation *imp) +{ + Dynarr *d = (Dynarr *) XPNTR (alloc_sized_lrecord (sizeof (Dynarr), + dynarr_imp)); + d->elsize_ = elsize; + d->lisp_imp = imp; + + return d; +} +#endif /* not NEW_GC */ + +void +Dynarr_resize (void *d, Elemcount size) +{ + Elemcount newsize; + double multiplier; + Dynarr *dy = (Dynarr *) Dynarr_verify (d); + + if (Dynarr_max (dy) <= 8) + multiplier = 2; + else + multiplier = 1.5; + + for (newsize = Dynarr_max (dy); newsize < size;) + newsize = max (Dynarr_min_size, (Elemcount) (multiplier * newsize)); + + /* Don't do anything if the array is already big enough. */ + if (newsize > Dynarr_max (dy)) + { +#ifdef NEW_GC + if (dy->lisp_imp) + Dynarr_lisp_realloc (dy, newsize); + else + Dynarr_realloc (dy, newsize); +#else /* not NEW_GC */ + Dynarr_realloc (dy, newsize); +#endif /* not NEW_GC */ + dy->max_ = newsize; + } +} + +/* Add a number of contiguous elements to the array starting at POS. */ + +void +Dynarr_insert_many (void *d, const void *base, Elemcount len, Elemcount pos) +{ + Dynarr *dy = Dynarr_verify_mod (d); + Elemcount old_len = Dynarr_length (dy); + + /* #### This could conceivably be wrong, if code wants to access stuff + between len and largest. */ + dynarr_checking_assert (pos >= 0 && pos <= old_len); + dynarr_checking_assert (len >= 0); + Dynarr_increase_length (dy, old_len + len); + + if (pos != old_len) + { + memmove ((Rawbyte *) dy->base + (pos + len)*Dynarr_elsize (dy), + (Rawbyte *) dy->base + pos*Dynarr_elsize (dy), + (old_len - pos)*Dynarr_elsize (dy)); + } + /* Some functions call us with a value of 0 to mean "reserve space but + don't write into it" */ + if (base) + memcpy ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), base, + len*Dynarr_elsize (dy)); +} + +void +Dynarr_delete_many (void *d, Elemcount pos, Elemcount len) +{ + Dynarr *dy = Dynarr_verify_mod (d); + + dynarr_checking_assert (pos >= 0 && len >= 0 && + pos + len <= Dynarr_length (dy)); + + memmove ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), + (Rawbyte *) dy->base + (pos + len)*Dynarr_elsize (dy), + (Dynarr_length (dy) - pos - len)*Dynarr_elsize (dy)); + + Dynarr_set_length_1 (dy, Dynarr_length (dy) - len); +} + +void +Dynarr_free (void *d) +{ + Dynarr *dy = (Dynarr *) d; + +#ifdef NEW_GC + if (dy->base && !DUMPEDP (dy->base)) + { + if (!dy->lisp_imp) + { + xfree (dy->base); + dy->base = 0; + } + } + if (!DUMPEDP (dy)) + { + if (!dy->lisp_imp) + xfree (dy); + } +#else /* not NEW_GC */ + if (dy->base && !DUMPEDP (dy->base)) + { + xfree (dy->base); + dy->base = 0; + } + if(!DUMPEDP (dy)) + xfree (dy); +#endif /* not NEW_GC */ +} + +#ifdef MEMORY_USAGE_STATS + +/* Return memory usage for dynarr D. The returned value is the total + amount of bytes actually being used for the dynarr, including all + overhead. The extra amount of space in the dynarr that is + allocated beyond what was requested is returned in DYNARR_OVERHEAD + in STATS. The extra amount of space that malloc() allocates beyond + what was requested of it is returned in MALLOC_OVERHEAD in STATS. + See the comment above the definition of this structure. */ + +Bytecount +Dynarr_memory_usage (void *d, struct usage_stats *stats) +{ + Bytecount total = 0; + Dynarr *dy = (Dynarr *) d; + + /* We have to be a bit tricky here because not all of the + memory that malloc() will claim as "requested" was actually + requested. */ + + if (dy->base) + { + Bytecount malloc_used = + malloced_storage_size (dy->base, Dynarr_elsize (dy) * Dynarr_max (dy), + 0); + /* #### This may or may not be correct. Some dynarrs would + prefer that we use dy->len instead of dy->largest here. */ + Bytecount was_requested = Dynarr_elsize (dy) * Dynarr_largest (dy); + Bytecount dynarr_overhead = + Dynarr_elsize (dy) * (Dynarr_max (dy) - Dynarr_largest (dy)); + + total += malloc_used; + stats->was_requested += was_requested; + stats->dynarr_overhead += dynarr_overhead; + /* And the remainder must be malloc overhead. */ + stats->malloc_overhead += + malloc_used - was_requested - dynarr_overhead; + } + + total += malloced_storage_size (d, sizeof (*dy), stats); + + return total; +} + +#endif /* MEMORY_USAGE_STATS */ + + +/*****************************************************************************/ +/* stack-like allocation */ +/*****************************************************************************/ + +/* Version of malloc() that will be extremely efficient when allocation + nearly always occurs in LIFO (stack) order. + + #### Perhaps shouldn't be in this file, but where else? */ + +typedef struct +{ + Dynarr_declare (char_dynarr *); +} char_dynarr_dynarr; + +char_dynarr_dynarr *stack_like_free_list; +char_dynarr_dynarr *stack_like_in_use_list; + +void * +stack_like_malloc (Bytecount size) +{ + char_dynarr *this_one; + if (!stack_like_free_list) + { + stack_like_free_list = Dynarr_new2 (char_dynarr_dynarr, + char_dynarr *); + stack_like_in_use_list = Dynarr_new2 (char_dynarr_dynarr, + char_dynarr *); + } + + if (Dynarr_length (stack_like_free_list) > 0) + this_one = Dynarr_pop (stack_like_free_list); + else + this_one = Dynarr_new (char); + Dynarr_add (stack_like_in_use_list, this_one); + Dynarr_reset (this_one); + Dynarr_add_many (this_one, 0, size); + return Dynarr_begin (this_one); +} + +void +stack_like_free (void *val) +{ + Elemcount len = Dynarr_length (stack_like_in_use_list); + assert (len > 0); + /* The vast majority of times, we will be called in a last-in first-out + order, and the item at the end of the list will be the one we're + looking for, so just check for this first and avoid any function + calls. */ + if (Dynarr_begin (Dynarr_at (stack_like_in_use_list, len - 1)) == val) + { + char_dynarr *this_one = Dynarr_pop (stack_like_in_use_list); + Dynarr_add (stack_like_free_list, this_one); + } + else + { + /* Find the item and delete it. */ + int i; + assert (len >= 2); + for (i = len - 2; i >= 0; i--) + if (Dynarr_begin (Dynarr_at (stack_like_in_use_list, i)) == + val) + { + char_dynarr *this_one = Dynarr_at (stack_like_in_use_list, i); + Dynarr_add (stack_like_free_list, this_one); + Dynarr_delete (stack_like_in_use_list, i); + return; + } + + ABORT (); + } +} + + +/*****************************************************************************/ +/* Generalized gap array */ +/*****************************************************************************/ + +/* A "gap array" is an array that has a "gap" somewhere in the middle of it, + so that insertions and deletions near the gap -- or in general, highly + localized insertions and deletions -- are very fast. Inserting or + deleting works by first moving the gap to the insertion or deletion + position and then shortening or lengthening the gap as necessary. The + idea comes from the gap used in storing text in a buffer. + + The gap array interface differs in a number of ways from dynarrs (#### + and should be changed so that it works the same as dynarrs): + + (1) There aren't separate type-specific gap array types. As a result, + operations like gap_array_at() require that the type be specified as + one of the arguments. It is often more convenient to use a macro + wrapper around this operation. + + (2) The gap array type is itself a stretchy array rather than using a + separate block of memory to store the array. This means that certain + operations (especially insertions) may relocate the the gap array, + and as a result return a pointer to the (possibly) moved gap array, + which must be stored back into the location where the gap array + pointer resides. This also means that the caller must worry about + cloning the gap array in the case where it has been dumped, or you + will get an ABORT() inside of xrealloc(). + + (3) Fewer operations are available than for dynarrs, and may have + different names and/or different calling conventions. + + (4) The mechanism for creating "Lisp-object gap arrays" isn't completely + developed. Currently it's only possible to create a gap-array Lisp + object that wraps Lisp_Object pointers (not Lisp object structures + directly), and only under NEW_GC. + + (5) Gap arrays have a concept of a "gap array marker" that properly + tracks insertions and deletions; no such thing exists in dynarrs. + It exists in gap arrays because it's necessary for their use in + implementing extent lists. + */ + +extern const struct sized_memory_description gap_array_marker_description; + +static const struct memory_description gap_array_marker_description_1[] = { +#ifdef NEW_GC + { XD_LISP_OBJECT, offsetof (Gap_Array_Marker, next) }, +#else /* not NEW_GC */ + { XD_BLOCK_PTR, offsetof (Gap_Array_Marker, next), 1, + { &gap_array_marker_description } }, +#endif /* not NEW_GC */ + { XD_END } +}; + +#ifdef NEW_GC +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("gap-array-marker", gap_array_marker, + 0, gap_array_marker_description_1, + struct gap_array_marker); +#else /* not NEW_GC */ +const struct sized_memory_description gap_array_marker_description = { + sizeof (Gap_Array_Marker), + gap_array_marker_description_1 +}; +#endif /* not NEW_GC */ + +static const struct memory_description lispobj_gap_array_description_1[] = { + XD_GAP_ARRAY_DESC (&lisp_object_description), + { XD_END } +}; + +#ifdef NEW_GC + +static Bytecount +size_gap_array (Lisp_Object obj) +{ + Gap_Array *ga = XGAP_ARRAY (obj); + return gap_array_byte_size (ga); +} + +DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("gap-array", gap_array, + 0, + lispobj_gap_array_description_1, + size_gap_array, + struct gap_array); +#else /* not NEW_GC */ +const struct sized_memory_description lispobj_gap_array_description = { + 0, lispobj_gap_array_description_1 +}; +#endif /* (not) NEW_GC */ + +#ifndef NEW_GC +static Gap_Array_Marker *gap_array_marker_freelist; +#endif /* not NEW_GC */ + +/* This generalizes the "array with a gap" model used to store buffer + characters. This is based on the stuff in insdel.c and should + probably be merged with it. This is not extent-specific and should + perhaps be moved into a separate file. */ + +/* ------------------------------- */ +/* internal functions */ +/* ------------------------------- */ + +/* Adjust the gap array markers in the range (FROM, TO]. Parallel to + adjust_markers() in insdel.c. */ + +static void +gap_array_adjust_markers (Gap_Array *ga, Memxpos from, + Memxpos to, Elemcount amount) +{ + Gap_Array_Marker *m; + + for (m = ga->markers; m; m = m->next) + m->pos = do_marker_adjustment (m->pos, from, to, amount); +} + +static void +gap_array_recompute_derived_values (Gap_Array *ga) +{ + ga->offset_past_gap = ga->elsize * (ga->gap + ga->gapsize); + ga->els_past_gap = ga->numels - ga->gap; +} + +/* Move the gap to array position POS. Parallel to move_gap() in + insdel.c but somewhat simplified. */ + +static void +gap_array_move_gap (Gap_Array *ga, Elemcount pos) +{ + Elemcount gap = ga->gap; + Elemcount gapsize = ga->gapsize; + + if (pos < gap) + { + memmove (GAP_ARRAY_MEMEL_ADDR (ga, pos + gapsize), + GAP_ARRAY_MEMEL_ADDR (ga, pos), + (gap - pos)*ga->elsize); + gap_array_adjust_markers (ga, (Memxpos) pos, (Memxpos) gap, + gapsize); + } + else if (pos > gap) + { + memmove (GAP_ARRAY_MEMEL_ADDR (ga, gap), + GAP_ARRAY_MEMEL_ADDR (ga, gap + gapsize), + (pos - gap)*ga->elsize); + gap_array_adjust_markers (ga, (Memxpos) (gap + gapsize), + (Memxpos) (pos + gapsize), - gapsize); + } + ga->gap = pos; + + gap_array_recompute_derived_values (ga); +} + +/* Make the gap INCREMENT characters longer. Parallel to make_gap() in + insdel.c. The gap array may be moved, so assign the return value back + to the array pointer. */ + +static Gap_Array * +gap_array_make_gap (Gap_Array *ga, Elemcount increment) +{ + Elemcount real_gap_loc; + Elemcount old_gap_size; + + /* If we have to get more space, get enough to last a while. We use + a geometric progression that saves on realloc space. */ + increment += 100 + ga->numels / 8; + +#ifdef NEW_GC + if (ga->is_lisp) + ga = (Gap_Array *) mc_realloc (ga, + offsetof (Gap_Array, array) + + (ga->numels + ga->gapsize + increment) * + ga->elsize); + else +#endif /* not NEW_GC */ + ga = (Gap_Array *) xrealloc (ga, + offsetof (Gap_Array, array) + + (ga->numels + ga->gapsize + increment) * + ga->elsize); + if (ga == 0) + memory_full (); + + real_gap_loc = ga->gap; + old_gap_size = ga->gapsize; + + /* Call the newly allocated space a gap at the end of the whole space. */ + ga->gap = ga->numels + ga->gapsize; + ga->gapsize = increment; + + /* Move the new gap down to be consecutive with the end of the old one. + This adjusts the markers properly too. */ + gap_array_move_gap (ga, real_gap_loc + old_gap_size); + + /* Now combine the two into one large gap. */ + ga->gapsize += old_gap_size; + ga->gap = real_gap_loc; + + gap_array_recompute_derived_values (ga); + + return ga; +} + +/* ------------------------------- */ +/* external functions */ +/* ------------------------------- */ + +Bytecount +gap_array_byte_size (Gap_Array *ga) +{ + return offsetof (Gap_Array, array) + (ga->numels + ga->gapsize) * ga->elsize; +} + +/* Insert NUMELS elements (pointed to by ELPTR) into the specified + gap array at POS. The gap array may be moved, so assign the + return value back to the array pointer. */ + +Gap_Array * +gap_array_insert_els (Gap_Array *ga, Elemcount pos, void *elptr, + Elemcount numels) +{ + assert (pos >= 0 && pos <= ga->numels); + if (ga->gapsize < numels) + ga = gap_array_make_gap (ga, numels - ga->gapsize); + if (pos != ga->gap) + gap_array_move_gap (ga, pos); + + memcpy (GAP_ARRAY_MEMEL_ADDR (ga, ga->gap), (char *) elptr, + numels*ga->elsize); + ga->gapsize -= numels; + ga->gap += numels; + ga->numels += numels; + gap_array_recompute_derived_values (ga); + /* This is the equivalent of insert-before-markers. + + #### Should only happen if marker is "moves forward at insert" type. + */ + + gap_array_adjust_markers (ga, pos - 1, pos, numels); + return ga; +} + +/* Delete NUMELS elements from the specified gap array, starting at FROM. */ + +void +gap_array_delete_els (Gap_Array *ga, Elemcount from, Elemcount numdel) +{ + Elemcount to = from + numdel; + Elemcount gapsize = ga->gapsize; + + assert (from >= 0); + assert (numdel >= 0); + assert (to <= ga->numels); + + /* Make sure the gap is somewhere in or next to what we are deleting. */ + if (to < ga->gap) + gap_array_move_gap (ga, to); + if (from > ga->gap) + gap_array_move_gap (ga, from); + + /* Relocate all markers pointing into the new, larger gap + to point at the end of the text before the gap. */ + gap_array_adjust_markers (ga, to + gapsize, to + gapsize, + - numdel - gapsize); + + ga->gapsize += numdel; + ga->numels -= numdel; + ga->gap = from; + gap_array_recompute_derived_values (ga); +} + +Gap_Array_Marker * +gap_array_make_marker (Gap_Array *ga, Elemcount pos) +{ + Gap_Array_Marker *m; + + assert (pos >= 0 && pos <= ga->numels); +#ifdef NEW_GC + m = XGAP_ARRAY_MARKER (ALLOC_NORMAL_LISP_OBJECT (gap_array_marker)); +#else /* not NEW_GC */ + if (gap_array_marker_freelist) + { + m = gap_array_marker_freelist; + gap_array_marker_freelist = gap_array_marker_freelist->next; + } + else + m = xnew (Gap_Array_Marker); +#endif /* not NEW_GC */ + + m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); + m->next = ga->markers; + ga->markers = m; + return m; +} + +void +gap_array_delete_marker (Gap_Array *ga, Gap_Array_Marker *m) +{ + Gap_Array_Marker *p, *prev; + + for (prev = 0, p = ga->markers; p && p != m; prev = p, p = p->next) + ; + assert (p); + if (prev) + prev->next = p->next; + else + ga->markers = p->next; +#ifndef NEW_GC + m->next = gap_array_marker_freelist; + m->pos = 0xDEADBEEF; /* -559038737 base 10 */ + gap_array_marker_freelist = m; +#endif /* not NEW_GC */ +} + +#ifndef NEW_GC +void +gap_array_delete_all_markers (Gap_Array *ga) +{ + Gap_Array_Marker *p, *next; + + for (p = ga->markers; p; p = next) + { + next = p->next; + p->next = gap_array_marker_freelist; + p->pos = 0xDEADBEEF; /* -559038737 as an int */ + gap_array_marker_freelist = p; + } +} +#endif /* not NEW_GC */ + +void +gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, Elemcount pos) +{ + assert (pos >= 0 && pos <= ga->numels); + m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); +} + +Gap_Array * +make_gap_array (Elemcount elsize, int USED_IF_NEW_GC (do_lisp)) +{ + Gap_Array *ga; +#ifdef NEW_GC + /* #### I don't quite understand why it's necessary to make all these + internal objects into Lisp objects under NEW_GC. It's a pain in the + ass to code around this. I'm proceeding on the assumption that it's + not really necessary to do it after all, and so we only make a Lisp- + object gap array when the object being held is a Lisp_Object, i.e. a + pointer to a Lisp object. In the case where instead we hold a `struct + range_table_entry', just blow it off. Otherwise we either need to do + a bunch of painful and/or boring rewriting. --ben */ + if (do_lisp) + { + ga = XGAP_ARRAY (ALLOC_SIZED_LISP_OBJECT (sizeof (Gap_Array), + gap_array)); + ga->is_lisp = 1; + } + else +#endif /* not NEW_GC */ + ga = xnew_and_zero (Gap_Array); + ga->elsize = elsize; + return ga; +} + +Gap_Array * +gap_array_clone (Gap_Array *ga) +{ + Bytecount size = gap_array_byte_size (ga); + Gap_Array *ga2; + Gap_Array_Marker *m; + +#ifdef NEW_GC + if (ga->is_lisp) + { + ga2 = XGAP_ARRAY (ALLOC_SIZED_LISP_OBJECT (size, gap_array)); + copy_lisp_object (wrap_gap_array (ga2), wrap_gap_array (ga)); + } + else +#endif + { + ga2 = (Gap_Array *) xmalloc (size); + memcpy (ga2, ga, size); + } + ga2->markers = NULL; + for (m = ga->markers; m; m = m->next) + gap_array_make_marker (ga2, m->pos); + return ga2; +} + +#ifndef NEW_GC +void +free_gap_array (Gap_Array *ga) +{ + gap_array_delete_all_markers (ga); + xfree (ga); +} +#endif /* not NEW_GC */ + +#ifdef MEMORY_USAGE_STATS + +/* Return memory usage for gap array GA. The returned value is the total + amount of bytes actually being used for the gap array, including all + overhead. The extra amount of space in the gap array that is used + for the gap is counted in GAP_OVERHEAD, not in WAS_REQUESTED. + If NEW_GC, space for gap-array markers is returned through MARKER_ANCILLARY; + otherwise it's added into the gap array usage. */ + +Bytecount +gap_array_memory_usage (Gap_Array *ga, struct usage_stats *stats, + Bytecount *marker_ancillary) +{ + Bytecount total = 0; + + /* We have to be a bit tricky here because not all of the + memory that malloc() will claim as "requested" was actually + requested -- some of it makes up the gap. */ + + Bytecount size = gap_array_byte_size (ga); + Bytecount gap_size = ga->gapsize * ga->elsize; + Bytecount malloc_used = malloced_storage_size (ga, size, 0); + total += malloc_used; + stats->was_requested += size - gap_size; + stats->gap_overhead += gap_size; + stats->malloc_overhead += malloc_used - size; + +#ifdef NEW_GC + { + Bytecount marker_usage = 0; + Gap_Array_Marker *p; + + for (p = ga->markers; p; p = p->next) + marker_usage += lisp_object_memory_usage (wrap_gap_array_marker (p)); + if (marker_ancillary) + *marker_ancillary = marker_usage; + } +#else + { + Gap_Array_Marker *p; + + for (p = ga->markers; p; p = p->next) + total += malloced_storage_size (p, sizeof (p), stats); + if (marker_ancillary) + *marker_ancillary = 0; + } +#endif /* (not) NEW_GC */ + + return total; +} + +#endif /* MEMORY_USAGE_STATS */ + + +/*****************************************************************************/ +/* Initialization */ +/*****************************************************************************/ + +void +syms_of_array (void) +{ +#ifdef NEW_GC + INIT_LISP_OBJECT (gap_array_marker); + INIT_LISP_OBJECT (gap_array); +#endif /* NEW_GC */ +} +
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/array.h Mon Mar 29 21:28:13 2010 -0500 @@ -0,0 +1,769 @@ +/* Header for arrays (dynarrs, gap arrays, etc.). + Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. + Copyright (C) 1996, 2001, 2002, 2004, 2005, 2009, 2010 Ben Wing. + +This file is part of XEmacs. + +XEmacs is free software; you can redistribute 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. + +XEmacs is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with XEmacs; see the file COPYING. If not, write to +the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +Boston, MA 02111-1307, USA. */ + +/* Synched up with: Not in FSF. */ + +/* This file has been Mule-ized, Ben Wing, 10-13-04. */ + +#ifndef INCLUDED_array_h_ +#define INCLUDED_array_h_ + +/************************************************************************/ +/** Definition of dynamic arrays (dynarrs) **/ +/************************************************************************/ + +BEGIN_C_DECLS + +/************* Dynarr declaration *************/ + +#ifdef NEW_GC +#define DECLARE_DYNARR_LISP_IMP() \ + const struct lrecord_implementation *lisp_imp; +#else +#define DECLARE_DYNARR_LISP_IMP() +#endif + +#ifdef ERROR_CHECK_DYNARR +#define DECLARE_DYNARR_LOCKED() \ + int locked; +#else +#define DECLARE_DYNARR_LOCKED() +#endif + +#define Dynarr_declare(type) \ + struct lrecord_header header; \ + type *base; \ + DECLARE_DYNARR_LISP_IMP () \ + DECLARE_DYNARR_LOCKED () \ + int elsize_; \ + int len_; \ + int largest_; \ + int max_ + +typedef struct dynarr +{ + Dynarr_declare (void); +} Dynarr; + +#define XD_DYNARR_DESC(base_type, sub_desc) \ + { XD_BLOCK_PTR, offsetof (base_type, base), \ + XD_INDIRECT(1, 0), {sub_desc} }, \ + { XD_INT, offsetof (base_type, len_) }, \ + { XD_INT_RESET, offsetof (base_type, largest_), XD_INDIRECT(1, 0) }, \ + { XD_INT_RESET, offsetof (base_type, max_), XD_INDIRECT(1, 0) } + +#ifdef NEW_GC +#define XD_LISP_DYNARR_DESC(base_type, sub_desc) \ + { XD_INLINE_LISP_OBJECT_BLOCK_PTR, offsetof (base_type, base), \ + XD_INDIRECT(1, 0), {sub_desc} }, \ + { XD_INT, offsetof (base_type, len_) }, \ + { XD_INT_RESET, offsetof (base_type, largest_), XD_INDIRECT(1, 0) }, \ + { XD_INT_RESET, offsetof (base_type, max_), XD_INDIRECT(1, 0) } +#endif /* NEW_GC */ + +/************* Dynarr verification *************/ + +/* Dynarr locking and verification. + + [I] VERIFICATION + + Verification routines simply return their basic argument, possibly + casted, but in the process perform some verification on it, aborting if + the verification fails. The verification routines take FILE and LINE + parameters, and use them to output the file and line of the caller + when an abort occurs, rather than the file and line of the inline + function, which is less than useful. + + There are three basic types of verification routines: + + (1) Verify the dynarr itself. This verifies the basic invariant + involving the length/size values: + + 0 <= Dynarr_length(d) <= Dynarr_largest(d) <= Dynarr_max(d) + + (2) Verify the dynarr itself prior to modifying it. This performs + the same verification as previously, but also checks that the + dynarr is not locked (see below). + + (3) Verify a dynarr position. Unfortunately we have to have + different verification routines depending on which kind of operation + is being performed: + + (a) For Dynarr_at(), we check that the POS is bounded by Dynarr_largest(), + i.e. 0 <= POS < Dynarr_largest(). + (b) For Dynarr_atp_allow_end(), we also have to allow + POS == Dynarr_largest(). + (c) For Dynarr_atp(), we behave largely like Dynarr_at() but make a + special exception when POS == 0 and Dynarr_largest() == 0 -- see + comment below. + (d) Some other routines contain the POS verification within their code, + and make the check 0 <= POS < Dynarr_length() or + 0 <= POS <= Dynarr_length(). + + #### It is not well worked-out whether and in what circumstances it's + allowed to use a position that is between Dynarr_length() and + Dynarr_largest(). The ideal solution is to never allow this, and require + instead that code first change the length before accessing higher + positions. That would require looking through all the code that accesses + dynarrs and fixing it appropriately (especially redisplay code, and + especially redisplay code in the vicinity of a reference to + Dynarr_largest(), since such code usually checks explicitly to see whether + there is extra stuff between Dynarr_length() and Dynarr_largest().) + + [II] LOCKING + + The idea behind dynarr locking is simple: Locking a dynarr prevents + any modification from occurring, or rather, leads to an abort upon + any attempt to modify a dynarr. + + Dynarr locking was originally added to catch some sporadic and hard-to- + debug crashes in the redisplay code where dynarrs appeared to be getting + corrupted in an unexpected fashion. The solution was to lock the + dynarrs that were getting corrupted (in this case, the display-line + dynarrs) around calls to routines that weren't supposed to be changing + these dynarrs but might somehow be calling code that modified them. + This eventually revealed that there was a reentrancy problem with + redisplay that involved the QUIT mechanism and the processing done in + order to determine whether C-g had been pressed -- this processing + involves retrieving, processing and queueing pending events to see + whether any of them result in a C-g keypress. However, at least under + MS Windows this can result in redisplay being called reentrantly. + For more info:-- + + (Info-goto-node "(internals)Critical Redisplay Sections") + +*/ + +#ifdef ERROR_CHECK_DYNARR +DECLARE_INLINE_HEADER ( +int +Dynarr_verify_pos_at (void *d, Elemcount pos, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + /* We use `largest', not `len', because the redisplay code often + accesses stuff between len and largest. */ + assert_at_line (pos >= 0 && pos < dy->largest_, file, line); + return pos; +} + +DECLARE_INLINE_HEADER ( +int +Dynarr_verify_pos_atp (void *d, Elemcount pos, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + /* We use `largest', not `len', because the redisplay code often + accesses stuff between len and largest. */ + /* [[ Code will often do something like ... + + val = make_bit_vector_from_byte_vector (Dynarr_atp (dyn, 0), + Dynarr_length (dyn)); + + which works fine when the Dynarr_length is non-zero, but when zero, + the result of Dynarr_atp() not only points past the end of the + allocated array, but the array may not have ever been allocated and + hence the return value is NULL. But the length of 0 causes the + pointer to never get checked. These can occur throughout the code + so we put in a special check. --ben ]] + + Update: The common idiom `Dynarr_atp (dyn, 0)' has been changed to + `Dynarr_begin (dyn)'. Possibly this special check at POS 0 can be + done only for Dynarr_begin() not for general Dynarr_atp(). --ben */ + if (pos == 0 && dy->len_ == 0) + return pos; + /* #### It's vaguely possible that some code could legitimately want to + retrieve a pointer to the position just past the end of dynarr memory. + This could happen with Dynarr_atp() but not Dynarr_at(). If so, it + will trigger this assert(). In such cases, it should be obvious that + the code wants to do this; rather than relaxing the assert, we should + probably create a new macro Dynarr_atp_allow_end() which is like + Dynarr_atp() but which allows for pointing at invalid addresses -- we + really want to check for cases of accessing just past the end of + memory, which is a likely off-by-one problem to occur and will usually + not trigger a protection fault (instead, you'll just get random + behavior, possibly overwriting other memory, which is bad). --ben */ + assert_at_line (pos >= 0 && pos < dy->largest_, file, line); + return pos; +} + +DECLARE_INLINE_HEADER ( +int +Dynarr_verify_pos_atp_allow_end (void *d, Elemcount pos, const Ascbyte *file, + int line) +) +{ + Dynarr *dy = (Dynarr *) d; + /* We use `largest', not `len', because the redisplay code often + accesses stuff between len and largest. + We also allow referencing the very end, past the end of allocated + legitimately space. See comments in Dynarr_verify_pos_atp.()*/ + assert_at_line (pos >= 0 && pos <= dy->largest_, file, line); + return pos; +} + +#else +#define Dynarr_verify_pos_at(d, pos, file, line) (pos) +#define Dynarr_verify_pos_atp(d, pos, file, line) (pos) +#define Dynarr_verify_pos_atp_allow_end(d, pos, file, line) (pos) +#endif /* ERROR_CHECK_DYNARR */ + +#ifdef ERROR_CHECK_DYNARR +DECLARE_INLINE_HEADER ( +Dynarr * +Dynarr_verify_1 (void *d, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + assert_at_line (dy->len_ >= 0 && dy->len_ <= dy->largest_ && + dy->largest_ <= dy->max_, file, line); + return dy; +} + +DECLARE_INLINE_HEADER ( +Dynarr * +Dynarr_verify_mod_1 (void *d, const Ascbyte *file, int line) +) +{ + Dynarr *dy = (Dynarr *) d; + assert_at_line (!dy->locked, file, line); + return Dynarr_verify_1 (d, file, line); +} + +#define Dynarr_verify(d) Dynarr_verify_1 (d, __FILE__, __LINE__) +#define Dynarr_verify_mod(d) Dynarr_verify_mod_1 (d, __FILE__, __LINE__) + +DECLARE_INLINE_HEADER ( +void +Dynarr_lock (void *d) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + dy->locked = 1; +} + +DECLARE_INLINE_HEADER ( +void +Dynarr_unlock (void *d) +) +{ + Dynarr *dy = Dynarr_verify (d); + assert (dy->locked); + dy->locked = 0; +} + +#else /* not ERROR_CHECK_DYNARR */ + +#define Dynarr_verify(d) ((Dynarr *) d) +#define Dynarr_verify_mod(d) ((Dynarr *) d) +#define Dynarr_lock(d) DO_NOTHING +#define Dynarr_unlock(d) DO_NOTHING + +#endif /* ERROR_CHECK_DYNARR */ + +/************* Dynarr creation *************/ + +MODULE_API void *Dynarr_newf (Bytecount elsize); +MODULE_API void Dynarr_free (void *d); + +#ifdef NEW_GC +MODULE_API void *Dynarr_lisp_newf (Bytecount elsize, + const struct lrecord_implementation + *dynarr_imp, + const struct lrecord_implementation *imp); + +#define Dynarr_lisp_new(type, dynarr_imp, imp) \ + ((type##_dynarr *) Dynarr_lisp_newf (sizeof (type), dynarr_imp, imp)) +#define Dynarr_lisp_new2(dynarr_type, type, dynarr_imp, imp) \ + ((dynarr_type *) Dynarr_lisp_newf (sizeof (type)), dynarr_imp, imp) +#endif /* NEW_GC */ +#define Dynarr_new(type) ((type##_dynarr *) Dynarr_newf (sizeof (type))) +#define Dynarr_new2(dynarr_type, type) \ + ((dynarr_type *) Dynarr_newf (sizeof (type))) + +/************* Dynarr access *************/ + +#ifdef ERROR_CHECK_DYNARR +#define Dynarr_at(d, pos) \ + ((d)->base[Dynarr_verify_pos_at (d, pos, __FILE__, __LINE__)]) +#define Dynarr_atp_allow_end(d, pos) \ + (&((d)->base[Dynarr_verify_pos_atp_allow_end (d, pos, __FILE__, __LINE__)])) +#define Dynarr_atp(d, pos) \ + (&((d)->base[Dynarr_verify_pos_atp (d, pos, __FILE__, __LINE__)])) +#else +#define Dynarr_at(d, pos) ((d)->base[pos]) +#define Dynarr_atp(d, pos) (&Dynarr_at (d, pos)) +#define Dynarr_atp_allow_end(d, pos) Dynarr_atp (d, pos) +#endif + +/* Old #define Dynarr_atp(d, pos) (&Dynarr_at (d, pos)) */ +#define Dynarr_begin(d) Dynarr_atp (d, 0) +#define Dynarr_lastp(d) Dynarr_atp (d, Dynarr_length (d) - 1) +#define Dynarr_past_lastp(d) Dynarr_atp_allow_end (d, Dynarr_length (d)) + + +/************* Dynarr length/size retrieval and setting *************/ + +/* Retrieve the length of a dynarr. The `+ 0' is to ensure that this cannot + be used as an lvalue. */ +#define Dynarr_length(d) (Dynarr_verify (d)->len_ + 0) +/* Retrieve the largest ever length seen of a dynarr. The `+ 0' is to + ensure that this cannot be used as an lvalue. */ +#define Dynarr_largest(d) (Dynarr_verify (d)->largest_ + 0) +/* Retrieve the number of elements that fit in the currently allocated + space. The `+ 0' is to ensure that this cannot be used as an lvalue. */ +#define Dynarr_max(d) (Dynarr_verify (d)->max_ + 0) +/* Return the size in bytes of an element in a dynarr. */ +#define Dynarr_elsize(d) (Dynarr_verify (d)->elsize_ + 0) +/* Retrieve the advertised memory usage of a dynarr, i.e. the number of + bytes occupied by the elements in the dynarr, not counting any overhead. */ +#define Dynarr_sizeof(d) (Dynarr_length (d) * Dynarr_elsize (d)) + +/* Actually set the length of a dynarr. This is a low-level routine that + should not be directly used; use Dynarr_set_length() or + Dynarr_set_lengthr() instead. */ +DECLARE_INLINE_HEADER ( +void +Dynarr_set_length_1 (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + dynarr_checking_assert (len >= 0 && len <= Dynarr_max (dy)); + /* Use the raw field references here otherwise we get a crash because + we've set the length but not yet fixed up the largest value. */ + dy->len_ = len; + if (dy->len_ > dy->largest_) + dy->largest_ = dy->len_; + (void) Dynarr_verify_mod (d); +} + +/* "Restricted set-length": Set the length of dynarr D to LEN, + which must be in the range [0, Dynarr_largest(d)]. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_set_lengthr (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + dynarr_checking_assert (len >= 0 && len <= Dynarr_largest (dy)); + Dynarr_set_length_1 (dy, len); +} + +/* "Restricted increment": Increment the length of dynarr D by 1; the resulting + length must be in the range [0, Dynarr_largest(d)]. */ + +#define Dynarr_incrementr(d) Dynarr_set_lengthr (d, Dynarr_length (d) + 1) + + +MODULE_API void Dynarr_resize (void *d, Elemcount size); + +DECLARE_INLINE_HEADER ( +void +Dynarr_resize_to_fit (void *d, Elemcount size) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + if (size > Dynarr_max (dy)) + Dynarr_resize (dy, size); +} + +#define Dynarr_resize_to_add(d, numels) \ + Dynarr_resize_to_fit (d, Dynarr_length (d) + numels) + +/* This is an optimization. This is like Dynarr_set_length() but the length + is guaranteed to be at least as big as the existing length. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_increase_length (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + dynarr_checking_assert (len >= Dynarr_length (dy)); + Dynarr_resize_to_fit (dy, len); + Dynarr_set_length_1 (dy, len); +} + +/* Set the length of dynarr D to LEN. If the length increases, resize as + necessary to fit. (NOTE: This will leave uninitialized memory. If you + aren't planning on immediately overwriting the memory, use + Dynarr_set_length_and_zero() to zero out all the memory that would + otherwise be uninitialized.) */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_set_length (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + Elemcount old_len = Dynarr_length (dy); + if (old_len >= len) + Dynarr_set_lengthr (dy, len); + else + Dynarr_increase_length (d, len); +} + +#define Dynarr_increment(d) Dynarr_increase_length (d, Dynarr_length (d) + 1) + +/* Zero LEN contiguous elements starting at POS. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_zero_many (void *d, Elemcount pos, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + memset ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), 0, + len*Dynarr_elsize (dy)); +} + +/* This is an optimization. This is like Dynarr_set_length_and_zero() but + the length is guaranteed to be at least as big as the existing + length. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_increase_length_and_zero (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + Elemcount old_len = Dynarr_length (dy); + Dynarr_increase_length (dy, len); + Dynarr_zero_many (dy, old_len, len - old_len); +} + +/* Set the length of dynarr D to LEN. If the length increases, resize as + necessary to fit and zero out all the elements between the old and new + lengths. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_set_length_and_zero (void *d, Elemcount len) +) +{ + Dynarr *dy = Dynarr_verify_mod (d); + Elemcount old_len = Dynarr_length (dy); + if (old_len >= len) + Dynarr_set_lengthr (dy, len); + else + Dynarr_increase_length_and_zero (d, len); +} + +/* Reset the dynarr's length to 0. */ +#define Dynarr_reset(d) Dynarr_set_lengthr (d, 0) + +#ifdef MEMORY_USAGE_STATS +struct usage_stats; +Bytecount Dynarr_memory_usage (void *d, struct usage_stats *stats); +#endif + +/************* Adding/deleting elements to/from a dynarr *************/ + +/* Set the Lisp implementation of the element at POS in dynarr D. Only + does this if the dynarr holds Lisp objects of a particular type (the + objects themselves, not pointers to them), and only under NEW_GC. */ + +#ifdef NEW_GC +#define DYNARR_SET_LISP_IMP(d, pos) \ +do { \ + if ((d)->lisp_imp) \ + set_lheader_implementation \ + ((struct lrecord_header *)&(((d)->base)[pos]), (d)->lisp_imp); \ +} while (0) +#else +#define DYNARR_SET_LISP_IMP(d, pos) DO_NOTHING +#endif /* (not) NEW_GC */ + +/* Add Element EL to the end of dynarr D. */ + +#define Dynarr_add(d, el) \ +do { \ + Elemcount _da_pos = Dynarr_length (d); \ + (void) Dynarr_verify_mod (d); \ + Dynarr_increment (d); \ + ((d)->base)[_da_pos] = (el); \ + DYNARR_SET_LISP_IMP (d, _da_pos); \ +} while (0) + +/* Set EL as the element at position POS in dynarr D. + Expand the dynarr as necessary so that its length is enough to include + position POS within it, and zero out any new elements created as a + result of expansion, other than the one at POS. */ + +#define Dynarr_set(d, pos, el) \ +do { \ + Elemcount _ds_pos = (pos); \ + (void) Dynarr_verify_mod (d); \ + if (Dynarr_length (d) < _ds_pos + 1) \ + Dynarr_increase_length_and_zero (d, _ds_pos + 1); \ + ((d)->base)[_ds_pos] = (el); \ + DYNARR_SET_LISP_IMP (d, _ds_pos); \ +} while (0) + +/* Add LEN contiguous elements, stored at BASE, to dynarr D. If BASE is + NULL, reserve space but don't store anything. */ + +DECLARE_INLINE_HEADER ( +void +Dynarr_add_many (void *d, const void *base, Elemcount len) +) +{ + /* This duplicates Dynarr_insert_many to some extent; but since it is + called so often, it seemed useful to remove the unnecessary stuff + from that function and to make it inline */ + Dynarr *dy = Dynarr_verify_mod (d); + Elemcount pos = Dynarr_length (dy); + Dynarr_increase_length (dy, Dynarr_length (dy) + len); + if (base) + memcpy ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), base, + len*Dynarr_elsize (dy)); +} + +/* Insert LEN elements, currently pointed to by BASE, into dynarr D + starting at position POS. */ + +MODULE_API void Dynarr_insert_many (void *d, const void *base, Elemcount len, + Elemcount pos); + +/* Prepend LEN elements, currently pointed to by BASE, to the beginning. */ + +#define Dynarr_prepend_many(d, base, len) Dynarr_insert_many (d, base, len, 0) + +/* Add literal string S to dynarr D, which should hold chars or unsigned + chars. The final zero byte is not stored. */ + +#define Dynarr_add_literal_string(d, s) Dynarr_add_many (d, s, sizeof (s) - 1) + +/* Convert Lisp string S to an external encoding according to CODESYS and + add to dynarr D, which should hold chars or unsigned chars. No final + zero byte is appended. */ + +/* #### This should be an inline function but LISP_STRING_TO_SIZED_EXTERNAL + isn't declared yet. */ + +#define Dynarr_add_ext_lisp_string(d, s, codesys) \ +do { \ + Lisp_Object dyna_ls_s = (s); \ + Lisp_Object dyna_ls_cs = (codesys); \ + Extbyte *dyna_ls_eb; \ + Bytecount dyna_ls_bc; \ + \ + LISP_STRING_TO_SIZED_EXTERNAL (dyna_ls_s, dyna_ls_eb, \ + dyna_ls_bc, dyna_ls_cs); \ + Dynarr_add_many (d, dyna_ls_eb, dyna_ls_bc); \ +} while (0) + +/* Delete LEN elements starting at position POS. */ + +MODULE_API void Dynarr_delete_many (void *d, Elemcount pos, Elemcount len); + +/* Pop off (i.e. delete) the last element from the dynarr and return it */ + +#define Dynarr_pop(d) \ + (dynarr_checking_assert (Dynarr_length (d) > 0), \ + Dynarr_verify_mod (d)->len_--, \ + Dynarr_at (d, Dynarr_length (d))) + +/* Delete the item at POS */ + +#define Dynarr_delete(d, pos) Dynarr_delete_many (d, pos, 1) + +/* Delete the item located at memory address P, which must be a `type *' + pointer, where `type' is the type of the elements of the dynarr. */ +#define Dynarr_delete_by_pointer(d, p) \ + Dynarr_delete_many (d, (p) - ((d)->base), 1) + +/* Delete all elements that are numerically equal to EL. */ + +#define Dynarr_delete_object(d, el) \ +do \ +{ \ + REGISTER int i; \ + for (i = Dynarr_length (d) - 1; i >= 0; i--) \ + { \ + if (el == Dynarr_at (d, i)) \ + Dynarr_delete_many (d, i, 1); \ + } \ +} while (0) + + +/************************************************************************/ +/** Stack-like malloc/free **/ +/************************************************************************/ + +void *stack_like_malloc (Bytecount size); +void stack_like_free (void *val); + + + +/************************************************************************/ +/** Gap array **/ +/************************************************************************/ + +/* Holds a marker that moves as elements in the array are inserted and + deleted, similar to standard markers. */ + +typedef struct gap_array_marker +{ +#ifdef NEW_GC + NORMAL_LISP_OBJECT_HEADER header; +#endif /* NEW_GC */ + int pos; + struct gap_array_marker *next; +} Gap_Array_Marker; + + +/* Holds a "gap array", which is an array of elements with a gap located + in it. Insertions and deletions with a high degree of locality + are very fast, essentially in constant time. Array positions as + used and returned in the gap array functions are independent of + the gap. */ + +/* Layout of gap array: + + <------ gap ------><---- gapsize ----><----- numels - gap ----> + <---------------------- numels + gapsize ---------------------> + + For marking purposes, we use two extra variables computed from + the others -- the offset to the data past the gap, plus the number + of elements in that data: + + offset_past_gap = elsize * (gap + gapsize) + els_past_gap = numels - gap +*/ + + +typedef struct gap_array +{ +#ifdef NEW_GC + NORMAL_LISP_OBJECT_HEADER header; + int is_lisp; +#endif /* NEW_GC */ + Elemcount gap; + Elemcount gapsize; + Elemcount numels; + Bytecount elsize; + /* Redundant numbers computed from the others, for marking purposes */ + Bytecount offset_past_gap; + Elemcount els_past_gap; + Gap_Array_Marker *markers; + /* this is a stretchy array */ + char array[1]; +} Gap_Array; + +#ifdef NEW_GC +struct gap_array_marker; + +DECLARE_LISP_OBJECT (gap_array_marker, struct gap_array_marker); +#define XGAP_ARRAY_MARKER(x) \ + XRECORD (x, gap_array_marker, struct gap_array_marker) +#define wrap_gap_array_marker(p) wrap_record (p, gap_array_marker) +#define GAP_ARRAY_MARKERP(x) RECORDP (x, gap_array_marker) +#define CHECK_GAP_ARRAY_MARKER(x) CHECK_RECORD (x, gap_array_marker) +#define CONCHECK_GAP_ARRAY_MARKER(x) CONCHECK_RECORD (x, gap_array_marker) + +struct gap_array; + +DECLARE_LISP_OBJECT (gap_array, struct gap_array); +#define XGAP_ARRAY(x) XRECORD (x, gap_array, struct gap_array) +#define wrap_gap_array(p) wrap_record (p, gap_array) +#define GAP_ARRAYP(x) RECORDP (x, gap_array) +#define CHECK_GAP_ARRAY(x) CHECK_RECORD (x, gap_array) +#define CONCHECK_GAP_ARRAY(x) CONCHECK_RECORD (x, gap_array) +#endif /* NEW_GC */ + +#ifdef NEW_GC +#define XD_GAP_ARRAY_MARKER_DESC \ + { XD_LISP_OBJECT, offsetof (Gap_Array, markers) } +#else /* not NEW_GC */ +#define XD_GAP_ARRAY_MARKER_DESC \ + { XD_BLOCK_PTR, offsetof (Gap_Array, markers), 1, \ + { &gap_array_marker_description }, XD_FLAG_NO_KKCC } +#endif /* not NEW_GC */ + +#define XD_GAP_ARRAY_DESC(sub_desc) \ + { XD_ELEMCOUNT, offsetof (Gap_Array, gap) }, \ + { XD_BYTECOUNT, offsetof (Gap_Array, offset_past_gap) }, \ + { XD_ELEMCOUNT, offsetof (Gap_Array, els_past_gap) }, \ + XD_GAP_ARRAY_MARKER_DESC, \ + { XD_BLOCK_ARRAY, offsetof (Gap_Array, array), XD_INDIRECT (0, 0), \ + { sub_desc } }, \ + { XD_BLOCK_ARRAY, XD_INDIRECT (1, offsetof (Gap_Array, array)), \ + XD_INDIRECT (2, 0), { sub_desc } } + +/* Convert a "memory position" (i.e. taking the gap into account) into + the address of the element at (i.e. after) that position. "Memory + positions" are only used internally and are of type Memxpos. + "Array positions" are used externally and are of type Elemcount. */ +#define GAP_ARRAY_MEMEL_ADDR(ga, memel) ((ga)->array + (ga)->elsize*(memel)) + +/* Number of elements currently in a gap array */ +#define gap_array_length(ga) ((ga)->numels) + +#define gap_array_gappos(ga) ((ga)->gap) +#define gap_array_gapsize(ga) ((ga)->gapsize) + +#define GAP_ARRAY_ARRAY_TO_MEMORY_POS_1(pos, gappos, gapsize) \ + ((pos) < gappos ? (pos) : (pos) + gapsize) + +#define GAP_ARRAY_ARRAY_TO_MEMORY_POS(ga, pos) \ + GAP_ARRAY_ARRAY_TO_MEMORY_POS_1 (pos, (ga)->gap, (ga)->gapsize) + +#define GAP_ARRAY_MEMORY_TO_ARRAY_POS(ga, pos) \ + ((pos) <= (ga)->gap ? (pos) : (pos) - (ga)->gapsize) + +/* Return a pointer to the element at a given position. */ +#define gap_array_atp(ga, pos, type) \ + ((type *) GAP_ARRAY_MEMEL_ADDR (ga, GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos))) + +/* Return the element at a given position. */ +#define gap_array_at(ga, pos, type) (*gap_array_atp (ga, pos, type)) + +/* Return a pointer to the beginning of memory storage for the gap array. + Note this is NOT the same as gap_array_atp(ga, 0, type) because that + will skip forward past the gap if the gap is at position 0. */ +#define gap_array_begin(ga, type) ((type *) ((ga)->array)) + +#ifndef NEW_GC +extern const struct sized_memory_description lispobj_gap_array_description; +extern const struct sized_memory_description gap_array_marker_description; +#endif + +Bytecount gap_array_byte_size (Gap_Array *ga); +Gap_Array *gap_array_insert_els (Gap_Array *ga, Elemcount pos, void *elptr, + Elemcount numels); +void gap_array_delete_els (Gap_Array *ga, Elemcount from, Elemcount numdel); +#define gap_array_delete_all_els(ga) \ + gap_array_delete_els (ga, 0, gap_array_length (ga)) +Gap_Array_Marker *gap_array_make_marker (Gap_Array *ga, Elemcount pos); +void gap_array_delete_marker (Gap_Array *ga, Gap_Array_Marker *m); +void gap_array_delete_all_markers (Gap_Array *ga); +void gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, Elemcount pos); +#define gap_array_marker_pos(ga, m) \ + GAP_ARRAY_MEMORY_TO_ARRAY_POS (ga, (m)->pos) +Gap_Array *make_gap_array (Elemcount elsize, int USED_IF_NEW_GC (do_lisp)); +Gap_Array *gap_array_clone (Gap_Array *ga); +void free_gap_array (Gap_Array *ga); +Bytecount gap_array_memory_usage (Gap_Array *ga, struct usage_stats *stats, + Bytecount *marker_ancillary); + +#endif /* INCLUDED_array_h_ */
--- a/src/buffer.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/buffer.c Mon Mar 29 21:28:13 2010 -0500 @@ -234,11 +234,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("buffer-text", buffer_text, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - buffer_text_description_1, - Lisp_Buffer_Text); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("buffer-text", buffer_text, + 0, buffer_text_description_1, + Lisp_Buffer_Text); #endif /* NEW_GC */ static const struct sized_memory_description buffer_text_description = { @@ -304,9 +302,9 @@ if (print_readably) { if (!BUFFER_LIVE_P (b)) - printing_unreadable_object ("#<killed buffer>"); + printing_unreadable_object_fmt ("#<killed buffer>"); else - printing_unreadable_object ("#<buffer %s>", XSTRING_DATA (b->name)); + printing_unreadable_object_fmt ("#<buffer %s>", XSTRING_DATA (b->name)); } else if (!BUFFER_LIVE_P (b)) write_ascstring (printcharfun, "#<killed buffer>"); @@ -333,11 +331,10 @@ /* We do not need a finalize method to handle a buffer's children list because all buffers have `kill-buffer' applied to them before they disappear, and the children removal happens then. */ -DEFINE_LRECORD_IMPLEMENTATION ("buffer", buffer, - 0, /*dumpable-flag*/ - mark_buffer, print_buffer, 0, 0, 0, - buffer_description, - struct buffer); +DEFINE_NODUMP_LISP_OBJECT ("buffer", buffer, mark_buffer, + print_buffer, 0, 0, 0, + buffer_description, + struct buffer); DEFUN ("bufferp", Fbufferp, 1, 1, 0, /* Return t if OBJECT is an editor buffer. @@ -603,11 +600,11 @@ static struct buffer * allocate_buffer (void) { - struct buffer *b = ALLOC_LCRECORD_TYPE (struct buffer, &lrecord_buffer); - - COPY_LCRECORD (b, XBUFFER (Vbuffer_defaults)); - - return b; + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (buffer); + + copy_lisp_object (obj, Vbuffer_defaults); + + return XBUFFER (obj); } static Lisp_Object @@ -1755,76 +1752,52 @@ struct buffer_stats { - int text; - int markers; - int extents; - int other; + struct usage_stats u; + Bytecount text; + /* Ancillary Lisp */ + Bytecount markers; + Bytecount extents; }; static Bytecount -compute_buffer_text_usage (struct buffer *b, struct overhead_stats *ovstats) +compute_buffer_text_usage (struct buffer *b, struct usage_stats *ustats) { - int was_requested = b->text->z - 1; - Bytecount gap = b->text->gap_size + b->text->end_gap_size; - Bytecount malloc_use = malloced_storage_size (b->text->beg, was_requested + gap, 0); - - ovstats->gap_overhead += gap; - ovstats->was_requested += was_requested; - ovstats->malloc_overhead += malloc_use - (was_requested + gap); + Bytecount was_requested, gap, malloc_use; + + /* Killed buffer? */ + if (!b->text) + return 0; + + /* Indirect buffer shares its text with someone else, so don't double- + count the text */ + if (b->base_buffer) + return 0; + + was_requested = b->text->z - 1; + gap = b->text->gap_size + b->text->end_gap_size; + malloc_use = malloced_storage_size (b->text->beg, was_requested + gap, 0); + + ustats->gap_overhead += gap; + ustats->was_requested += was_requested; + ustats->malloc_overhead += malloc_use - (was_requested + gap); return malloc_use; } static void compute_buffer_usage (struct buffer *b, struct buffer_stats *stats, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { - xzero (*stats); - stats->other += LISPOBJ_STORAGE_SIZE (b, sizeof (*b), ovstats); - stats->text += compute_buffer_text_usage (b, ovstats); - stats->markers += compute_buffer_marker_usage (b, ovstats); - stats->extents += compute_buffer_extent_usage (b, ovstats); + stats->text += compute_buffer_text_usage (b, ustats); + stats->markers += compute_buffer_marker_usage (b); + stats->extents += compute_buffer_extent_usage (b); } -DEFUN ("buffer-memory-usage", Fbuffer_memory_usage, 1, 1, 0, /* -Return stats about the memory usage of buffer BUFFER. -The values returned are in the form of an alist of usage types and byte -counts. The byte counts attempt to encompass all the memory used -by the buffer (separate from the memory logically associated with a -buffer or frame), including internal structures and any malloc() -overhead associated with them. In practice, the byte counts are -underestimated because certain memory usage is very hard to determine -\(e.g. the amount of memory used inside the Xt library or inside the -X server) and because there is other stuff that might logically -be associated with a window, buffer, or frame (e.g. window configurations, -glyphs) but should not obviously be included in the usage counts. - -Multiple slices of the total memory usage may be returned, separated -by a nil. Each slice represents a particular view of the memory, a -particular way of partitioning it into groups. Within a slice, there -is no overlap between the groups of memory, and each slice collectively -represents all the memory concerned. -*/ - (buffer)) +static void +buffer_memory_usage (Lisp_Object buffer, struct generic_usage_stats *gustats) { - struct buffer_stats stats; - struct overhead_stats ovstats; - Lisp_Object val = Qnil; - - CHECK_BUFFER (buffer); /* dead buffers should be allowed, no? */ - xzero (ovstats); - compute_buffer_usage (XBUFFER (buffer), &stats, &ovstats); - - val = acons (Qtext, make_int (stats.text), val); - val = acons (Qmarkers, make_int (stats.markers), val); - val = acons (Qextents, make_int (stats.extents), val); - val = acons (Qother, make_int (stats.other), val); - val = Fcons (Qnil, val); - val = acons (Qactually_requested, make_int (ovstats.was_requested), val); - val = acons (Qmalloc_overhead, make_int (ovstats.malloc_overhead), val); - val = acons (Qgap_overhead, make_int (ovstats.gap_overhead), val); - val = acons (Qdynarr_overhead, make_int (ovstats.dynarr_overhead), val); - - return Fnreverse (val); + struct buffer_stats *stats = (struct buffer_stats *) gustats; + + compute_buffer_usage (XBUFFER (buffer), stats, &stats->u); } #endif /* MEMORY_USAGE_STATS */ @@ -1908,11 +1881,19 @@ void +buffer_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (buffer, memory_usage); +#endif +} + +void syms_of_buffer (void) { - INIT_LRECORD_IMPLEMENTATION (buffer); + INIT_LISP_OBJECT (buffer); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (buffer_text); + INIT_LISP_OBJECT (buffer_text); #endif /* NEW_GC */ DEFSYMBOL (Qbuffer_live_p); @@ -1972,9 +1953,6 @@ DEFSUBR (Fbarf_if_buffer_read_only); DEFSUBR (Fbury_buffer); DEFSUBR (Fkill_all_local_variables); -#ifdef MEMORY_USAGE_STATS - DEFSUBR (Fbuffer_memory_usage); -#endif #if defined (DEBUG_XEMACS) && defined (MULE) DEFSUBR (Fbuffer_char_byte_converion_info); DEFSUBR (Fstring_char_byte_converion_info); @@ -1997,6 +1975,11 @@ vars_of_buffer (void) { /* This function can GC */ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY + (buffer, memusage_stats_list, list4 (Qtext, Qt, Qmarkers, Qextents)); +#endif /* MEMORY_USAGE_STATS */ + staticpro (&QSFundamental); staticpro (&QSscratch); @@ -2143,9 +2126,8 @@ do \ { \ struct symbol_value_forward *I_hate_C = \ - alloc_lrecord_type (struct symbol_value_forward, \ - &lrecord_symbol_value_forward); \ - /*mcpro ((Lisp_Object) I_hate_C);*/ \ + XSYMBOL_VALUE_FORWARD (ALLOC_NORMAL_LISP_OBJECT (symbol_value_forward)); \ + /*mcpro ((Lisp_Object) I_hate_C);*/ \ \ I_hate_C->magic.value = &(buffer_local_flags.field_name); \ I_hate_C->magic.type = forward_type; \ @@ -2179,8 +2161,6 @@ 1 /* lisp_readonly bit */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ &(buffer_local_flags.field_name), \ forward_type \ @@ -2219,7 +2199,7 @@ static void nuke_all_buffer_slots (struct buffer *b, Lisp_Object zap) { - ZERO_LCRECORD (b); + zero_nonsized_lisp_object (wrap_buffer (b)); b->extent_info = Qnil; b->indirect_children = Qnil; @@ -2234,13 +2214,15 @@ { /* Make sure all markable slots in buffer_defaults are initialized reasonably, so mark_buffer won't choke. */ - struct buffer *defs = ALLOC_LCRECORD_TYPE (struct buffer, &lrecord_buffer); - struct buffer *syms = ALLOC_LCRECORD_TYPE (struct buffer, &lrecord_buffer); + Lisp_Object defobj = ALLOC_NORMAL_LISP_OBJECT (buffer); + struct buffer *defs = XBUFFER (defobj); + Lisp_Object symobj = ALLOC_NORMAL_LISP_OBJECT (buffer); + struct buffer *syms = XBUFFER (symobj); staticpro_nodump (&Vbuffer_defaults); staticpro_nodump (&Vbuffer_local_symbols); - Vbuffer_defaults = wrap_buffer (defs); - Vbuffer_local_symbols = wrap_buffer (syms); + Vbuffer_defaults = defobj; + Vbuffer_local_symbols = symobj; nuke_all_buffer_slots (syms, Qnil); nuke_all_buffer_slots (defs, Qnil); @@ -2297,6 +2279,8 @@ The local flag bits are in the local_var_flags slot of the buffer. */ + set_lheader_implementation ((struct lrecord_header *) + &buffer_local_flags, &lrecord_buffer); nuke_all_buffer_slots (&buffer_local_flags, make_int (-2)); buffer_local_flags.filename = always_local_no_default; buffer_local_flags.directory = always_local_no_default;
--- a/src/buffer.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/buffer.h Mon Mar 29 21:28:13 2010 -0500 @@ -80,7 +80,7 @@ struct buffer_text { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Ibyte *beg; /* Actual address of buffer contents. */ Bytebpos gpt; /* Index of gap in buffer. */ @@ -144,7 +144,7 @@ #ifdef NEW_GC typedef struct buffer_text Lisp_Buffer_Text; -DECLARE_LRECORD (buffer_text, Lisp_Buffer_Text); +DECLARE_LISP_OBJECT (buffer_text, Lisp_Buffer_Text); #define XBUFFER_TEXT(x) \ XRECORD (x, buffer_text, Lisp_Buffer_Text) @@ -157,7 +157,7 @@ struct buffer { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* This structure holds the coordinates of the buffer contents in ordinary buffers. In indirect buffers, this is not used. */ @@ -268,7 +268,7 @@ #undef MARKED_SLOT }; -DECLARE_LRECORD (buffer, struct buffer); +DECLARE_LISP_OBJECT (buffer, struct buffer); #define XBUFFER(x) XRECORD (x, buffer, struct buffer) #define wrap_buffer(p) wrap_record (p, buffer) #define BUFFERP(x) RECORDP (x, buffer)
--- a/src/bytecode-ops.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/bytecode-ops.h Mon Mar 29 21:28:13 2010 -0500 @@ -57,7 +57,7 @@ OPCODE (set, 0114) OPCODE (fset, 0115) OPCODE (get, 0116) - OPCODE (substring, 0117) + OPCODE (subseq, 0117) OPCODE (concat2, 0120) OPCODE (concat3, 0121) OPCODE (concat4, 0122)
--- a/src/bytecode.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/bytecode.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Execution of byte code produced by bytecomp.el. Implementation of compiled-function objects. Copyright (C) 1992, 1993 Free Software Foundation, Inc. - Copyright (C) 1995, 2002 Ben Wing. + Copyright (C) 1995, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -65,22 +65,21 @@ make_compiled_function_args (int totalargs) { Lisp_Compiled_Function_Args *args; - args = (Lisp_Compiled_Function_Args *) - alloc_lrecord - (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, - Lisp_Object, args, totalargs), - &lrecord_compiled_function_args); + args = XCOMPILED_FUNCTION_ARGS + (ALLOC_SIZED_LISP_OBJECT + (FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, + Lisp_Object, args, totalargs), + compiled_function_args)); args->size = totalargs; return wrap_compiled_function_args (args); } static Bytecount -size_compiled_function_args (const void *lheader) +size_compiled_function_args (Lisp_Object obj) { return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Compiled_Function_Args, Lisp_Object, args, - ((Lisp_Compiled_Function_Args *) - lheader)->size); + XCOMPILED_FUNCTION_ARGS (obj)->size); } static const struct memory_description compiled_function_args_description[] = { @@ -90,13 +89,12 @@ { XD_END } }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("compiled-function-args", - compiled_function_args, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - compiled_function_args_description, - size_compiled_function_args, - Lisp_Compiled_Function_Args); +DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT ("compiled-function-args", + compiled_function_args, + 0, + compiled_function_args_description, + size_compiled_function_args, + Lisp_Compiled_Function_Args); #endif /* NEW_GC */ EXFUN (Ffetch_bytecode, 1); @@ -1573,11 +1571,11 @@ break; } - case Bsubstring: + case Bsubseq: { Lisp_Object arg2 = POP; Lisp_Object arg1 = POP; - TOP_LVALUE = Fsubstring (TOP, arg1, arg2); + TOP_LVALUE = Fsubseq (TOP, arg1, arg2); break; } @@ -2247,7 +2245,8 @@ struct gcpro gcpro1, gcpro2; GCPRO2 (obj, printcharfun); - write_ascstring (printcharfun, print_readably ? "#[" : "#<compiled-function "); + write_ascstring (printcharfun, print_readably ? "#[" : + "#<compiled-function "); #ifdef COMPILED_FUNCTION_ANNOTATION_HACK if (!print_readably) { @@ -2300,7 +2299,10 @@ } UNGCPRO; - write_ascstring (printcharfun, print_readably ? "]" : ">"); + if (print_readably) + write_ascstring (printcharfun, "]"); + else + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } @@ -2374,14 +2376,13 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("compiled-function", compiled_function, - 1, /*dumpable_flag*/ - mark_compiled_function, - print_compiled_function, 0, - compiled_function_equal, - compiled_function_hash, - compiled_function_description, - Lisp_Compiled_Function); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("compiled-function", compiled_function, + mark_compiled_function, + print_compiled_function, 0, + compiled_function_equal, + compiled_function_hash, + compiled_function_description, + Lisp_Compiled_Function); DEFUN ("compiled-function-p", Fcompiled_function_p, 1, 1, 0, /* @@ -2756,9 +2757,9 @@ void syms_of_bytecode (void) { - INIT_LRECORD_IMPLEMENTATION (compiled_function); + INIT_LISP_OBJECT (compiled_function); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (compiled_function_args); + INIT_LISP_OBJECT (compiled_function_args); #endif /* NEW_GC */ DEFERROR_STANDARD (Qinvalid_byte_code, Qinvalid_state); @@ -2823,14 +2824,14 @@ static void init_opcode_table_multi_op (Opcode op) { - const Ascbyte *basename = opcode_name_table[op]; + const Ascbyte *base = opcode_name_table[op]; Ascbyte temp[300]; int i; for (i = 1; i < 7; i++) { assert (!opcode_name_table[op + i]); - sprintf (temp, "%s+%d", basename, i); + sprintf (temp, "%s+%d", base, i); opcode_name_table[op + i] = xstrdup (temp); } }
--- a/src/bytecode.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/bytecode.h Mon Mar 29 21:28:13 2010 -0500 @@ -34,14 +34,14 @@ #ifdef NEW_GC struct compiled_function_args { - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; long size; Lisp_Object args[1]; }; typedef struct compiled_function_args Lisp_Compiled_Function_Args; -DECLARE_LRECORD (compiled_function_args, Lisp_Compiled_Function_Args); +DECLARE_LISP_OBJECT (compiled_function_args, Lisp_Compiled_Function_Args); #define XCOMPILED_FUNCTION_ARGS(x) \ XRECORD (x, compiled_function_args, Lisp_Compiled_Function_Args) @@ -83,7 +83,7 @@ struct Lisp_Compiled_Function { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; unsigned short stack_depth; unsigned short specpdl_depth; struct @@ -148,7 +148,7 @@ int stack_depth, Lisp_Object *constants_data); -DECLARE_LRECORD (compiled_function, Lisp_Compiled_Function); +DECLARE_LISP_OBJECT (compiled_function, Lisp_Compiled_Function); #define XCOMPILED_FUNCTION(x) XRECORD (x, compiled_function, \ Lisp_Compiled_Function) #define wrap_compiled_function(p) wrap_record (p, compiled_function)
--- a/src/casetab.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/casetab.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* XEmacs routines to deal with case tables. Copyright (C) 1987, 1992, 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2002 Ben Wing. + Copyright (C) 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -105,12 +105,12 @@ { Lisp_Case_Table *ct = XCASE_TABLE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<case-table downcase=%s upcase=%s canon=%s eqv=%s ", 4, CASE_TABLE_DOWNCASE (ct), CASE_TABLE_UPCASE (ct), CASE_TABLE_CANON (ct), CASE_TABLE_EQV (ct)); - write_fmt_string (printcharfun, "0x%x>", ct->header.uid); + write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj)); } static const struct memory_description case_table_description [] = { @@ -122,16 +122,15 @@ }; -DEFINE_LRECORD_IMPLEMENTATION("case-table", case_table, - 1, /*dumpable-flag*/ - mark_case_table, print_case_table, 0, - 0, 0, case_table_description, Lisp_Case_Table); +DEFINE_DUMPABLE_LISP_OBJECT ("case-table", case_table, + mark_case_table, print_case_table, 0, + 0, 0, case_table_description, Lisp_Case_Table); static Lisp_Object allocate_case_table (int init_tables) { - Lisp_Case_Table *ct = - ALLOC_LCRECORD_TYPE (Lisp_Case_Table, &lrecord_case_table); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (case_table); + Lisp_Case_Table *ct = XCASE_TABLE (obj); if (init_tables) { @@ -147,7 +146,7 @@ SET_CASE_TABLE_CANON (ct, Qnil); SET_CASE_TABLE_EQV (ct, Qnil); } - return wrap_case_table (ct); + return obj; } DEFUN ("make-case-table", Fmake_case_table, 0, 0, 0, /* @@ -509,10 +508,42 @@ } +#ifdef MEMORY_USAGE_STATS + +struct case_table_stats +{ + struct usage_stats u; + /* Ancillary Lisp */ + Bytecount downcase, upcase, case_canon, case_eqv; +}; + +static void +case_table_memory_usage (Lisp_Object casetab, + struct generic_usage_stats *gustats) +{ + struct case_table_stats *stats = (struct case_table_stats *) gustats; + + stats->downcase = lisp_object_memory_usage (XCASE_TABLE_DOWNCASE (casetab)); + stats->upcase = lisp_object_memory_usage (XCASE_TABLE_UPCASE (casetab)); + stats->case_canon = lisp_object_memory_usage (XCASE_TABLE_CANON (casetab)); + stats->case_eqv = lisp_object_memory_usage (XCASE_TABLE_EQV (casetab)); +} + +#endif /* MEMORY_USAGE_STATS */ + + +void +casetab_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (case_table, memory_usage); +#endif +} + void syms_of_casetab (void) { - INIT_LRECORD_IMPLEMENTATION (case_table); + INIT_LISP_OBJECT (case_table); DEFSYMBOL_MULTIWORD_PREDICATE (Qcase_tablep); DEFSYMBOL (Qdowncase); @@ -531,6 +562,19 @@ } void +vars_of_casetab (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY (case_table, memusage_stats_list, + list5 (Qt, + intern ("downcase"), + intern ("upcase"), + intern ("case-canon"), + intern ("case-eqv"))); +#endif /* MEMORY_USAGE_STATS */ +} + +void complex_vars_of_casetab (void) { REGISTER Ichar i;
--- a/src/casetab.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/casetab.h Mon Mar 29 21:28:13 2010 -0500 @@ -25,7 +25,7 @@ struct Lisp_Case_Table { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object downcase_table; Lisp_Object upcase_table; Lisp_Object case_canon_table; @@ -34,7 +34,7 @@ }; typedef struct Lisp_Case_Table Lisp_Case_Table; -DECLARE_LRECORD (case_table, Lisp_Case_Table); +DECLARE_LISP_OBJECT (case_table, Lisp_Case_Table); #define XCASE_TABLE(x) XRECORD (x, case_table, Lisp_Case_Table) #define wrap_case_table(p) wrap_record (p, case_table) #define CASE_TABLEP(x) RECORDP (x, case_table)
--- a/src/charset.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/charset.h Mon Mar 29 21:28:13 2010 -0500 @@ -185,7 +185,7 @@ struct Lisp_Charset { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; int id; Lisp_Object name; @@ -246,7 +246,7 @@ }; typedef struct Lisp_Charset Lisp_Charset; -DECLARE_LRECORD (charset, Lisp_Charset); +DECLARE_LISP_OBJECT (charset, Lisp_Charset); #define XCHARSET(x) XRECORD (x, charset, Lisp_Charset) #define wrap_charset(p) wrap_record (p, charset) #define CHARSETP(x) RECORDP (x, charset)
--- a/src/chartab.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/chartab.c Mon Mar 29 21:28:13 2010 -0500 @@ -140,13 +140,12 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("char-table-entry", char_table_entry, - 1, /* dumpable flag */ - mark_char_table_entry, internal_object_printer, - 0, char_table_entry_equal, - char_table_entry_hash, - char_table_entry_description, - Lisp_Char_Table_Entry); +DEFINE_DUMPABLE_LISP_OBJECT ("char-table-entry", char_table_entry, + mark_char_table_entry, internal_object_printer, + 0, char_table_entry_equal, + char_table_entry_hash, + char_table_entry_description, + Lisp_Char_Table_Entry); #endif /* MULE */ @@ -395,12 +394,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("char-table", char_table, - 1, /*dumpable-flag*/ - mark_char_table, print_char_table, 0, - char_table_equal, char_table_hash, - char_table_description, - Lisp_Char_Table); +DEFINE_DUMPABLE_LISP_OBJECT ("char-table", char_table, + mark_char_table, print_char_table, 0, + char_table_equal, char_table_hash, + char_table_description, + Lisp_Char_Table); DEFUN ("char-table-p", Fchar_table_p, 1, 1, 0, /* Return non-nil if OBJECT is a char table. @@ -479,7 +477,7 @@ if (!EQ (ct->level1[i], Qnull_pointer) && CHAR_TABLE_ENTRYP (ct->level1[i]) && !OBJECT_DUMPED_P (ct->level1[1])) - FREE_LCRECORD (ct->level1[i]); + free_normal_lisp_object (ct->level1[i]); ct->level1[i] = value; } #endif /* MULE */ @@ -598,13 +596,11 @@ */ (type)) { - Lisp_Char_Table *ct; - Lisp_Object obj; + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table); + Lisp_Char_Table *ct = XCHAR_TABLE (obj); enum char_table_type ty = symbol_to_char_table_type (type); - ct = ALLOC_LCRECORD_TYPE (Lisp_Char_Table, &lrecord_char_table); ct->type = ty; - obj = wrap_char_table (ct); if (ty == CHAR_TABLE_TYPE_SYNTAX) { /* Qgeneric not Qsyntax because a syntax table has a mirror table @@ -634,13 +630,13 @@ make_char_table_entry (Lisp_Object initval) { int i; - Lisp_Char_Table_Entry *cte = - ALLOC_LCRECORD_TYPE (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table_entry); + Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (obj); for (i = 0; i < 96; i++) cte->level2[i] = initval; - return wrap_char_table_entry (cte); + return obj; } static Lisp_Object @@ -648,8 +644,8 @@ { Lisp_Char_Table_Entry *cte = XCHAR_TABLE_ENTRY (entry); int i; - Lisp_Char_Table_Entry *ctenew = - ALLOC_LCRECORD_TYPE (Lisp_Char_Table_Entry, &lrecord_char_table_entry); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (char_table_entry); + Lisp_Char_Table_Entry *ctenew = XCHAR_TABLE_ENTRY (obj); for (i = 0; i < 96; i++) { @@ -660,7 +656,7 @@ ctenew->level2[i] = new_; } - return wrap_char_table_entry (ctenew); + return obj; } #endif /* MULE */ @@ -679,12 +675,12 @@ CHECK_CHAR_TABLE (char_table); ct = XCHAR_TABLE (char_table); assert(!ct->mirror_table_p); - ctnew = ALLOC_LCRECORD_TYPE (Lisp_Char_Table, &lrecord_char_table); + obj = ALLOC_NORMAL_LISP_OBJECT (char_table); + ctnew = XCHAR_TABLE (obj); ctnew->type = ct->type; ctnew->parent = ct->parent; ctnew->default_ = ct->default_; ctnew->mirror_table_p = 0; - obj = wrap_char_table (ctnew); for (i = 0; i < NUM_ASCII_CHARS; i++) { @@ -1075,7 +1071,7 @@ int lb = XCHARSET_LEADING_BYTE (range->charset) - MIN_LEADING_BYTE; if (CHAR_TABLE_ENTRYP (ct->level1[lb]) && !OBJECT_DUMPED_P (ct->level1[lb])) - FREE_LCRECORD (ct->level1[lb]); + free_normal_lisp_object (ct->level1[lb]); ct->level1[lb] = val; } break; @@ -1832,10 +1828,10 @@ void syms_of_chartab (void) { - INIT_LRECORD_IMPLEMENTATION (char_table); + INIT_LISP_OBJECT (char_table); #ifdef MULE - INIT_LRECORD_IMPLEMENTATION (char_table_entry); + INIT_LISP_OBJECT (char_table_entry); DEFSYMBOL (Qcategory_table_p); DEFSYMBOL (Qcategory_designator_p);
--- a/src/chartab.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/chartab.h Mon Mar 29 21:28:13 2010 -0500 @@ -42,7 +42,7 @@ struct Lisp_Char_Table_Entry { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* In the interests of simplicity, we just use a fixed 96-entry table. If we felt like being smarter, we could make this @@ -51,7 +51,7 @@ }; typedef struct Lisp_Char_Table_Entry Lisp_Char_Table_Entry; -DECLARE_LRECORD (char_table_entry, Lisp_Char_Table_Entry); +DECLARE_LISP_OBJECT (char_table_entry, Lisp_Char_Table_Entry); #define XCHAR_TABLE_ENTRY(x) \ XRECORD (x, char_table_entry, Lisp_Char_Table_Entry) #define wrap_char_table_entry(p) wrap_record (p, char_table_entry) @@ -80,7 +80,7 @@ struct Lisp_Char_Table { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object ascii[NUM_ASCII_CHARS]; Lisp_Object default_; @@ -128,7 +128,7 @@ }; typedef struct Lisp_Char_Table Lisp_Char_Table; -DECLARE_LRECORD (char_table, Lisp_Char_Table); +DECLARE_LISP_OBJECT (char_table, Lisp_Char_Table); #define XCHAR_TABLE(x) XRECORD (x, char_table, Lisp_Char_Table) #define wrap_char_table(p) wrap_record (p, char_table) #define CHAR_TABLEP(x) RECORDP (x, char_table)
--- a/src/console-gtk-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-gtk-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -50,7 +50,7 @@ struct gtk_device { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* Gtk application info. */ GtkWidget *gtk_app_shell; @@ -115,7 +115,7 @@ #ifdef NEW_GC typedef struct gtk_device Lisp_Gtk_Device; -DECLARE_LRECORD (gtk_device, Lisp_Gtk_Device); +DECLARE_LISP_OBJECT (gtk_device, Lisp_Gtk_Device); #define XGTK_DEVICE(x) \ XRECORD (x, gtk_device, Lisp_Gtk_Device) @@ -144,7 +144,7 @@ struct gtk_frame { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* The widget of this frame. */ @@ -159,6 +159,11 @@ /* The widget of the edit portion of this frame; this is a GtkDrawingArea, and the window of this widget is what the redisplay code draws on. */ GtkWidget *edit_widget; + /* #### WARNING: this does not currently work. -- dvl + Position of the edit widget above, for absolute background placement. + + int x, y; + */ /* Lists the widgets above the text area, in the proper order. */ GtkWidget *top_widgets[MAX_CONCURRENT_TOP_WIDGETS]; @@ -203,7 +208,7 @@ #ifdef NEW_GC typedef struct gtk_frame Lisp_Gtk_Frame; -DECLARE_LRECORD (gtk_frame, Lisp_Gtk_Frame); +DECLARE_LISP_OBJECT (gtk_frame, Lisp_Gtk_Frame); #define XGTK_FRAME(x) \ XRECORD (x, gtk_frame, Lisp_Gtk_Frame) @@ -213,6 +218,10 @@ #define FRAME_GTK_DATA(f) FRAME_TYPE_DATA (f, gtk) +/* #### WARNING: this does not currently work. -- dvl + #define FRAME_GTK_X(f) (FRAME_GTK_DATA (f)->x) + #define FRAME_GTK_Y(f) (FRAME_GTK_DATA (f)->y) +*/ #define FRAME_GTK_SHELL_WIDGET(f) (FRAME_GTK_DATA (f)->widget) #define FRAME_GTK_CONTAINER_WIDGET(f) (FRAME_GTK_DATA (f)->container) #define FRAME_GTK_MENUBAR_WIDGET(f) (FRAME_GTK_DATA (f)->menubar_widget)
--- a/src/console-gtk.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-gtk.h Mon Mar 29 21:28:13 2010 -0500 @@ -64,7 +64,8 @@ int start_pixpos, int width, face_index findex, int cursor, int cursor_start, int cursor_width, int cursor_height); -GdkGC *gtk_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, Lisp_Object bg, +GdkGC *gtk_get_gc (struct frame *f, + Lisp_Object font, Lisp_Object fg, Lisp_Object bg, Lisp_Object bg_pmap, Lisp_Object lwidth); int gtk_initialize_frame_menubar (struct frame *f);
--- a/src/console-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,5 @@ /* Define console object for XEmacs. - Copyright (C) 1996, 2002, 2003, 2005 Ben Wing + Copyright (C) 1996, 2002, 2003, 2005, 2010 Ben Wing This file is part of XEmacs. @@ -153,9 +153,10 @@ int (*eol_cursor_width_method) (void); void (*output_vertical_divider_method) (struct window *, int); void (*clear_to_window_end_method) (struct window *, int, int); - void (*clear_region_method) (Lisp_Object, struct device*, struct frame*, face_index, - int, int, int, int, - Lisp_Object, Lisp_Object, Lisp_Object); + void (*clear_region_method) (Lisp_Object, struct device*, struct frame*, + face_index, int, int, int, int, + Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object); void (*clear_frame_method) (struct frame *); void (*window_output_begin_method) (struct window *); void (*frame_output_begin_method) (struct frame *); @@ -289,9 +290,10 @@ scrollbar_instance *); void (*scrollbar_pointer_changed_in_window_method) (struct window *w); #ifdef MEMORY_USAGE_STATS - int (*compute_scrollbar_instance_usage_method) (struct device *, - struct scrollbar_instance *, - struct overhead_stats *); + Bytecount (*compute_scrollbar_instance_usage_method) + (struct device *, + struct scrollbar_instance *, + struct usage_stats *); #endif /* Paint the window's deadbox, a rectangle between window borders and two short edges of both scrollbars. */ @@ -409,7 +411,7 @@ struct console { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Description of this console's methods. */ struct console_methods *conmeths; @@ -453,7 +455,11 @@ /* Redefine basic properties more efficiently */ #undef CONSOLE_LIVE_P -#define CONSOLE_LIVE_P(con) (!EQ (CONSOLE_TYPE (con), Qdead)) +/* The following is the old way, but it can lead to crashes in certain + weird circumstances, where you might want to be printing a console via + debug_print() */ +/* #define CONSOLE_LIVE_P(con) (!EQ (CONSOLE_TYPE (con), Qdead)) */ +#define CONSOLE_LIVE_P(con) ((con)->contype != dead_console) #undef CONSOLE_DEVICE_LIST #define CONSOLE_DEVICE_LIST(con) ((con)->device_list)
--- a/src/console-msw-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-msw-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -57,7 +57,7 @@ struct Lisp_Devmode { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Pointer to the DEVMODE structure */ DEVMODEW *devmode; @@ -82,7 +82,7 @@ struct mswindows_device { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Lisp_Object fontlist; /* List of (STRING . FIXED-P), device fonts */ HDC hcdc; /* Compatible DC */ @@ -94,7 +94,7 @@ #ifdef NEW_GC typedef struct mswindows_device Lisp_Mswindows_Device; -DECLARE_LRECORD (mswindows_device, Lisp_Mswindows_Device); +DECLARE_LISP_OBJECT (mswindows_device, Lisp_Mswindows_Device); #define XMSWINDOWS_DEVICE(x) \ XRECORD (x, mswindows_device, Lisp_Mswindows_Device) @@ -110,7 +110,7 @@ struct msprinter_device { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ HDC hdc, hcdc; /* Printer and the comp. DCs */ HANDLE hprinter; @@ -122,7 +122,7 @@ #ifdef NEW_GC typedef struct msprinter_device Lisp_Msprinter_Device; -DECLARE_LRECORD (msprinter_device, Lisp_Msprinter_Device); +DECLARE_LISP_OBJECT (msprinter_device, Lisp_Msprinter_Device); #define XMSPRINTER_DEVICE(x) \ XRECORD (x, msprinter_device, Lisp_Msprinter_Device) @@ -168,7 +168,7 @@ struct mswindows_frame { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* win32 window handle */ @@ -230,7 +230,7 @@ #ifdef NEW_GC typedef struct mswindows_frame Lisp_Mswindows_Frame; -DECLARE_LRECORD (mswindows_frame, Lisp_Mswindows_Frame); +DECLARE_LISP_OBJECT (mswindows_frame, Lisp_Mswindows_Frame); #define XMSWINDOWS_FRAME(x) \ XRECORD (x, mswindows_frame, Lisp_Mswindows_Frame) @@ -312,7 +312,7 @@ struct mswindows_dialog_id { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object frame; Lisp_Object callbacks;
--- a/src/console-msw.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-msw.h Mon Mar 29 21:28:13 2010 -0500 @@ -57,7 +57,7 @@ typedef struct Lisp_Devmode Lisp_Devmode; -DECLARE_LRECORD (devmode, Lisp_Devmode); +DECLARE_LISP_OBJECT (devmode, Lisp_Devmode); #define XDEVMODE(x) XRECORD (x, devmode, Lisp_Devmode) #define wrap_devmode(p) wrap_record (p, devmode) #define DEVMODEP(x) RECORDP (x, devmode) @@ -210,7 +210,7 @@ struct mswindows_dialog_id; -DECLARE_LRECORD (mswindows_dialog_id, struct mswindows_dialog_id); +DECLARE_LISP_OBJECT (mswindows_dialog_id, struct mswindows_dialog_id); #define XMSWINDOWS_DIALOG_ID(x) XRECORD (x, mswindows_dialog_id, struct mswindows_dialog_id) #define wrap_mswindows_dialog_id(p) wrap_record (p, mswindows_dialog_id) #define MSWINDOWS_DIALOG_IDP(x) RECORDP (x, mswindows_dialog_id)
--- a/src/console-stream-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-stream-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -35,7 +35,7 @@ struct stream_console { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ FILE *in; FILE *out; @@ -47,7 +47,7 @@ #ifdef NEW_GC typedef struct stream_console Lisp_Stream_Console; -DECLARE_LRECORD (stream_console, Lisp_Stream_Console); +DECLARE_LISP_OBJECT (stream_console, Lisp_Stream_Console); #define XSTREAM_CONSOLE(x) \ XRECORD (x, stream_console, Lisp_Stream_Console)
--- a/src/console-stream.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-stream.c Mon Mar 29 21:28:13 2010 -0500 @@ -54,11 +54,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("stream-console", stream_console, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - stream_console_data_description_1, - Lisp_Stream_Console); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("stream-console", stream_console, + 0, stream_console_data_description_1, + Lisp_Stream_Console); #else /* not NEW_GC */ const struct sized_memory_description stream_console_data_description = { sizeof (struct stream_console), stream_console_data_description_1 @@ -73,8 +71,8 @@ #ifdef NEW_GC if (CONSOLE_STREAM_DATA (con) == NULL) - CONSOLE_STREAM_DATA (con) = alloc_lrecord_type (struct stream_console, - &lrecord_stream_console); + CONSOLE_STREAM_DATA (con) = + XSTREAM_CONSOLE (ALLOC_NORMAL_LISP_OBJECT (stream_console)); #else /* not NEW_GC */ if (CONSOLE_STREAM_DATA (con) == NULL) CONSOLE_STREAM_DATA (con) = xnew_and_zero (struct stream_console); @@ -282,7 +280,8 @@ int UNUSED (x), int UNUSED (y), int UNUSED (width), int UNUSED (height), Lisp_Object UNUSED (fcolor), Lisp_Object UNUSED (bcolor), - Lisp_Object UNUSED (background_pixmap)) + Lisp_Object UNUSED (background_pixmap), + Lisp_Object UNUSED (background_placement)) { ABORT (); }
--- a/src/console-tty-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-tty-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -40,7 +40,7 @@ struct tty_console { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ int infd, outfd; Lisp_Object instream, outstream; @@ -207,7 +207,7 @@ #ifdef NEW_GC typedef struct tty_console Lisp_Tty_Console; -DECLARE_LRECORD (tty_console, Lisp_Tty_Console); +DECLARE_LISP_OBJECT (tty_console, Lisp_Tty_Console); #define XTTY_CONSOLE(x) \ XRECORD (x, tty_console, Lisp_Tty_Console) @@ -256,7 +256,7 @@ struct tty_device { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ #ifdef HAVE_TERMIOS speed_t ospeed; /* Output speed (from sg_ospeed) */ @@ -268,7 +268,7 @@ #ifdef NEW_GC typedef struct tty_device Lisp_Tty_Device; -DECLARE_LRECORD (tty_device, Lisp_Tty_Device); +DECLARE_LISP_OBJECT (tty_device, Lisp_Tty_Device); #define XTTY_DEVICE(x) \ XRECORD (x, tty_device, Lisp_Tty_Device)
--- a/src/console-tty.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-tty.c Mon Mar 29 21:28:13 2010 -0500 @@ -60,11 +60,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("tty-console", tty_console, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - tty_console_data_description_1, - Lisp_Tty_Console); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("tty-console", tty_console, + 0, tty_console_data_description_1, + Lisp_Tty_Console); #else /* not NEW_GC */ const struct sized_memory_description tty_console_data_description = { sizeof (struct tty_console), tty_console_data_description_1 @@ -77,8 +75,7 @@ { /* zero out all slots except the lisp ones ... */ #ifdef NEW_GC - CONSOLE_TTY_DATA (con) = alloc_lrecord_type (struct tty_console, - &lrecord_tty_console); + CONSOLE_TTY_DATA (con) = XTTY_CONSOLE (ALLOC_NORMAL_LISP_OBJECT (tty_console)); #else /* not NEW_GC */ CONSOLE_TTY_DATA (con) = xnew_and_zero (struct tty_console); #endif /* not NEW_GC */
--- a/src/console-x-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-x-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -2,6 +2,7 @@ Copyright (C) 1989, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. Copyright (C) 1996, 2002, 2003 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -45,7 +46,7 @@ struct x_device { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* The X connection of this device. */ Display *display; @@ -167,7 +168,7 @@ #ifdef NEW_GC typedef struct x_device Lisp_X_Device; -DECLARE_LRECORD (x_device, Lisp_X_Device); +DECLARE_LISP_OBJECT (x_device, Lisp_X_Device); #define XX_DEVICE(x) \ XRECORD (x, x_device, Lisp_X_Device) @@ -243,7 +244,7 @@ struct x_frame { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* The widget of this frame. @@ -265,6 +266,8 @@ /* The widget of the edit portion of this frame; this is an EmacsFrame, and the window of this widget is what the redisplay code draws on. */ Widget edit_widget; + /* Position of the edit widget above, for absolute background placement. */ + int x, y; /* Lists the widgets above the text area, in the proper order. Used by the EmacsManager. */ @@ -351,7 +354,7 @@ #ifdef NEW_GC typedef struct x_frame Lisp_X_Frame; -DECLARE_LRECORD (x_frame, Lisp_X_Frame); +DECLARE_LISP_OBJECT (x_frame, Lisp_X_Frame); #define XX_FRAME(x) \ XRECORD (x, x_frame, Lisp_X_Frame) @@ -360,6 +363,8 @@ #endif /* NEW_GC */ #define FRAME_X_DATA(f) FRAME_TYPE_DATA (f, x) +#define FRAME_X_X(f) (FRAME_X_DATA (f)->x) +#define FRAME_X_Y(f) (FRAME_X_DATA (f)->y) #define FRAME_X_SHELL_WIDGET(f) (FRAME_X_DATA (f)->widget) #define FRAME_X_CONTAINER_WIDGET(f) (FRAME_X_DATA (f)->container) #define FRAME_X_MENUBAR_WIDGET(f) (FRAME_X_DATA (f)->menubar_widget) @@ -407,6 +412,8 @@ extern struct console_type *x_console_type; +void x_get_frame_text_position (struct frame *); + #endif /* HAVE_X_WINDOWS */ #endif /* INCLUDED_console_x_impl_h_ */
--- a/src/console-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -240,7 +240,7 @@ split_up_display_spec (connection, &hostname_length, &display_length, &screen_length); - hostname = Fsubstring (connection, Qzero, make_int (hostname_length)); + hostname = Fsubseq (connection, Qzero, make_int (hostname_length)); hostname = canonicalize_host_name (hostname); connection = concat2 (hostname, make_string (XSTRING_DATA (connection)
--- a/src/console-xlike-inc.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console-xlike-inc.h Mon Mar 29 21:28:13 2010 -0500 @@ -169,6 +169,8 @@ #define XLIKE_GC_LINE_WIDTH GCLineWidth #define XLIKE_GC_STIPPLE GCStipple #define XLIKE_GC_TILE GCTile +#define XLIKE_GC_TS_X_ORIGIN GCTileStipXOrigin +#define XLIKE_GC_TS_Y_ORIGIN GCTileStipYOrigin #define XLIKE_GX_COPY GXcopy #define XLIKE_GX_XOR GXxor @@ -258,6 +260,8 @@ #define XLIKE_GC_LINE_WIDTH GDK_GC_LINE_WIDTH #define XLIKE_GC_STIPPLE GDK_GC_STIPPLE #define XLIKE_GC_TILE GDK_GC_TILE +#define XLIKE_GC_TS_X_ORIGIN GDK_GC_TS_X_ORIGIN +#define XLIKE_GC_TS_Y_ORIGIN GDK_GC_TS_Y_ORIGIN #define XLIKE_GX_COPY GDK_COPY #define XLIKE_GX_XOR GDK_XOR
--- a/src/console.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console.c Mon Mar 29 21:28:13 2010 -0500 @@ -163,21 +163,20 @@ struct console *con = XCONSOLE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (con->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (con->name)); write_fmt_string (printcharfun, "#<%s-console", !CONSOLE_LIVE_P (con) ? "dead" : CONSOLE_TYPE_NAME (con)); if (CONSOLE_LIVE_P (con) && !NILP (CONSOLE_CONNECTION (con))) write_fmt_string_lisp (printcharfun, " on %S", 1, CONSOLE_CONNECTION (con)); - write_fmt_string (printcharfun, " 0x%x>", con->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } -DEFINE_LRECORD_IMPLEMENTATION ("console", console, - 0, /*dumpable-flag*/ - mark_console, print_console, 0, 0, 0, - console_description, - struct console); +DEFINE_NODUMP_LISP_OBJECT ("console", console, mark_console, + print_console, 0, 0, 0, + console_description, + struct console); static void @@ -194,13 +193,12 @@ static struct console * allocate_console (Lisp_Object type) { - Lisp_Object console; - struct console *con = ALLOC_LCRECORD_TYPE (struct console, &lrecord_console); + Lisp_Object console = ALLOC_NORMAL_LISP_OBJECT (console); + struct console *con = XCONSOLE (console); struct gcpro gcpro1; - COPY_LCRECORD (con, XCONSOLE (Vconsole_defaults)); + copy_lisp_object (console, Vconsole_defaults); - console = wrap_console (con); GCPRO1 (console); con->conmeths = decode_console_type (type, ERROR_ME); @@ -663,7 +661,7 @@ static void nuke_all_console_slots (struct console *con, Lisp_Object zap) { - ZERO_LCRECORD (con); + zero_nonsized_lisp_object (wrap_console (con)); #define MARKED_SLOT(x) con->x = zap; #include "conslots.h" @@ -1187,12 +1185,12 @@ void syms_of_console (void) { - INIT_LRECORD_IMPLEMENTATION (console); + INIT_LISP_OBJECT (console); #ifdef NEW_GC #ifdef HAVE_TTY - INIT_LRECORD_IMPLEMENTATION (tty_console); + INIT_LISP_OBJECT (tty_console); #endif - INIT_LRECORD_IMPLEMENTATION (stream_console); + INIT_LISP_OBJECT (stream_console); #endif /* NEW_GC */ DEFSUBR (Fvalid_console_type_p); @@ -1320,9 +1318,8 @@ #define DEFVAR_CONSOLE_LOCAL_1(lname, field_name, forward_type, magic_fun) \ do { \ struct symbol_value_forward *I_hate_C = \ - alloc_lrecord_type (struct symbol_value_forward, \ - &lrecord_symbol_value_forward); \ - /*mcpro ((Lisp_Object) I_hate_C);*/ \ + XSYMBOL_VALUE_FORWARD (ALLOC_NORMAL_LISP_OBJECT (symbol_value_forward)); \ + /*mcpro ((Lisp_Object) I_hate_C);*/ \ \ I_hate_C->magic.value = &(console_local_flags.field_name); \ I_hate_C->magic.type = forward_type; \ @@ -1354,8 +1351,6 @@ 1 /* lisp_readonly bit */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ &(console_local_flags.field_name), \ forward_type \ @@ -1398,13 +1393,15 @@ /* Make sure all markable slots in console_defaults are initialized reasonably, so mark_console won't choke. */ - struct console *defs = ALLOC_LCRECORD_TYPE (struct console, &lrecord_console); - struct console *syms = ALLOC_LCRECORD_TYPE (struct console, &lrecord_console); + Lisp_Object defobj = ALLOC_NORMAL_LISP_OBJECT (console); + struct console *defs = XCONSOLE (defobj); + Lisp_Object symobj = ALLOC_NORMAL_LISP_OBJECT (console); + struct console *syms = XCONSOLE (symobj); staticpro_nodump (&Vconsole_defaults); staticpro_nodump (&Vconsole_local_symbols); - Vconsole_defaults = wrap_console (defs); - Vconsole_local_symbols = wrap_console (syms); + Vconsole_defaults = defobj; + Vconsole_local_symbols = symobj; nuke_all_console_slots (syms, Qnil); nuke_all_console_slots (defs, Qnil); @@ -1442,6 +1439,8 @@ The local flag bits are in the local_var_flags slot of the console. */ + set_lheader_implementation ((struct lrecord_header *) + &console_local_flags, &lrecord_console); nuke_all_console_slots (&console_local_flags, make_int (-2)); console_local_flags.defining_kbd_macro = always_local_resettable; console_local_flags.last_kbd_macro = always_local_resettable;
--- a/src/console.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/console.h Mon Mar 29 21:28:13 2010 -0500 @@ -79,7 +79,7 @@ struct console; -DECLARE_LRECORD (console, struct console); +DECLARE_LISP_OBJECT (console, struct console); #define XCONSOLE(x) XRECORD (x, console, struct console) #define wrap_console(p) wrap_record (p, console) #define CONSOLEP(x) RECORDP (x, console)
--- a/src/data.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/data.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Primitive operations on Lisp data types for XEmacs Lisp interpreter. Copyright (C) 1985, 1986, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - Copyright (C) 2000, 2001, 2002, 2003 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2003, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -30,6 +30,7 @@ #include "buffer.h" #include "bytecode.h" +#include "gc.h" #include "syssignal.h" #include "sysfloat.h" @@ -41,7 +42,8 @@ Lisp_Object Qcircular_list, Qcircular_property_list; Lisp_Object Qinvalid_argument, Qinvalid_constant, Qwrong_type_argument; Lisp_Object Qargs_out_of_range; -Lisp_Object Qwrong_number_of_arguments, Qinvalid_function, Qno_catch; +Lisp_Object Qwrong_number_of_arguments, Qinvalid_function; +Lisp_Object Qinvalid_keyword_argument, Qno_catch; Lisp_Object Qinternal_error, Qinvalid_state, Qstack_overflow, Qout_of_memory; Lisp_Object Qvoid_variable, Qcyclic_variable_indirection; Lisp_Object Qvoid_function, Qcyclic_function_indirection; @@ -2613,7 +2615,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<weak-list %s %S>", 2, encode_weak_list_type (XWEAK_LIST (obj)->type), @@ -2642,13 +2644,11 @@ Lisp_Object make_weak_list (enum weak_list_type type) { - Lisp_Object result; - struct weak_list *wl = - ALLOC_LCRECORD_TYPE (struct weak_list, &lrecord_weak_list); + Lisp_Object result = ALLOC_NORMAL_LISP_OBJECT (weak_list); + struct weak_list *wl = XWEAK_LIST (result); wl->list = Qnil; wl->type = type; - result = wrap_weak_list (wl); wl->next_weak = Vall_weak_lists; Vall_weak_lists = result; return result; @@ -2662,12 +2662,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("weak-list", weak_list, - 1, /*dumpable-flag*/ - mark_weak_list, print_weak_list, - 0, weak_list_equal, weak_list_hash, - weak_list_description, - struct weak_list); +DEFINE_DUMPABLE_LISP_OBJECT ("weak-list", weak_list, + mark_weak_list, print_weak_list, + 0, weak_list_equal, weak_list_hash, + weak_list_description, + struct weak_list); /* -- we do not mark the list elements (either the elements themselves or the cons cells that hold them) in the normal marking phase. @@ -2806,7 +2805,7 @@ if (need_to_mark_elem && ! marked_p (elem)) { #ifdef USE_KKCC - kkcc_gc_stack_push_lisp_object (elem, 0, -1); + kkcc_gc_stack_push_lisp_object_0 (elem); #else /* NOT USE_KKCC */ mark_object (elem); #endif /* NOT USE_KKCC */ @@ -2834,7 +2833,7 @@ if (!NILP (rest2) && ! marked_p (rest2)) { #ifdef USE_KKCC - kkcc_gc_stack_push_lisp_object (rest2, 0, -1); + kkcc_gc_stack_push_lisp_object_0 (rest2); #else /* NOT USE_KKCC */ mark_object (rest2); #endif /* NOT USE_KKCC */ @@ -3092,7 +3091,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<weak-box>"); /* #### fix */ } @@ -3116,10 +3115,8 @@ Lisp_Object make_weak_box (Lisp_Object value) { - Lisp_Object result; - - struct weak_box *wb = - ALLOC_LCRECORD_TYPE (struct weak_box, &lrecord_weak_box); + Lisp_Object result = ALLOC_NORMAL_LISP_OBJECT (weak_box); + struct weak_box *wb = XWEAK_BOX (result); wb->value = value; result = wrap_weak_box (wb); @@ -3133,12 +3130,10 @@ { XD_END} }; -DEFINE_LRECORD_IMPLEMENTATION ("weak_box", weak_box, - 0, /*dumpable-flag*/ - mark_weak_box, print_weak_box, - 0, weak_box_equal, weak_box_hash, - weak_box_description, - struct weak_box); +DEFINE_NODUMP_LISP_OBJECT ("weak-box", weak_box, mark_weak_box, + print_weak_box, 0, weak_box_equal, + weak_box_hash, weak_box_description, + struct weak_box); DEFUN ("make-weak-box", Fmake_weak_box, 1, 1, 0, /* Return a new weak box from value CONTENTS. @@ -3214,8 +3209,8 @@ if (marked_p (XEPHEMERON (rest)->key)) { #ifdef USE_KKCC - kkcc_gc_stack_push_lisp_object - (XCAR (XEPHEMERON (rest)->cons_chain), 0, -1); + kkcc_gc_stack_push_lisp_object_0 + (XCAR (XEPHEMERON (rest)->cons_chain)); #else /* NOT USE_KKCC */ mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); #endif /* NOT USE_KKCC */ @@ -3264,8 +3259,8 @@ { MARK_CONS (XCONS (XEPHEMERON (rest)->cons_chain)); #ifdef USE_KKCC - kkcc_gc_stack_push_lisp_object - (XCAR (XEPHEMERON (rest)->cons_chain), 0, -1); + kkcc_gc_stack_push_lisp_object_0 + (XCAR (XEPHEMERON (rest)->cons_chain)); #else /* NOT USE_KKCC */ mark_object (XCAR (XEPHEMERON (rest)->cons_chain)); #endif /* NOT USE_KKCC */ @@ -3318,7 +3313,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<ephemeron>"); /* #### fix */ } @@ -3337,24 +3332,23 @@ } Lisp_Object -make_ephemeron(Lisp_Object key, Lisp_Object value, Lisp_Object finalizer) +make_ephemeron (Lisp_Object key, Lisp_Object value, Lisp_Object finalizer) { - Lisp_Object result, temp = Qnil; + Lisp_Object temp = Qnil; struct gcpro gcpro1, gcpro2; - - struct ephemeron *eph = - ALLOC_LCRECORD_TYPE (struct ephemeron, &lrecord_ephemeron); + Lisp_Object result = ALLOC_NORMAL_LISP_OBJECT (ephemeron); + struct ephemeron *eph = XEPHEMERON (result); eph->key = Qnil; eph->cons_chain = Qnil; eph->value = Qnil; - result = wrap_ephemeron(eph); + result = wrap_ephemeron (eph); GCPRO2 (result, temp); eph->key = key; - temp = Fcons(value, finalizer); - eph->cons_chain = Fcons(temp, Vall_ephemerons); + temp = Fcons (value, finalizer); + eph->cons_chain = Fcons (temp, Vall_ephemerons); eph->value = value; Vall_ephemerons = result; @@ -3375,12 +3369,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("ephemeron", ephemeron, - 0, /*dumpable-flag*/ - mark_ephemeron, print_ephemeron, - 0, ephemeron_equal, ephemeron_hash, - ephemeron_description, - struct ephemeron); +DEFINE_NODUMP_LISP_OBJECT ("ephemeron", ephemeron, + mark_ephemeron, print_ephemeron, + 0, ephemeron_equal, ephemeron_hash, + ephemeron_description, + struct ephemeron); DEFUN ("make-ephemeron", Fmake_ephemeron, 2, 3, 0, /* Return a new ephemeron with key KEY, value VALUE, and finalizer FINALIZER. @@ -3472,6 +3465,7 @@ DEFERROR_STANDARD (Qwrong_number_of_arguments, Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_function, Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_constant, Qinvalid_argument); + DEFERROR_STANDARD (Qinvalid_keyword_argument, Qinvalid_argument); DEFERROR (Qno_catch, "No catch for tag", Qinvalid_argument); DEFERROR_STANDARD (Qinvalid_state, Qerror); @@ -3518,9 +3512,9 @@ void syms_of_data (void) { - INIT_LRECORD_IMPLEMENTATION (weak_list); - INIT_LRECORD_IMPLEMENTATION (ephemeron); - INIT_LRECORD_IMPLEMENTATION (weak_box); + INIT_LISP_OBJECT (weak_list); + INIT_LISP_OBJECT (ephemeron); + INIT_LISP_OBJECT (weak_box); DEFSYMBOL (Qquote); DEFSYMBOL (Qlambda);
--- a/src/database.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/database.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Database access routines Copyright (C) 1996, William M. Perry - Copyright (C) 2001, 2002, 2005 Ben Wing. + Copyright (C) 2001, 2002, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -147,7 +147,7 @@ struct Lisp_Database { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object fname; int mode; int access_; @@ -180,7 +180,8 @@ static Lisp_Database * allocate_database (void) { - Lisp_Database *db = ALLOC_LCRECORD_TYPE (Lisp_Database, &lrecord_database); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (database); + Lisp_Database *db = XDATABASE (obj); db->fname = Qnil; db->live_p = 0; @@ -216,7 +217,7 @@ Lisp_Database *db = XDATABASE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<database \"%s\" (%s/%s/", 3, db->fname, db->funcs->get_type (db), @@ -231,29 +232,22 @@ XSYMBOL_NAME (XCODING_SYSTEM_NAME (db->coding_system))); - write_fmt_string (printcharfun, "0x%x>", db->header.uid); + write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_database (void *header, int for_disksave) +finalize_database (Lisp_Object obj) { - Lisp_Database *db = (Lisp_Database *) header; + Lisp_Database *db = XDATABASE (obj); - if (for_disksave) - { - invalid_operation - ("Can't dump an emacs containing database objects", - wrap_database (db)); - } db->funcs->close (db); } -DEFINE_LRECORD_IMPLEMENTATION ("database", database, - 0, /*dumpable-flag*/ - mark_database, print_database, - finalize_database, 0, 0, - database_description, - Lisp_Database); +DEFINE_NODUMP_LISP_OBJECT ("database", database, + mark_database, print_database, + finalize_database, 0, 0, + database_description, + Lisp_Database); DEFUN ("close-database", Fclose_database, 1, 1, 0, /* Close database DATABASE. @@ -860,7 +854,7 @@ void syms_of_database (void) { - INIT_LRECORD_IMPLEMENTATION (database); + INIT_LISP_OBJECT (database); DEFSYMBOL (Qdatabasep); #ifdef HAVE_DBM
--- a/src/database.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/database.h Mon Mar 29 21:28:13 2010 -0500 @@ -25,6 +25,6 @@ #define INCLUDED_database_h_ typedef struct Lisp_Database Lisp_Database; -DECLARE_LRECORD (database, Lisp_Database); +DECLARE_LISP_OBJECT (database, Lisp_Database); #endif /* INCLUDED_database_h_ */
--- a/src/depend Tue Feb 23 07:28:35 2010 -0600 +++ b/src/depend Mon Mar 29 21:28:13 2010 -0500 @@ -11,92 +11,92 @@ LISP_H= #else CONFIG_H=config.h -LISP_H=lisp.h compiler.h config.h dumper.h gc.h general-slots.h lisp.h lrecord.h mc-alloc.h number-gmp.h number-mp.h number.h symeval.h symsinit.h text.h vdb.h $(LISP_UNION_H) +LISP_H=lisp.h array.h compiler.h config.h dumper.h gc.h general-slots.h lisp.h lrecord.h mc-alloc.h number-gmp.h number-mp.h number.h symeval.h symsinit.h text.h vdb.h $(LISP_UNION_H) #endif #if defined(HAVE_MS_WINDOWS) console-msw.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console-msw-impl.h console-msw.h console.h elhash.h events.h intl-auto-encap-win32.h keymap-buttons.h opaque.h specifier.h systime.h syswindows.h -device-msw.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-msw-impl.h console-msw.h console-stream.h console.h device-impl.h device.h devslots.h events.h faces.h frame.h intl-auto-encap-win32.h keymap-buttons.h fontcolor-msw.h fontcolor.h redisplay.h specifier.h sysdep.h systime.h syswindows.h +device-msw.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-msw-impl.h console-msw.h console-stream.h console.h device-impl.h device.h devslots.h events.h faces.h fontcolor-msw.h fontcolor.h frame.h intl-auto-encap-win32.h keymap-buttons.h redisplay.h specifier.h sysdep.h systime.h syswindows.h dialog-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h frame-impl.h frame.h frameslots.h gui.h intl-auto-encap-win32.h opaque.h redisplay.h specifier.h sysfile.h syswindows.h dired-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console-msw.h console.h intl-auto-encap-win32.h ndir.h regex.h syntax.h sysdir.h sysfile.h sysfloat.h sysproc.h syspwd.h syssignal.h systime.h syswindows.h -event-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console-stream-impl.h console-stream.h console.h device-impl.h device.h devslots.h dragdrop.h events.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gui.h intl-auto-encap-win32.h keymap-buttons.h lstream.h menubar.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h process.h redisplay.h scrollbar-msw.h scrollbar.h specifier.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h syswait.h syswindows.h window-impl.h window.h winslots.h +event-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console-stream-impl.h console-stream.h console.h device-impl.h device.h devslots.h dragdrop.h events.h faces.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gui.h intl-auto-encap-win32.h keymap-buttons.h lstream.h menubar.h process.h redisplay.h scrollbar-msw.h scrollbar.h specifier.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h syswait.h syswindows.h window-impl.h window.h winslots.h +fontcolor-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device-impl.h device.h devslots.h elhash.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h insdel.h intl-auto-encap-win32.h opaque.h specifier.h syswindows.h frame-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h intl-auto-encap-win32.h keymap-buttons.h redisplay.h scrollbar.h specifier.h systime.h syswindows.h window-impl.h window.h winslots.h -glyphs-msw.o: $(CONFIG_H) $(LISP_H) charset.h coding-system-slots.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device-impl.h device.h devslots.h elhash.h faces.h file-coding.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h lstream.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h opaque.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h syswindows.h window-impl.h window.h winslots.h +glyphs-msw.o: $(CONFIG_H) $(LISP_H) charset.h coding-system-slots.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device-impl.h device.h devslots.h elhash.h faces.h file-coding.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h lstream.h opaque.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h syswindows.h window-impl.h window.h winslots.h gui-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h elhash.h events.h frame-impl.h frame.h frameslots.h glyphs.h gui.h intl-auto-encap-win32.h keymap-buttons.h redisplay.h scrollbar.h specifier.h systime.h syswindows.h window-impl.h window.h winslots.h menubar-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h elhash.h events.h frame-impl.h frame.h frameslots.h gui.h intl-auto-encap-win32.h keymap-buttons.h menubar.h opaque.h redisplay.h scrollbar.h specifier.h systime.h syswindows.h window-impl.h window.h winslots.h -fontcolor-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device-impl.h device.h devslots.h elhash.h insdel.h intl-auto-encap-win32.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h opaque.h specifier.h syswindows.h -redisplay-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h debug.h device-impl.h device.h devslots.h events.h faces.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h gutter.h intl-auto-encap-win32.h keymap-buttons.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdep.h systime.h syswindows.h window-impl.h window.h winslots.h +redisplay-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h debug.h device-impl.h device.h devslots.h events.h faces.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h gutter.h intl-auto-encap-win32.h keymap-buttons.h redisplay.h scrollbar.h specifier.h sysdep.h systime.h syswindows.h window-impl.h window.h winslots.h scrollbar-msw.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device.h elhash.h events.h frame-impl.h frame.h frameslots.h intl-auto-encap-win32.h keymap-buttons.h opaque.h redisplay.h scrollbar-msw.h scrollbar.h specifier.h systime.h syswindows.h window-impl.h window.h winslots.h select-msw.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h file-coding.h frame-impl.h frame.h frameslots.h intl-auto-encap-win32.h opaque.h redisplay.h select.h specifier.h syswindows.h toolbar-msw.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h device.h elhash.h faces.h frame-impl.h frame.h frameslots.h glyphs-msw.h glyphs.h gui.h intl-auto-encap-win32.h redisplay.h scrollbar.h specifier.h syswindows.h toolbar.h window-impl.h window.h winslots.h #endif #if defined(HAVE_XLIKE) event-xlike-inc.o: -fontcolor-xlike-inc.o: $(LWLIB_SRCDIR)/lwlib.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h -redisplay-xlike-inc.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdep.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +fontcolor-xlike-inc.o: $(LWLIB_SRCDIR)/lwlib.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h +redisplay-xlike-inc.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h redisplay.h scrollbar.h specifier.h sysdep.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h select-xlike-inc.o: toolbar-xlike.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h faces.h frame-impl.h frame.h frameslots.h glyphs.h redisplay.h scrollbar.h specifier.h sysgtk.h toolbar-xlike.h toolbar.h window-impl.h window.h winslots.h xintrinsic.h #endif #if defined(HAVE_X_WINDOWS) -EmacsFrame.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h faces.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h fontcolor-x.h fontcolor.h redisplay.h scrollbar.h specifier.h toolbar.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +EmacsFrame.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h faces.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h redisplay.h scrollbar.h specifier.h toolbar.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h EmacsManager.o: $(CONFIG_H) $(LWLIB_SRCDIR)/lwlib.h EmacsManager.h EmacsManagerP.h compiler.h xintrinsicp.h xmmanagerp.h xmotif.h xmprimitivep.h EmacsShell-sub.o: $(CONFIG_H) $(LWLIB_SRCDIR)/lwlib.h EmacsShell.h EmacsShellP.h xintrinsic.h xintrinsicp.h EmacsShell.o: $(CONFIG_H) EmacsShell.h ExternalShell.h xintrinsicp.h balloon-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h balloon_help.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h specifier.h xintrinsic.h balloon_help.o: $(CONFIG_H) balloon_help.h compiler.h xintrinsic.h console-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h elhash.h process.h redisplay.h specifier.h xintrinsic.h -device-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h file-coding.h frame-impl.h frame.h frameslots.h gccache-x.h glyphs-x.h glyphs.h intl-auto-encap-win32.h keymap-buttons.h fontcolor-x.h fontcolor.h process.h redisplay.h scrollbar.h specifier.h sysdep.h sysdll.h sysfile.h systime.h syswindows.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h +device-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h file-coding.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h gccache-x.h glyphs-x.h glyphs.h intl-auto-encap-win32.h keymap-buttons.h process.h redisplay.h scrollbar.h specifier.h sysdep.h sysdll.h sysfile.h systime.h syswindows.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h dialog-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console-x-impl.h console-x.h console.h events.h frame-impl.h frame.h frameslots.h gui.h keymap-buttons.h opaque.h redisplay.h scrollbar.h specifier.h systime.h window.h xintrinsic.h -frame-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h EmacsShell.h ExternalShell.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h dragdrop.h events.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h gutter.h keymap-buttons.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h redisplay.h scrollbar-x.h scrollbar.h specifier.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +fontcolor-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h device-impl.h device.h devslots.h elhash.h font-mgr.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor-xlike-inc.c fontcolor.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h insdel.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h +frame-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h EmacsManager.h EmacsShell.h ExternalShell.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h dragdrop.h events.h extents.h faces.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h gutter.h keymap-buttons.h redisplay.h scrollbar-x.h scrollbar.h specifier.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h gccache-x.o: $(CONFIG_H) $(LISP_H) gccache-x.h hash.h -glyphs-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h bitmaps.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h faces.h file-coding.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h lstream.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h opaque.h process.h redisplay.h scrollbar.h specifier.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h window-impl.h window.h winslots.h xintrinsic.h xmotif.h +glyphs-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h bitmaps.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h faces.h file-coding.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h lstream.h opaque.h process.h redisplay.h scrollbar.h specifier.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h window-impl.h window.h winslots.h xintrinsic.h xmotif.h gui-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h events.h frame.h glyphs.h gui.h keymap-buttons.h menubar.h opaque.h redisplay.h scrollbar.h specifier.h systime.h window-impl.h window.h winslots.h xintrinsic.h xmotif.h intl-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h console-x.h console.h xintrinsic.h menubar-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h gui.h keymap-buttons.h keymap.h menubar.h opaque.h redisplay.h scrollbar.h specifier.h systime.h window-impl.h window.h winslots.h xintrinsic.h -fontcolor-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h device-impl.h device.h devslots.h elhash.h font-mgr.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h insdel.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor-xlike-inc.c fontcolor.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h -redisplay-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h redisplay-xlike-inc.c redisplay.h scrollbar.h specifier.h sysdep.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +redisplay-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h redisplay-xlike-inc.c redisplay.h scrollbar.h specifier.h sysdep.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h scrollbar-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h redisplay.h scrollbar-x.h scrollbar.h specifier.h window-impl.h window.h winslots.h xintrinsic.h -select-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h frame-impl.h frame.h frameslots.h fontcolor-x.h fontcolor.h opaque.h redisplay.h select-xlike-inc.c select.h specifier.h systime.h xintrinsic.h xmotif.h -toolbar-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h faces.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h fontcolor-x.h fontcolor.h redisplay.h scrollbar.h specifier.h toolbar-xlike.h toolbar.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +select-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h opaque.h redisplay.h select-xlike-inc.c select.h specifier.h systime.h xintrinsic.h xmotif.h +toolbar-x.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h charset.h conslots.h console-impl.h console-x-impl.h console-x.h console.h faces.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h redisplay.h scrollbar.h specifier.h toolbar-xlike.h toolbar.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h #endif #if defined(HAVE_TTY) console-tty.o: $(CONFIG_H) $(LISP_H) charset.h coding-system-slots.h conslots.h console-impl.h console-stream.h console-tty-impl.h console-tty.h console.h elhash.h faces.h file-coding.h frame.h glyphs.h intl-auto-encap-win32.h lstream.h process.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h systty.h syswindows.h window-impl.h window.h winslots.h device-tty.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-stream.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h faces.h frame.h intl-auto-encap-win32.h keymap-buttons.h lstream.h redisplay.h specifier.h sysdep.h sysfile.h syssignal.h systime.h systty.h syswindows.h event-tty.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device.h events.h frame.h keymap-buttons.h process.h redisplay.h specifier.h sysproc.h syssignal.h systime.h systty.h syswait.h +fontcolor-tty.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device.h fontcolor-impl.h fontcolor-tty-impl.h fontcolor-tty.h fontcolor.h insdel.h specifier.h systty.h frame-tty.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h keymap-buttons.h redisplay.h specifier.h systime.h systty.h -fontcolor-tty.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device.h insdel.h fontcolor-impl.h fontcolor-tty-impl.h fontcolor-tty.h fontcolor.h specifier.h systty.h -redisplay-tty.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h faces.h frame-impl.h frame.h frameslots.h glyphs.h keymap-buttons.h lstream.h fontcolor-impl.h fontcolor-tty-impl.h fontcolor-tty.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdep.h syssignal.h systime.h systty.h window-impl.h window.h winslots.h +redisplay-tty.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h faces.h fontcolor-impl.h fontcolor-tty-impl.h fontcolor-tty.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h keymap-buttons.h lstream.h redisplay.h scrollbar.h specifier.h sysdep.h syssignal.h systime.h systty.h window-impl.h window.h winslots.h #endif #if defined(HAVE_GTK) console-gtk.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h elhash.h process.h redisplay.h specifier.h sysgtk.h -device-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h frame-impl.h frame.h frameslots.h gccache-gtk.h glyphs-gtk.h glyphs.h gtk-xemacs.h intl-auto-encap-win32.h keymap-buttons.h fontcolor-gtk.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h sysgdkx.h sysgtk.h systime.h syswindows.h window-impl.h window.h winslots.h +device-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h fontcolor-gtk.h fontcolor.h frame-impl.h frame.h frameslots.h gccache-gtk.h glyphs-gtk.h glyphs.h gtk-xemacs.h intl-auto-encap-win32.h keymap-buttons.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h sysgdkx.h sysgtk.h systime.h syswindows.h window-impl.h window.h winslots.h dialog-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h events.h frame.h gui.h keymap-buttons.h opaque.h redisplay.h scrollbar.h specifier.h sysgtk.h systime.h window.h emacs-marshals.o: hash.h emacs-widget-accessors.o: -event-gtk.o: $(CONFIG_H) $(LISP_H) blocktype.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-tty.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h event-xlike-inc.c events.h file-coding.h frame-impl.h frame.h frameslots.h gtk-xemacs.h gui.h keymap-buttons.h lstream.h menubar.h fontcolor-gtk.h fontcolor.h process.h redisplay.h scrollbar.h specifier.h sysgdkx.h sysgtk.h sysproc.h syssignal.h systime.h systty.h window.h -frame-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h events.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs-gtk.h glyphs.h gtk-xemacs.h keymap-buttons.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h redisplay.h scrollbar-gtk.h scrollbar.h specifier.h sysdll.h sysgdkx.h sysgtk.h systime.h ui-gtk.h window-impl.h window.h winslots.h +event-gtk.o: $(CONFIG_H) $(LISP_H) blocktype.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-tty.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h event-xlike-inc.c events.h file-coding.h fontcolor-gtk.h fontcolor.h frame-impl.h frame.h frameslots.h gtk-xemacs.h gui.h keymap-buttons.h lstream.h menubar.h process.h redisplay.h scrollbar.h specifier.h sysgdkx.h sysgtk.h sysproc.h syssignal.h systime.h systty.h window.h +fontcolor-gtk.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h device-impl.h device.h devslots.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor-xlike-inc.c fontcolor.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h insdel.h redisplay.h scrollbar.h specifier.h sysgdkx.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h +frame-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h events.h extents.h faces.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-gtk.h glyphs.h gtk-xemacs.h keymap-buttons.h redisplay.h scrollbar-gtk.h scrollbar.h specifier.h sysdll.h sysgdkx.h sysgtk.h systime.h ui-gtk.h window-impl.h window.h winslots.h gccache-gtk.o: $(CONFIG_H) $(LISP_H) gccache-gtk.h hash.h sysgtk.h glade.o: bytecode.h -glyphs-gtk.o: $(CONFIG_H) $(LISP_H) bitmaps.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h file-coding.h frame-impl.h frame.h frameslots.h glyphs-gtk.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h keymap-buttons.h lstream.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h opaque.h redisplay.h scrollbar.h specifier.h sysdll.h sysfile.h sysgdkx.h sysgtk.h systime.h syswindows.h ui-gtk.h window-impl.h window.h winslots.h +glyphs-gtk.o: $(CONFIG_H) $(LISP_H) bitmaps.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h file-coding.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs-gtk.h glyphs.h gui.h imgproc.h insdel.h intl-auto-encap-win32.h keymap-buttons.h lstream.h opaque.h redisplay.h scrollbar.h specifier.h sysdll.h sysfile.h sysgdkx.h sysgtk.h systime.h syswindows.h ui-gtk.h window-impl.h window.h winslots.h gtk-glue.o: console-gtk.h console.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h specifier.h sysgtk.h -gtk-xemacs.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gtk-xemacs.h fontcolor-gtk.h fontcolor.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h +gtk-xemacs.o: $(CONFIG_H) $(LISP_H) charset.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h faces.h fontcolor-gtk.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gtk-xemacs.h redisplay.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h gui-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h frame.h gui.h opaque.h redisplay.h specifier.h sysgtk.h menubar-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h gui.h keymap-buttons.h menubar.h opaque.h redisplay.h scrollbar.h specifier.h sysdll.h sysgtk.h systime.h ui-gtk.h window-impl.h window.h winslots.h -native-gtk-toolbar.o: $(CONFIG_H) $(LISP_H) charset.h console-gtk.h console.h faces.h frame.h glyphs-gtk.h glyphs.h fontcolor-gtk.h fontcolor.h redisplay.h scrollbar.h specifier.h sysgtk.h toolbar.h window-impl.h window.h winslots.h -fontcolor-gtk.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h device-impl.h device.h devslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h insdel.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor-xlike-inc.c fontcolor.h redisplay.h scrollbar.h specifier.h sysgdkx.h sysgtk.h window-impl.h window.h winslots.h xintrinsic.h -redisplay-gtk.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h redisplay-xlike-inc.c redisplay.h scrollbar.h specifier.h sysdep.h sysgdkx.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h +native-gtk-toolbar.o: $(CONFIG_H) $(LISP_H) charset.h console-gtk.h console.h faces.h fontcolor-gtk.h fontcolor.h frame.h glyphs-gtk.h glyphs.h redisplay.h scrollbar.h specifier.h sysgtk.h toolbar.h window-impl.h window.h winslots.h +redisplay-gtk.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h EmacsFrameP.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-x-impl.h console-x.h console-xlike-inc.h console.h debug.h device-impl.h device.h devslots.h faces.h file-coding.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h gccache-gtk.h gccache-x.h glyphs-gtk.h glyphs-x.h glyphs.h gutter.h mule-ccl.h redisplay-xlike-inc.c redisplay.h scrollbar.h specifier.h sysdep.h sysgdkx.h sysgtk.h sysproc.h syssignal.h systime.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h xmprimitivep.h scrollbar-gtk.o: $(CONFIG_H) $(LISP_H) conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h frame-impl.h frame.h frameslots.h glyphs-gtk.h glyphs.h redisplay.h scrollbar-gtk.h scrollbar.h specifier.h sysgtk.h window-impl.h window.h winslots.h select-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device-impl.h device.h devslots.h events.h frame.h keymap-buttons.h opaque.h redisplay.h select-xlike-inc.c select.h specifier.h sysgtk.h systime.h toolbar-gtk.o: $(CONFIG_H) $(LISP_H) conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h frame.h redisplay.h specifier.h sysgtk.h toolbar-xlike.h ui-byhand.o: gui.h -ui-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device.h elhash.h emacs-marshals.c emacs-widget-accessors.c events.h faces.h glade.c glyphs-gtk.h glyphs.h gtk-glue.c gui.h hash.h keymap-buttons.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdll.h sysgtk.h systime.h ui-byhand.c ui-gtk.h window-impl.h window.h winslots.h +ui-gtk.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console.h device.h elhash.h emacs-marshals.c emacs-widget-accessors.c events.h faces.h fontcolor-gtk-impl.h fontcolor-gtk.h fontcolor-impl.h fontcolor.h glade.c glyphs-gtk.h glyphs.h gtk-glue.c gui.h hash.h keymap-buttons.h redisplay.h scrollbar.h specifier.h sysdll.h sysgtk.h systime.h ui-byhand.c ui-gtk.h window-impl.h window.h winslots.h #endif #if defined(HAVE_DATABASE) database.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h database.h file-coding.h intl-auto-encap-win32.h sysfile.h syswindows.h #endif #if defined(MULE) mule-ccl.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h elhash.h file-coding.h mule-ccl.h -mule-charset.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console.h device.h elhash.h faces.h lstream.h mule-ccl.h fontcolor.h specifier.h +mule-charset.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console.h device.h elhash.h faces.h fontcolor.h lstream.h mule-ccl.h specifier.h mule-coding.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h elhash.h extents.h file-coding.h mule-ccl.h rangetab.h mule-wnnfns.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h redisplay.h scrollbar.h sysdep.h window.h #endif @@ -111,6 +111,7 @@ alloc.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-stream.h console.h device.h elhash.h events.h extents-impl.h extents.h file-coding.h frame-impl.h frame.h frameslots.h glyphs.h intl-auto-encap-win32.h keymap-buttons.h lstream.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h systime.h syswindows.h window-impl.h window.h winslots.h alloca.o: $(CONFIG_H) $(LISP_H) alsaplay.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h sound.h sysfile.h syswindows.h +array.o: $(CONFIG_H) $(LISP_H) insdel.h blocktype.o: $(CONFIG_H) $(LISP_H) blocktype.h buffer.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h extents.h faces.h file-coding.h frame-impl.h frame.h frameslots.h insdel.h intl-auto-encap-win32.h lstream.h ndir.h process.h redisplay.h scrollbar.h select.h specifier.h syntax.h sysdir.h sysfile.h syswindows.h window.h bytecode.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h bytecode-ops.h bytecode.h casetab.h charset.h chartab.h opaque.h redisplay.h scrollbar.h syntax.h window.h @@ -125,7 +126,7 @@ console.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-stream-impl.h console-stream.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h keymap-buttons.h redisplay.h scrollbar.h specifier.h sysdep.h systime.h systty.h window.h data.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h sysfloat.h syssignal.h debug.o: $(CONFIG_H) $(LISP_H) bytecode.h debug.h -device.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h frame-impl.h frame.h frameslots.h keymap-buttons.h keymap.h fontcolor.h redisplay.h scrollbar.h specifier.h sysdep.h syssignal.h systime.h toolbar.h window.h +device.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h faces.h fontcolor.h frame-impl.h frame.h frameslots.h keymap-buttons.h keymap.h redisplay.h scrollbar.h specifier.h sysdep.h syssignal.h systime.h toolbar.h window.h dialog.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console.h frame-impl.h frame.h frameslots.h redisplay.h specifier.h dired.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h elhash.h intl-auto-encap-win32.h ndir.h opaque.h regex.h syntax.h sysdep.h sysdir.h sysfile.h syspwd.h systime.h syswindows.h doc.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h file-coding.h insdel.h intl-auto-encap-win32.h keymap-buttons.h keymap.h lstream.h sysfile.h syswindows.h @@ -133,7 +134,6 @@ dragdrop.o: $(CONFIG_H) $(LISP_H) dragdrop.h dump-data.o: $(CONFIG_H) $(LISP_H) dump-data.h dumper.o: $(CONFIG_H) $(LISP_H) coding-system-slots.h console-stream.h console.h dump-data.h elhash.h file-coding.h intl-auto-encap-win32.h lstream.h specifier.h sysfile.h syswindows.h -dynarr.o: $(CONFIG_H) $(LISP_H) ecrt0.o: $(CONFIG_H) editfns.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h console.h device.h events.h frame.h insdel.h intl-auto-encap-win32.h keymap-buttons.h line-number.h ndir.h process.h redisplay.h scrollbar.h sysdep.h sysdir.h sysfile.h sysproc.h syspwd.h syssignal.h systime.h syswindows.h window.h elhash.o: $(CONFIG_H) $(LISP_H) bytecode.h elhash.h opaque.h @@ -141,12 +141,12 @@ emodules.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h console.h emodules.h file-coding.h frame.h insdel.h lstream.h redisplay.h scrollbar.h sysdep.h sysdll.h window.h esd.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h miscplay.h sound.h sysfile.h syswindows.h eval.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console.h device.h frame.h lstream.h opaque.h profile.h redisplay.h scrollbar.h specifier.h window.h -event-Xt.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h Emacs.ad.h EmacsFrame.h blocktype.h charset.h coding-system-slots.h conslots.h console-impl.h console-tty.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h event-xlike-inc.c events.h file-coding.h frame-impl.h frame.h frameslots.h glyphs.h keymap-buttons.h lstream.h fontcolor-x.h fontcolor.h process.h redisplay.h scrollbar.h specifier.h sysproc.h syssignal.h systime.h systty.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h +event-Xt.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h Emacs.ad.h EmacsFrame.h blocktype.h charset.h coding-system-slots.h conslots.h console-impl.h console-tty.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h dragdrop.h elhash.h event-xlike-inc.c events.h file-coding.h fontcolor-x.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h keymap-buttons.h lstream.h process.h redisplay.h scrollbar.h specifier.h sysproc.h syssignal.h systime.h systty.h window-impl.h window.h winslots.h xintrinsic.h xintrinsicp.h xmotif.h event-stream.o: $(CONFIG_H) $(LISP_H) backtrace.h blocktype.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h events.h file-coding.h frame-impl.h frame.h frameslots.h gui.h insdel.h intl-auto-encap-win32.h keymap-buttons.h keymap.h lstream.h macros.h menubar.h process.h profile.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h syssignal.h systime.h syswindows.h window-impl.h window.h winslots.h event-unixoid.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console-stream-impl.h console-stream.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h intl-auto-encap-win32.h keymap-buttons.h lstream.h process.h specifier.h sysdep.h sysfile.h sysproc.h syssignal.h systime.h systty.h syswindows.h events.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device.h events.h extents.h frame-impl.h frame.h frameslots.h glyphs.h keymap-buttons.h keymap.h lstream.h redisplay.h scrollbar.h specifier.h systime.h systty.h toolbar.h window-impl.h window.h winslots.h extents.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h console.h debug.h device.h elhash.h extents-impl.h extents.h faces.h frame.h glyphs.h gutter.h insdel.h keymap-buttons.h keymap.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h -faces.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h extents-impl.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs.h fontcolor-impl.h fontcolor.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h +faces.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h extents-impl.h extents.h faces.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h file-coding.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h elhash.h extents.h file-coding.h insdel.h lstream.h opaque.h rangetab.h fileio.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h console.h device.h events.h file-coding.h frame.h insdel.h intl-auto-encap-win32.h keymap-buttons.h lstream.h ndir.h process.h profile.h redisplay.h scrollbar.h sysdep.h sysdir.h sysfile.h sysproc.h syspwd.h syssignal.h systime.h syswindows.h window-impl.h window.h winslots.h filelock.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h ndir.h paths.h sysdir.h sysfile.h sysproc.h syspwd.h syssignal.h systime.h syswindows.h @@ -154,16 +154,17 @@ floatfns.o: $(CONFIG_H) $(LISP_H) sysfloat.h syssignal.h fns.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h console.h device.h events.h extents.h frame.h insdel.h intl-auto-encap-win32.h keymap-buttons.h lstream.h opaque.h process.h redisplay.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h font-lock.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h insdel.h syntax.h -font-mgr.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h font-mgr.h hash.h intl-auto-encap-win32.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h specifier.h sysfile.h syswindows.h xintrinsic.h +font-mgr.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h font-mgr.h fontcolor-impl.h fontcolor-x-impl.h fontcolor-x.h fontcolor.h hash.h intl-auto-encap-win32.h specifier.h sysfile.h syswindows.h xintrinsic.h +fontcolor.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty.h console.h device-impl.h device.h devslots.h elhash.h faces.h fontcolor-impl.h fontcolor.h frame.h glyphs.h redisplay.h scrollbar.h specifier.h systty.h window-impl.h window.h winslots.h frame.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h events.h extents.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gui.h gutter.h keymap-buttons.h menubar.h process.h redisplay.h scrollbar.h specifier.h systime.h toolbar.h window-impl.h window.h winslots.h free-hook.o: $(CONFIG_H) $(LISP_H) hash.h gc.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console-stream.h console.h device.h elhash.h events.h extents-impl.h extents.h file-coding.h frame-impl.h frame.h frameslots.h glyphs.h intl-auto-encap-win32.h keymap-buttons.h lstream.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h systime.h syswindows.h window-impl.h window.h winslots.h general.o: $(CONFIG_H) $(LISP_H) general-slots.h getloadavg.o: $(CONFIG_H) $(LISP_H) intl-auto-encap-win32.h sysfile.h syswindows.h -glyphs-eimage.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h file-coding.h frame.h glyphs.h intl-auto-encap-win32.h lstream.h fontcolor-impl.h fontcolor.h opaque.h redisplay.h scrollbar.h specifier.h sysfile.h syswindows.h window-impl.h window.h winslots.h +glyphs-eimage.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h file-coding.h fontcolor-impl.h fontcolor.h frame.h glyphs.h intl-auto-encap-win32.h lstream.h opaque.h redisplay.h scrollbar.h specifier.h sysfile.h syswindows.h window-impl.h window.h winslots.h glyphs-shared.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console.h elhash.h faces.h frame.h glyphs.h imgproc.h insdel.h intl-auto-encap-win32.h lstream.h opaque.h redisplay.h scrollbar.h specifier.h sysdep.h sysfile.h syswindows.h window-impl.h window.h winslots.h -glyphs-widget.o: $(CONFIG_H) $(LISP_H) bytecode.h charset.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h frame.h glyphs.h gui.h insdel.h lstream.h fontcolor.h opaque.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h -glyphs.o: $(CONFIG_H) $(LISP_H) blocktype.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gui.h insdel.h intl-auto-encap-win32.h fontcolor-impl.h fontcolor.h opaque.h rangetab.h redisplay.h scrollbar.h specifier.h sysfile.h syswindows.h window-impl.h window.h winslots.h +glyphs-widget.o: $(CONFIG_H) $(LISP_H) bytecode.h charset.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h fontcolor.h frame.h glyphs.h gui.h insdel.h lstream.h opaque.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h +glyphs.o: $(CONFIG_H) $(LISP_H) blocktype.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h faces.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gui.h insdel.h intl-auto-encap-win32.h opaque.h rangetab.h redisplay.h scrollbar.h specifier.h sysfile.h syswindows.h window-impl.h window.h winslots.h gmalloc.o: $(CONFIG_H) $(LISP_H) getpagesize.h sysdep.h gpmevent.o: $(CONFIG_H) $(LISP_H) commands.h conslots.h console-impl.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h events.h frame.h gpmevent.h keymap-buttons.h lstream.h process.h redisplay.h specifier.h sysdep.h sysproc.h syssignal.h systime.h systty.h gui.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h elhash.h gui.h menubar.h redisplay.h @@ -172,13 +173,13 @@ hpplay.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h sound.h imgproc.o: $(CONFIG_H) $(LISP_H) imgproc.h indent.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console.h device.h extents.h faces.h frame.h glyphs.h insdel.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h -inline.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk.h console-impl.h console-msw.h console.h database.h device-impl.h device.h devslots.h elhash.h events.h extents-impl.h extents.h faces.h file-coding.h font-mgr.h frame-impl.h frame.h frameslots.h glyphs-x.h glyphs.h gui.h intl-auto-encap-win32.h keymap-buttons.h keymap.h lstream.h fontcolor-impl.h fontcolor.h opaque.h process.h rangetab.h redisplay.h scrollbar.h specifier.h syntax.h sysdll.h sysfile.h sysgtk.h systime.h syswindows.h toolbar.h tooltalk.h ui-gtk.h window-impl.h window.h winslots.h xintrinsic.h +inline.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h coding-system-slots.h conslots.h console-gtk-impl.h console-gtk.h console-impl.h console-msw-impl.h console-msw.h console-stream-impl.h console-stream.h console-tty-impl.h console-tty.h console-x-impl.h console-x.h console.h database.h device-impl.h device.h devslots.h elhash.h events.h extents-impl.h extents.h faces.h file-coding.h font-mgr.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gui.h intl-auto-encap-win32.h keymap-buttons.h keymap.h lstream.h opaque.h process.h rangetab.h redisplay.h scrollbar.h specifier.h syntax.h sysdll.h sysfile.h sysgtk.h systime.h systty.h syswindows.h toolbar.h tooltalk.h ui-gtk.h window-impl.h window.h winslots.h xintrinsic.h input-method-motif.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device.h frame-impl.h frame.h frameslots.h redisplay.h specifier.h xintrinsic.h xmotif.h input-method-xlib.o: $(CONFIG_H) $(LISP_H) $(LWLIB_SRCDIR)/lwlib.h EmacsFrame.h buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-x-impl.h console-x.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h keymap-buttons.h redisplay.h scrollbar.h specifier.h systime.h window-impl.h window.h winslots.h xintrinsic.h insdel.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h console.h device.h extents.h frame.h insdel.h line-number.h lstream.h redisplay.h intl-auto-encap-win32.o: $(CONFIG_H) $(LISP_H) intl-auto-encap-win32.h syswindows.h intl-encap-win32.o: $(CONFIG_H) $(LISP_H) console-msw.h console.h intl-auto-encap-win32.h syswindows.h -intl-win32.o: $(CONFIG_H) $(LISP_H) charset.h coding-system-slots.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h elhash.h faces.h file-coding.h frame-impl.h frame.h frameslots.h intl-auto-encap-win32.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h redisplay.h scrollbar.h specifier.h syswindows.h window-impl.h window.h winslots.h +intl-win32.o: $(CONFIG_H) $(LISP_H) charset.h coding-system-slots.h conslots.h console-impl.h console-msw-impl.h console-msw.h console.h elhash.h faces.h file-coding.h fontcolor-impl.h fontcolor-msw-impl.h fontcolor-msw.h fontcolor.h frame-impl.h frame.h frameslots.h intl-auto-encap-win32.h redisplay.h scrollbar.h specifier.h syswindows.h window-impl.h window.h winslots.h intl.o: $(CONFIG_H) $(LISP_H) keymap.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h elhash.h events.h extents.h frame.h insdel.h keymap-buttons.h keymap-slots.h keymap.h redisplay.h scrollbar.h specifier.h systime.h window.h lastfile.o: $(CONFIG_H) @@ -202,7 +203,6 @@ number-gmp.o: $(CONFIG_H) $(LISP_H) sysproc.h syssignal.h systime.h number-mp.o: $(CONFIG_H) $(LISP_H) number.o: $(CONFIG_H) $(LISP_H) -fontcolor.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console-tty.h console.h device-impl.h device.h devslots.h elhash.h faces.h frame.h glyphs.h fontcolor-impl.h fontcolor.h redisplay.h scrollbar.h specifier.h systty.h window-impl.h window.h winslots.h opaque.o: $(CONFIG_H) $(LISP_H) opaque.h print.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h bytecode.h casetab.h charset.h chartab.h conslots.h console-impl.h console-msw.h console-stream-impl.h console-stream.h console-tty-impl.h console-tty.h console.h device-impl.h device.h devslots.h extents.h frame.h insdel.h intl-auto-encap-win32.h lstream.h opaque.h redisplay.h specifier.h sysfile.h systty.h syswindows.h process-nt.o: $(CONFIG_H) $(LISP_H) console-msw.h console.h events.h hash.h intl-auto-encap-win32.h keymap-buttons.h lstream.h process-slots.h process.h procimpl.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h @@ -213,11 +213,11 @@ rangetab.o: $(CONFIG_H) $(LISP_H) rangetab.h realpath.o: $(CONFIG_H) $(LISP_H) backtrace.h intl-auto-encap-win32.h ndir.h profile.h sysdir.h sysfile.h syswindows.h redisplay-output.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gutter.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h -redisplay.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-impl.h console-tty.h console.h debug.h device-impl.h device.h devslots.h elhash.h events.h extents-impl.h extents.h faces.h file-coding.h frame-impl.h frame.h frameslots.h glyphs.h gui.h gutter.h insdel.h intl-auto-encap-win32.h keymap-buttons.h line-number.h menubar.h fontcolor-impl.h fontcolor.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h sysfile.h systime.h systty.h syswindows.h toolbar.h window-impl.h window.h winslots.h +redisplay.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h coding-system-slots.h commands.h conslots.h console-impl.h console-tty.h console.h debug.h device-impl.h device.h devslots.h elhash.h events.h extents-impl.h extents.h faces.h file-coding.h fontcolor-impl.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gui.h gutter.h insdel.h intl-auto-encap-win32.h keymap-buttons.h line-number.h menubar.h opaque.h process.h profile.h redisplay.h scrollbar.h specifier.h sysfile.h systime.h systty.h syswindows.h toolbar.h window-impl.h window.h winslots.h regex.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h regex.h syntax.h scrollbar.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h frame-impl.h frame.h frameslots.h glyphs.h gutter.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h search.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h insdel.h opaque.h regex.h syntax.h -select.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h extents.h frame.h fontcolor.h opaque.h redisplay.h select.h specifier.h +select.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h extents.h fontcolor.h frame.h opaque.h redisplay.h select.h specifier.h sgiplay.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h intl-auto-encap-win32.h libst.h sound.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h sheap.o: $(CONFIG_H) $(LISP_H) intl-auto-encap-win32.h sheap-adjust.h sysfile.h syswindows.h signal.o: $(CONFIG_H) $(LISP_H) conslots.h console-impl.h console.h device-impl.h device.h devslots.h events.h frame-impl.h frame.h frameslots.h intl-auto-encap-win32.h keymap-buttons.h process.h redisplay.h specifier.h sysdep.h sysfile.h syssignal.h systime.h syswindows.h @@ -256,4 +256,4 @@ vm-limit.o: $(CONFIG_H) $(LISP_H) mem-limits.h widget.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h win32.o: $(CONFIG_H) $(LISP_H) backtrace.h buffer.h bufslots.h casetab.h charset.h chartab.h console-msw.h console.h hash.h intl-auto-encap-win32.h profile.h sysfile.h sysproc.h syssignal.h systime.h syswindows.h -window.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h faces.h frame-impl.h frame.h frameslots.h glyphs.h gutter.h fontcolor.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h +window.o: $(CONFIG_H) $(LISP_H) buffer.h bufslots.h casetab.h charset.h chartab.h commands.h conslots.h console-impl.h console.h device-impl.h device.h devslots.h elhash.h faces.h fontcolor.h frame-impl.h frame.h frameslots.h glyphs.h gutter.h redisplay.h scrollbar.h specifier.h window-impl.h window.h winslots.h
--- a/src/device-gtk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device-gtk.c Mon Mar 29 21:28:13 2010 -0500 @@ -76,11 +76,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("gtk-device", gtk_device, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - gtk_device_data_description_1, - Lisp_Gtk_Device); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("gtk-device", gtk_device, + 0, gtk_device_data_description_1, + Lisp_Gtk_Device); #else /* not NEW_GC */ extern const struct sized_memory_description gtk_device_data_description; @@ -117,7 +115,7 @@ allocate_gtk_device_struct (struct device *d) { #ifdef NEW_GC - d->device_data = alloc_lrecord_type (struct gtk_device, &lrecord_gtk_device); + d->device_data = XGTK_DEVICE (ALLOC_NORMAL_LISP_OBJECT (gtk_device)); #else /* not NEW_GC */ d->device_data = xnew_and_zero (struct gtk_device); #endif /* not NEW_GC */ @@ -689,7 +687,7 @@ syms_of_device_gtk (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (gtk_device); + INIT_LISP_OBJECT (gtk_device); #endif /* NEW_GC */ DEFSUBR (Fgtk_keysym_on_keyboard_p);
--- a/src/device-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -71,7 +71,7 @@ struct device { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Methods for this device's console. This can also be retrieved through device->console, but it's faster this way. */
--- a/src/device-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* device functions for mswindows. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. Copyright (C) 1994, 1995 Free Software Foundation, Inc. - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -75,11 +75,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("mswindows-device", mswindows_device, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - mswindows_device_data_description_1, - Lisp_Mswindows_Device); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("mswindows-device", mswindows_device, + 0, mswindows_device_data_description_1, + Lisp_Mswindows_Device); #else /* not NEW_GC */ extern const struct sized_memory_description mswindows_device_data_description; @@ -96,11 +94,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("msprinter-device", msprinter_device, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - msprinter_device_data_description_1, - Lisp_Msprinter_Device); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("msprinter-device", msprinter_device, + 0, msprinter_device_data_description_1, + Lisp_Msprinter_Device); #else /* not NEW_GC */ extern const struct sized_memory_description msprinter_device_data_description; @@ -166,8 +162,7 @@ init_one_device (d); #ifdef NEW_GC - d->device_data = alloc_lrecord_type (struct mswindows_device, - &lrecord_mswindows_device); + d->device_data = XMSWINDOWS_DEVICE (ALLOC_NORMAL_LISP_OBJECT (mswindows_device)); #else /* not NEW_GC */ d->device_data = xnew_and_zero (struct mswindows_device); #endif /* not NEW_GC */ @@ -523,8 +518,7 @@ Extbyte *printer_name; #ifdef NEW_GC - d->device_data = alloc_lrecord_type (struct msprinter_device, - &lrecord_msprinter_device); + d->device_data = XMSPRINTER_DEVICE (ALLOC_NORMAL_LISP_OBJECT (msprinter_device)); #else /* not NEW_GC */ d->device_data = xnew_and_zero (struct msprinter_device); #endif /* not NEW_GC */ @@ -580,6 +574,7 @@ #ifndef NEW_GC xfree (d->device_data); + d->device_data = 0; #endif /* not NEW_GC */ } } @@ -671,7 +666,7 @@ suffix. */ Ibyte new_connext[20]; - qxesprintf (new_connext, ":%X", d->header.uid); + qxesprintf (new_connext, ":%X", LISP_OBJECT_UID (wrap_device (d))); new_connection = concat2 (devname, build_istring (new_connext)); } DEVICE_CONNECTION (d) = new_connection; @@ -1154,28 +1149,19 @@ { Lisp_Devmode *dm = XDEVMODE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<msprinter-settings"); if (!NILP (dm->printer_name)) write_fmt_string_lisp (printcharfun, " for %S", 1, dm->printer_name); if (!NILP (dm->device)) write_fmt_string_lisp (printcharfun, " (currently on %s)", 1, dm->device); - write_fmt_string (printcharfun, " 0x%x>", dm->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_devmode (void *header, int for_disksave) +finalize_devmode (Lisp_Object obj) { - Lisp_Devmode *dm = (Lisp_Devmode *) header; - - if (for_disksave) - { - Lisp_Object devmode = wrap_devmode (dm); - - invalid_operation - ("Cannot dump XEmacs containing an msprinter-settings object", - devmode); - } + Lisp_Devmode *dm = XDEVMODE (obj); assert (NILP (dm->device)); } @@ -1209,20 +1195,19 @@ internal_hash (dm->printer_name, depth + 1)); } -DEFINE_LRECORD_IMPLEMENTATION ("msprinter-settings", devmode, - 0, /*dumpable-flag*/ - mark_devmode, print_devmode, finalize_devmode, - equal_devmode, hash_devmode, - devmode_description, - Lisp_Devmode); +DEFINE_NODUMP_LISP_OBJECT ("msprinter-settings", devmode, + mark_devmode, print_devmode, + finalize_devmode, + equal_devmode, hash_devmode, + devmode_description, + Lisp_Devmode); static Lisp_Object allocate_devmode (DEVMODEW* src_devmode, int do_copy, Lisp_Object src_name, struct device *d) { - Lisp_Devmode *dm; - - dm = ALLOC_LCRECORD_TYPE (Lisp_Devmode, &lrecord_devmode); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (devmode); + Lisp_Devmode *dm = XDEVMODE (obj); if (d) dm->device = wrap_device (d); @@ -1241,7 +1226,7 @@ dm->devmode = src_devmode; } - return wrap_devmode (dm); + return obj; } DEFUN ("msprinter-settings-copy", Fmsprinter_settings_copy, 1, 1, 0, /* @@ -1377,11 +1362,11 @@ void syms_of_device_mswindows (void) { - INIT_LRECORD_IMPLEMENTATION (devmode); + INIT_LISP_OBJECT (devmode); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (mswindows_device); - INIT_LRECORD_IMPLEMENTATION (msprinter_device); + INIT_LISP_OBJECT (mswindows_device); + INIT_LISP_OBJECT (msprinter_device); #endif /* NEW_GC */ DEFSUBR (Fmsprinter_get_settings);
--- a/src/device-tty.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device-tty.c Mon Mar 29 21:28:13 2010 -0500 @@ -49,18 +49,16 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("tty-device", tty_device, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - tty_device_data_description_1, - Lisp_Tty_Device); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("tty-device", tty_device, + 0, tty_device_data_description_1, + Lisp_Tty_Device); #endif /* NEW_GC */ static void allocate_tty_device_struct (struct device *d) { #ifdef NEW_GC - d->device_data = alloc_lrecord_type (struct tty_device, &lrecord_tty_device); + d->device_data = XTTY_DEVICE (ALLOC_NORMAL_LISP_OBJECT (tty_device)); #else /* not NEW_GC */ d->device_data = xnew_and_zero (struct tty_device); #endif /* not NEW_GC */ @@ -118,7 +116,10 @@ free_tty_device_struct (struct device *d) { if (d->device_data) - xfree (d->device_data); + { + xfree (d->device_data); + d->device_data = 0; + } } static void @@ -208,7 +209,7 @@ syms_of_device_tty (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (tty_device); + INIT_LISP_OBJECT (tty_device); #endif /* NEW_GC */ DEFSYMBOL (Qmake_device_early_tty_entry_point);
--- a/src/device-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -111,11 +111,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("x-device", x_device, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - x_device_data_description_1, - Lisp_X_Device); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("x-device", x_device, + 0, x_device_data_description_1, + Lisp_X_Device); #else /* not NEW_GC */ extern const struct sized_memory_description x_device_data_description; @@ -230,7 +228,7 @@ allocate_x_device_struct (struct device *d) { #ifdef NEW_GC - d->device_data = alloc_lrecord_type (struct x_device, &lrecord_x_device); + d->device_data = XX_DEVICE (ALLOC_NORMAL_LISP_OBJECT (x_device)); #else /* not NEW_GC */ d->device_data = xnew_and_zero (struct x_device); #endif /* not NEW_GC */ @@ -2108,7 +2106,7 @@ syms_of_device_x (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (x_device); + INIT_LISP_OBJECT (x_device); #endif /* NEW_GC */ DEFSUBR (Fx_debug_mode);
--- a/src/device.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Generic device functions. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. Copyright (C) 1994, 1995 Free Software Foundation, Inc. - Copyright (C) 1995, 1996, 2002 Ben Wing. + Copyright (C) 1995, 1996, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -160,20 +160,19 @@ struct device *d = XDEVICE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (d->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (d->name)); write_fmt_string (printcharfun, "#<%s-device", !DEVICE_LIVE_P (d) ? "dead" : DEVICE_TYPE_NAME (d)); if (DEVICE_LIVE_P (d) && !NILP (DEVICE_CONNECTION (d))) write_fmt_string_lisp (printcharfun, " on %S", 1, DEVICE_CONNECTION (d)); - write_fmt_string (printcharfun, " 0x%x>", d->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } -DEFINE_LRECORD_IMPLEMENTATION ("device", device, - 0, /*dumpable-flag*/ - mark_device, print_device, 0, 0, 0, - device_description, - struct device); +DEFINE_NODUMP_LISP_OBJECT ("device", device, + mark_device, print_device, 0, 0, 0, + device_description, + struct device); int valid_device_class_p (Lisp_Object class_) @@ -201,7 +200,7 @@ static void nuke_all_device_slots (struct device *d, Lisp_Object zap) { - ZERO_LCRECORD (d); + zero_nonsized_lisp_object (wrap_device (d)); #define MARKED_SLOT(x) d->x = zap; #include "devslots.h" @@ -210,12 +209,11 @@ static struct device * allocate_device (Lisp_Object console) { - Lisp_Object device; - struct device *d = ALLOC_LCRECORD_TYPE (struct device, &lrecord_device); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (device); + struct device *d = XDEVICE (obj); struct gcpro gcpro1; - device = wrap_device (d); - GCPRO1 (device); + GCPRO1 (obj); nuke_all_device_slots (d, Qnil); @@ -1398,7 +1396,7 @@ void syms_of_device (void) { - INIT_LRECORD_IMPLEMENTATION (device); + INIT_LISP_OBJECT (device); DEFSUBR (Fvalid_device_class_p); DEFSUBR (Fdevice_class_list);
--- a/src/device.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/device.h Mon Mar 29 21:28:13 2010 -0500 @@ -31,7 +31,7 @@ struct device; -DECLARE_LRECORD (device, struct device); +DECLARE_LISP_OBJECT (device, struct device); #define XDEVICE(x) XRECORD (x, device, struct device) #define wrap_device(p) wrap_record (p, device) #define DEVICEP(x) RECORDP (x, device)
--- a/src/dialog-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/dialog-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -183,12 +183,11 @@ return data->callbacks; } -DEFINE_LRECORD_IMPLEMENTATION ("mswindows-dialog-id", mswindows_dialog_id, - 0, /* dump-able flag */ - mark_mswindows_dialog_id, - internal_object_printer, 0, 0, 0, - mswindows_dialog_id_description, - struct mswindows_dialog_id); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("mswindows-dialog-id", + mswindows_dialog_id, + mark_mswindows_dialog_id, + mswindows_dialog_id_description, + struct mswindows_dialog_id); /* Dialog procedure */ static BOOL CALLBACK @@ -442,6 +441,7 @@ { ret = tstr_to_local_file_format (pd.unknown_fname); xfree (pd.unknown_fname); + pd.unknown_fname = 0; } else while (1) signal_quit (); @@ -748,13 +748,9 @@ GC-protected and thus it is put into a statically protected list. */ { - Lisp_Object dialog_data; int i; - struct mswindows_dialog_id *did = - ALLOC_LCRECORD_TYPE (struct mswindows_dialog_id, - &lrecord_mswindows_dialog_id); - - dialog_data = wrap_mswindows_dialog_id (did); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (mswindows_dialog_id); + struct mswindows_dialog_id *did = XMSWINDOWS_DIALOG_ID (obj); did->frame = wrap_frame (f); did->callbacks = make_vector (Dynarr_length (dialog_items), Qunbound); @@ -767,16 +763,16 @@ qxeCreateDialogIndirectParam (NULL, (LPDLGTEMPLATE) Dynarr_begin (template_), FRAME_MSWINDOWS_HANDLE (f), dialog_proc, - (LPARAM) STORE_LISP_IN_VOID (dialog_data)); + (LPARAM) STORE_LISP_IN_VOID (obj)); if (!did->hwnd) /* Something went wrong creating the dialog */ signal_error (Qdialog_box_error, "Creating dialog", keys); - Vdialog_data_list = Fcons (dialog_data, Vdialog_data_list); + Vdialog_data_list = Fcons (obj, Vdialog_data_list); /* Cease protection and free dynarrays */ unbind_to (unbind_count); - return dialog_data; + return obj; } } @@ -814,7 +810,7 @@ void syms_of_dialog_mswindows (void) { - INIT_LRECORD_IMPLEMENTATION (mswindows_dialog_id); + INIT_LISP_OBJECT (mswindows_dialog_id); DEFKEYWORD (Q_initial_directory); DEFKEYWORD (Q_initial_filename);
--- a/src/dialog-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/dialog-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Implements elisp-programmable dialog boxes -- X interface. Copyright (C) 1993, 1994 Free Software Foundation, Inc. Copyright (C) 1995 Tinker Systems and INS Engineering Corp. - Copyright (C) 2000, 2002, 2003 Ben Wing. + Copyright (C) 2000, 2002, 2003, 2010 Ben Wing. This file is part of XEmacs.
--- a/src/dired.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/dired.c Mon Mar 29 21:28:13 2010 -0500 @@ -508,7 +508,7 @@ return bestmatch; if (matchcount == 1 && bestmatchsize == file_name_length) return Qt; - return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize)); + return Fsubseq (bestmatch, Qzero, make_int (bestmatchsize)); } @@ -772,7 +772,7 @@ return bestmatch; if (matchcount == 1 && bestmatchsize == user_name_length) return Qt; - return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize)); + return Fsubseq (bestmatch, Qzero, make_int (bestmatchsize)); }
--- a/src/dumper.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/dumper.c Mon Mar 29 21:28:13 2010 -0500 @@ -800,7 +800,7 @@ break; } #ifdef NEW_GC - case XD_LISP_OBJECT_BLOCK_PTR: + case XD_INLINE_LISP_OBJECT_BLOCK_PTR: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); @@ -1073,7 +1073,7 @@ break; } #ifdef NEW_GC - case XD_LISP_OBJECT_BLOCK_PTR: + case XD_INLINE_LISP_OBJECT_BLOCK_PTR: #endif /* NEW_GC */ case XD_OPAQUE_DATA_PTR: case XD_ASCII_STRING: @@ -1314,7 +1314,7 @@ case XD_LONG: case XD_INT_RESET: break; - case XD_LISP_OBJECT_BLOCK_PTR: + case XD_INLINE_LISP_OBJECT_BLOCK_PTR: case XD_OPAQUE_DATA_PTR: case XD_ASCII_STRING: case XD_BLOCK_PTR:
--- a/src/dynarr.c Tue Feb 23 07:28:35 2010 -0600 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000 @@ -1,526 +0,0 @@ -/* Support for dynamic arrays. - Copyright (C) 1993 Sun Microsystems, Inc. - Copyright (C) 2002, 2003, 2004, 2005, 2010 Ben Wing. - -This file is part of XEmacs. - -XEmacs is free software; you can redistribute 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. - -XEmacs is distributed in the hope that it will be useful, but WITHOUT -ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -for more details. - -You should have received a copy of the GNU General Public License -along with XEmacs; see the file COPYING. If not, write to -the Free Software Foundation, Inc., 59 Temple Place - Suite 330, -Boston, MA 02111-1307, USA. */ - -/* Synched up with: Not in FSF. */ - -/* Written by Ben Wing, December 1993. */ - -/* - -A "dynamic array" or "dynarr" is a contiguous array of fixed-size elements -where there is no upper limit (except available memory) on the number of -elements in the array. Because the elements are maintained contiguously, -space is used efficiently (no per-element pointers necessary) and random -access to a particular element is in constant time. At any one point, the -block of memory that holds the array has an upper limit; if this limit is -exceeded, the memory is realloc()ed into a new array that is twice as big. -Assuming that the time to grow the array is on the order of the new size of -the array block, this scheme has a provably constant amortized time -\(i.e. average time over all additions). - -When you add elements or retrieve elements, pointers are used. Note that -the element itself (of whatever size it is), and not the pointer to it, -is stored in the array; thus you do not have to allocate any heap memory -on your own. Also, returned pointers are only guaranteed to be valid -until the next operation that changes the length of the array. - -This is a container object. Declare a dynamic array of a specific type -as follows: - - typedef struct - { - Dynarr_declare (mytype); - } mytype_dynarr; - -Use the following functions/macros: - - - ************* Dynarr creation ************* - - void *Dynarr_new(type) - [MACRO] Create a new dynamic-array object, with each element of the - specified type. The return value is cast to (type##_dynarr). - This requires following the convention that types are declared in - such a way that this type concatenation works. In particular, TYPE - must be a symbol, not an arbitrary C type. To make dynarrs of - complex types, a typedef must be declared, e.g. - - typedef unsigned char *unsigned_char_ptr; - - and then you can say - - unsigned_char_ptr_dynarr *dyn = Dynarr_new (unsigned_char_ptr); - - void *Dynarr_new2(dynarr_type, type) - [MACRO] Create a new dynamic-array object, with each element of the - specified type. The array itself is of type DYNARR_TYPE. This makes - it possible to create dynarrs over complex types without the need - to create typedefs, as described above. Use is as follows: - - ucharptr_dynarr *dyn = Dynarr_new2 (ucharptr_dynarr *, unsigned char *); - - Dynarr_free(d) - Destroy a dynamic array and the memory allocated to it. - - ************* Dynarr access ************* - - type Dynarr_at(d, i) - [MACRO] Return the element at the specified index. The index must be - between 0 and Dynarr_largest(d), inclusive. With error-checking - enabled, bounds checking on the index is in the form of asserts() -- - an out-of-bounds index causes an abort. The element itself is - returned, not a pointer to it. - - type *Dynarr_atp(d, i) - [MACRO] Return a pointer to the element at the specified index. - Restrictions and bounds checking on the index is as for Dynarr_at. - The pointer may not be valid after an element is added to or - (conceivably) removed from the array, because this may trigger a - realloc() performed on the underlying dynarr storage, which may - involve moving the entire underlying storage to a new location in - memory. - - type *Dynarr_begin(d) - [MACRO] Return a pointer to the first element in the dynarr. See - Dynarr_atp() for warnings about when the pointer might become invalid. - - type *Dynarr_lastp(d) - [MACRO] Return a pointer to the last element in the dynarr. See - Dynarr_atp() for warnings about when the pointer might become invalid. - - type *Dynarr_past_lastp(d) - [MACRO] Return a pointer to the beginning of the element just past the - last one. WARNING: This may not point to valid memory; however, the - byte directly before will be pointer will be valid memory. This macro - might be useful for various reasons, e.g. as a stopping point in a loop - (although Dynarr_lastp() could be used just as well) or as a place to - start writing elements if Dynarr_length() < Dynarr_largest(). - - ************* Dynarr length/size retrieval and setting ************* - - int Dynarr_length(d) - [MACRO] Return the number of elements currently in a dynamic array. - - int Dynarr_largest(d) - [MACRO] Return the maximum value that Dynarr_length(d) would - ever have returned. This is used esp. in the redisplay code, - which reuses dynarrs for performance reasons. - - int Dynarr_max(d) - [MACRO] Return the maximum number of elements that can fit in the - dynarr before it needs to be resized. - - Note that Dynarr_length(d) <= Dynarr_largest(d) <= Dynarr_max(d). - - Bytecount Dynarr_sizeof(d) - [MACRO] Return the total size of the elements currently in dynarr - D. This - - Dynarr_set_lengthr(d, len) - [MACRO] Set the length of D to LEN, which must be between 0 and - Dynarr_largest(d), inclusive. With error-checking enabled, an - assertion failure will result from trying to set the length - to less than zero or greater than Dynarr_largest(d). The - restriction to Dynarr_largest() is to ensure that - - Dynarr_set_length(d, len) - [MACRO] Set the length of D to LEN, resizing the dynarr as - necessary to make sure enough space is available. there are no - restrictions on LEN other than available memory and that it must - be at least 0. Note that - - Dynarr_set_length_and_zero(d, len) - [MACRO] Like Dynarr_set_length(d, len) but also, if increasing - the length, zero out the memory between the old and new lengths, - i.e. starting just past the previous last element and up through - the new last element. - - Dynarr_incrementr(d) - [MACRO] Increments the length of D by 1. Equivalent to - Dynarr_set_lengthr(d, Dynarr_length(d) + 1). - - Dynarr_increment(d) - [MACRO] Increments the length of D by 1. Equivalent to - Dynarr_set_length(d, Dynarr_length(d) + 1). - - Dynarr_reset(d) - [MACRO] Reset the length of a dynamic array to 0. - - Dynarr_resize(d, maxval) - Resize the internal dynarr storage to so that it can hold at least - MAXVAL elements. Resizing is done using a geometric series - (repeatedly multiply the old maximum by a constant, normally 1.5, - till a large enough size is reached), so this will be efficient - even if resizing larger by one element at a time. This is mostly - an internal function. - - - - ************* Adding/deleting elements to/from a dynarr ************* - - Dynarr_add(d, el) - [MACRO] Add an element to the end of a dynamic array. EL is a pointer - to the element; the element itself is stored in the array, however. - No function call is performed unless the array needs to be resized. - - Dynarr_add_many(d, base, len) - [MACRO] Add LEN elements to the end of the dynamic array. The elements - should be contiguous in memory, starting at BASE. If BASE if NULL, - just make space for the elements; don't actually add them. - - Dynarr_prepend_many(d, base, len) - [MACRO] Prepend LEN elements to the beginning of the dynamic array. - The elements should be contiguous in memory, starting at BASE. - If BASE if NULL, just make space for the elements; don't actually - add them. - - Dynarr_insert_many(d, base, len, pos) - Insert LEN elements to the dynamic array starting at position - POS. The elements should be contiguous in memory, starting at BASE. - If BASE if NULL, just make space for the elements; don't actually - add them. - - type Dynarr_pop(d) - [MACRO] Pop the last element off the dynarr and return it. - - Dynarr_delete(d, i) - [MACRO] Delete an element from the dynamic array at position I. - - Dynarr_delete_many(d, pos, len) - Delete LEN elements from the dynamic array starting at position - POS. - - Dynarr_zero_many(d, pos, len) - Zero out LEN elements in the dynarr D starting at position POS. - - Dynarr_delete_by_pointer(d, p) - [MACRO] Delete an element from the dynamic array at pointer P, - which must point within the block of memory that stores the data. - P should be obtained using Dynarr_atp(). - - ************* Dynarr locking ************* - - Dynarr_lock(d) - Lock the dynarr against further locking or writing. With error-checking - enabled, any attempts to write into a locked dynarr or re-lock an - already locked one will cause an assertion failure and abort. - - Dynarr_unlock(d) - Unlock a locked dynarr, allowing writing into it. - - ************* Dynarr global variables ************* - - Dynarr_min_size - Minimum allowable size for a dynamic array when it is resized. - -*/ - -#include <config.h> -#include "lisp.h" - -static const struct memory_description const_Ascbyte_ptr_description_1[] = { - { XD_ASCII_STRING, 0 }, - { XD_END } -}; - -const struct sized_memory_description const_Ascbyte_ptr_description = { - sizeof (const Ascbyte *), - const_Ascbyte_ptr_description_1 -}; - -static const struct memory_description const_Ascbyte_ptr_dynarr_description_1[] = { - XD_DYNARR_DESC (const_Ascbyte_ptr_dynarr, &const_Ascbyte_ptr_description), - { XD_END } -}; - -const struct sized_memory_description const_Ascbyte_ptr_dynarr_description = { - sizeof (const_Ascbyte_ptr_dynarr), - const_Ascbyte_ptr_dynarr_description_1 -}; - - -static Elemcount Dynarr_min_size = 8; - -static void -Dynarr_realloc (Dynarr *dy, Elemcount new_size) -{ - if (DUMPEDP (dy->base)) - { - void *new_base = malloc (new_size * Dynarr_elsize (dy)); - memcpy (new_base, dy->base, - (Dynarr_max (dy) < new_size ? Dynarr_max (dy) : new_size) * - Dynarr_elsize (dy)); - dy->base = new_base; - } - else - dy->base = xrealloc (dy->base, new_size * Dynarr_elsize (dy)); -} - -void * -Dynarr_newf (Bytecount elsize) -{ - Dynarr *d = xnew_and_zero (Dynarr); - d->elsize_ = elsize; - - return d; -} - -#ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("dynarr", dynarr, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - 0, - Dynarr); - -static void -Dynarr_lisp_realloc (Dynarr *dy, Elemcount new_size) -{ - void *new_base = alloc_lrecord_array (Dynarr_elsize (dy), new_size, - dy->lisp_imp); - if (dy->base) - memcpy (new_base, dy->base, - (Dynarr_max (dy) < new_size ? Dynarr_max (dy) : new_size) * - Dynarr_elsize (dy)); - dy->base = new_base; -} - -void * -Dynarr_lisp_newf (Bytecount elsize, - const struct lrecord_implementation *dynarr_imp, - const struct lrecord_implementation *imp) -{ - Dynarr *d = (Dynarr *) alloc_lrecord (sizeof (Dynarr), dynarr_imp); - d->elsize_ = elsize; - d->lisp_imp = imp; - - return d; -} -#endif /* not NEW_GC */ - -void -Dynarr_resize (void *d, Elemcount size) -{ - Elemcount newsize; - double multiplier; - Dynarr *dy = (Dynarr *) Dynarr_verify (d); - - if (Dynarr_max (dy) <= 8) - multiplier = 2; - else - multiplier = 1.5; - - for (newsize = Dynarr_max (dy); newsize < size;) - newsize = max (Dynarr_min_size, (Elemcount) (multiplier * newsize)); - - /* Don't do anything if the array is already big enough. */ - if (newsize > Dynarr_max (dy)) - { -#ifdef NEW_GC - if (dy->lisp_imp) - Dynarr_lisp_realloc (dy, newsize); - else - Dynarr_realloc (dy, newsize); -#else /* not NEW_GC */ - Dynarr_realloc (dy, newsize); -#endif /* not NEW_GC */ - dy->max_ = newsize; - } -} - -/* Add a number of contiguous elements to the array starting at POS. */ - -void -Dynarr_insert_many (void *d, const void *base, Elemcount len, Elemcount pos) -{ - Dynarr *dy = Dynarr_verify_mod (d); - Elemcount old_len = Dynarr_length (dy); - - /* #### This could conceivably be wrong, if code wants to access stuff - between len and largest. */ - dynarr_checking_assert (pos >= 0 && pos <= old_len); - dynarr_checking_assert (len >= 0); - Dynarr_increase_length (dy, old_len + len); - - if (pos != old_len) - { - memmove ((Rawbyte *) dy->base + (pos + len)*Dynarr_elsize (dy), - (Rawbyte *) dy->base + pos*Dynarr_elsize (dy), - (old_len - pos)*Dynarr_elsize (dy)); - } - /* Some functions call us with a value of 0 to mean "reserve space but - don't write into it" */ - if (base) - memcpy ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), base, - len*Dynarr_elsize (dy)); -} - -void -Dynarr_delete_many (void *d, Elemcount pos, Elemcount len) -{ - Dynarr *dy = Dynarr_verify_mod (d); - - dynarr_checking_assert (pos >= 0 && len >= 0 && - pos + len <= Dynarr_length (dy)); - - memmove ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), - (Rawbyte *) dy->base + (pos + len)*Dynarr_elsize (dy), - (Dynarr_length (dy) - pos - len)*Dynarr_elsize (dy)); - - Dynarr_set_length_1 (dy, Dynarr_length (dy) - len); -} - -void -Dynarr_free (void *d) -{ - Dynarr *dy = (Dynarr *) d; - -#ifdef NEW_GC - if (dy->base && !DUMPEDP (dy->base)) - { - if (!dy->lisp_imp) - xfree (dy->base); - } - if(!DUMPEDP (dy)) - { - if (!dy->lisp_imp) - xfree (dy); - } -#else /* not NEW_GC */ - if (dy->base && !DUMPEDP (dy->base)) - xfree (dy->base); - if(!DUMPEDP (dy)) - xfree (dy); -#endif /* not NEW_GC */ -} - -#ifdef MEMORY_USAGE_STATS - -/* Return memory usage for dynarr D. The returned value is the total - amount of bytes actually being used for the dynarr, including all - overhead. The extra amount of space in the dynarr that is - allocated beyond what was requested is returned in DYNARR_OVERHEAD - in STATS. The extra amount of space that malloc() allocates beyond - what was requested of it is returned in MALLOC_OVERHEAD in STATS. - See the comment above the definition of this structure. */ - -Bytecount -Dynarr_memory_usage (void *d, struct overhead_stats *stats) -{ - Bytecount total = 0; - Dynarr *dy = (Dynarr *) d; - - /* We have to be a bit tricky here because not all of the - memory that malloc() will claim as "requested" was actually - requested. */ - - if (dy->base) - { - Bytecount malloc_used = - malloced_storage_size (dy->base, Dynarr_elsize (dy) * Dynarr_max (dy), - 0); - /* #### This may or may not be correct. Some dynarrs would - prefer that we use dy->len instead of dy->largest here. */ - Bytecount was_requested = Dynarr_elsize (dy) * Dynarr_largest (dy); - Bytecount dynarr_overhead = - Dynarr_elsize (dy) * (Dynarr_max (dy) - Dynarr_largest (dy)); - - total += malloc_used; - stats->was_requested += was_requested; - stats->dynarr_overhead += dynarr_overhead; - /* And the remainder must be malloc overhead. */ - stats->malloc_overhead += - malloc_used - was_requested - dynarr_overhead; - } - - total += malloced_storage_size (d, sizeof (*dy), stats); - - return total; -} - -#endif /* MEMORY_USAGE_STATS */ - -/* Version of malloc() that will be extremely efficient when allocation - nearly always occurs in LIFO (stack) order. - - #### Perhaps shouldn't be in this file, but where else? */ - -typedef struct -{ - Dynarr_declare (char_dynarr *); -} char_dynarr_dynarr; - -char_dynarr_dynarr *stack_like_free_list; -char_dynarr_dynarr *stack_like_in_use_list; - -void * -stack_like_malloc (Bytecount size) -{ - char_dynarr *this_one; - if (!stack_like_free_list) - { - stack_like_free_list = Dynarr_new2 (char_dynarr_dynarr, - char_dynarr *); - stack_like_in_use_list = Dynarr_new2 (char_dynarr_dynarr, - char_dynarr *); - } - - if (Dynarr_length (stack_like_free_list) > 0) - this_one = Dynarr_pop (stack_like_free_list); - else - this_one = Dynarr_new (char); - Dynarr_add (stack_like_in_use_list, this_one); - Dynarr_reset (this_one); - Dynarr_add_many (this_one, 0, size); - return Dynarr_begin (this_one); -} - -void -stack_like_free (void *val) -{ - Elemcount len = Dynarr_length (stack_like_in_use_list); - assert (len > 0); - /* The vast majority of times, we will be called in a last-in first-out - order, and the item at the end of the list will be the one we're - looking for, so just check for this first and avoid any function - calls. */ - if (Dynarr_begin (Dynarr_at (stack_like_in_use_list, len - 1)) == val) - { - char_dynarr *this_one = Dynarr_pop (stack_like_in_use_list); - Dynarr_add (stack_like_free_list, this_one); - } - else - { - /* Find the item and delete it. */ - int i; - assert (len >= 2); - for (i = len - 2; i >= 0; i--) - if (Dynarr_begin (Dynarr_at (stack_like_in_use_list, i)) == - val) - { - char_dynarr *this_one = Dynarr_at (stack_like_in_use_list, i); - Dynarr_add (stack_like_free_list, this_one); - Dynarr_delete (stack_like_in_use_list, i); - return; - } - - ABORT (); - } -}
--- a/src/elhash.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/elhash.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Implementation of the hash table lisp object type. Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - Copyright (C) 1995, 1996, 2002, 2004 Ben Wing. + Copyright (C) 1995, 1996, 2002, 2004, 2010 Ben Wing. Copyright (C) 1997 Free Software Foundation, Inc. This file is part of XEmacs. @@ -81,10 +81,11 @@ #include "lisp.h" #include "bytecode.h" #include "elhash.h" +#include "gc.h" #include "opaque.h" Lisp_Object Qhash_tablep; -static Lisp_Object Qhashtable, Qhash_table; +static Lisp_Object Qhashtable, Qhash_table, Qmake_hash_table; static Lisp_Object Qweakness, Qvalue, Qkey_or_value, Qkey_and_value; static Lisp_Object Vall_weak_hash_tables; static Lisp_Object Qrehash_size, Qrehash_threshold; @@ -96,7 +97,7 @@ struct Lisp_Hash_Table { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Elemcount size; Elemcount count; Elemcount rehash_count; @@ -280,6 +281,28 @@ return XHASH_TABLE (hash_table)->count; } +#ifdef MEMORY_USAGE_STATS + +struct hash_table_stats +{ + struct usage_stats u; + Bytecount hentries; +}; + +static void +hash_table_memory_usage (Lisp_Object hashtab, + struct generic_usage_stats *gustats) +{ + Lisp_Hash_Table *ht = XHASH_TABLE (hashtab); + struct hash_table_stats *stats = (struct hash_table_stats *) gustats; + stats->hentries += + malloced_storage_size (ht->hentries, + sizeof (htentry) * (ht->size + 1), + &stats->u); +} + +#endif /* MEMORY_USAGE_STATS */ + /* Printing hash tables. @@ -395,25 +418,24 @@ if (print_readably) write_ascstring (printcharfun, ")"); else - write_fmt_string (printcharfun, " 0x%x>", ht->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } +#ifdef ERROR_CHECK_STRUCTURES +#define USED_IF_ERROR_CHECK_STRUCTURES(x) x +#else +#define USED_IF_ERROR_CHECK_STRUCTURES(x) UNUSED (x) +#endif + #ifndef NEW_GC static void free_hentries (htentry *hentries, -#ifdef ERROR_CHECK_STRUCTURES - size_t size -#else /* not ERROR_CHECK_STRUCTURES) */ - size_t UNUSED (size) -#endif /* not ERROR_CHECK_STRUCTURES) */ - ) + Elemcount USED_IF_ERROR_CHECK_STRUCTURES (size)) { #ifdef ERROR_CHECK_STRUCTURES /* Ensure a crash if other code uses the discarded entries afterwards. */ - htentry *e, *sentinel; - - for (e = hentries, sentinel = e + size; e < sentinel; e++) - * (unsigned long *) e = 0xdeadbeef; /* -559038737 base 10 */ + deadbeef_memory (hentries, + (Rawbyte *) (hentries + size) - (Rawbyte *) hentries); #endif if (!DUMPEDP (hentries)) @@ -421,14 +443,11 @@ } static void -finalize_hash_table (void *header, int for_disksave) +finalize_hash_table (Lisp_Object obj) { - if (!for_disksave) - { - Lisp_Hash_Table *ht = (Lisp_Hash_Table *) header; - free_hentries (ht->hentries, ht->size); - ht->hentries = 0; - } + Lisp_Hash_Table *ht = XHASH_TABLE (obj); + free_hentries (ht->hentries, ht->size); + ht->hentries = 0; } #endif /* not NEW_GC */ @@ -455,20 +474,18 @@ htentry_weak_description_1 }; -DEFINE_LRECORD_IMPLEMENTATION ("hash-table-entry", hash_table_entry, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - htentry_description_1, - Lisp_Hash_Table_Entry); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("hash-table-entry", hash_table_entry, + 0, htentry_description_1, + Lisp_Hash_Table_Entry); #endif /* NEW_GC */ static const struct memory_description htentry_union_description_1[] = { /* Note: XD_INDIRECT in this table refers to the surrounding table, and so this will work. */ #ifdef NEW_GC - { XD_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, + { XD_INLINE_LISP_OBJECT_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), { &htentry_description } }, - { XD_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), + { XD_INLINE_LISP_OBJECT_BLOCK_PTR, 0, XD_INDIRECT (0, 1), { &htentry_weak_description }, XD_FLAG_UNION_DEFAULT_ENTRY }, #else /* not NEW_GC */ { XD_BLOCK_PTR, HASH_TABLE_NON_WEAK, XD_INDIRECT (0, 1), @@ -493,22 +510,12 @@ { XD_END } }; -#ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, - 1, /*dumpable-flag*/ - mark_hash_table, print_hash_table, - 0, hash_table_equal, hash_table_hash, - hash_table_description, - Lisp_Hash_Table); -#else /* not NEW_GC */ -DEFINE_LRECORD_IMPLEMENTATION ("hash-table", hash_table, - 1, /*dumpable-flag*/ - mark_hash_table, print_hash_table, - finalize_hash_table, - hash_table_equal, hash_table_hash, - hash_table_description, - Lisp_Hash_Table); -#endif /* not NEW_GC */ +DEFINE_DUMPABLE_LISP_OBJECT ("hash-table", hash_table, + mark_hash_table, print_hash_table, + IF_OLD_GC (finalize_hash_table), + hash_table_equal, hash_table_hash, + hash_table_description, + Lisp_Hash_Table); static Lisp_Hash_Table * xhash_table (Lisp_Object hash_table) @@ -535,6 +542,17 @@ ((double) ht->size * (.6180339887 / (double) sizeof (Lisp_Object))); } +static htentry * +allocate_hash_table_entries (Elemcount size) +{ +#ifdef NEW_GC + return XHASH_TABLE_ENTRY (alloc_lrecord_array + (size, &lrecord_hash_table_entry)); +#else /* not NEW_GC */ + return xnew_array_and_zero (htentry, size); +#endif /* not NEW_GC */ +} + Lisp_Object make_standard_lisp_hash_table (enum hash_table_test test, Elemcount size, @@ -579,8 +597,8 @@ double rehash_threshold, enum hash_table_weakness weakness) { - Lisp_Object hash_table; - Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); + Lisp_Object hash_table = ALLOC_NORMAL_LISP_OBJECT (hash_table); + Lisp_Hash_Table *ht = XHASH_TABLE (hash_table); ht->test_function = test_function; ht->hash_function = hash_function; @@ -602,15 +620,7 @@ compute_hash_table_derived_values (ht); /* We leave room for one never-occupied sentinel htentry at the end. */ -#ifdef NEW_GC - ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), - ht->size + 1, - &lrecord_hash_table_entry); -#else /* not NEW_GC */ - ht->hentries = xnew_array_and_zero (htentry, ht->size + 1); -#endif /* not NEW_GC */ - - hash_table = wrap_hash_table (ht); + ht->hentries = allocate_hash_table_entries (ht->size + 1); if (weakness == HASH_TABLE_NON_WEAK) ht->next_weak = Qunbound; @@ -993,29 +1003,27 @@ */ (int nargs, Lisp_Object *args)) { - int i = 0; - Lisp_Object test = Qnil; - Lisp_Object size = Qnil; - Lisp_Object rehash_size = Qnil; - Lisp_Object rehash_threshold = Qnil; - Lisp_Object weakness = Qnil; - - while (i + 1 < nargs) - { - Lisp_Object keyword = args[i++]; - Lisp_Object value = args[i++]; +#ifdef NO_NEED_TO_HANDLE_21_4_CODE + PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 5, + (test, size, rehash_size, rehash_threshold, weakness), + NULL, weakness = Qunbound), 0); +#else + PARSE_KEYWORDS (Qmake_hash_table, nargs, args, 0, 6, + (test, size, rehash_size, rehash_threshold, weakness, + type), (type = Qunbound, weakness = Qunbound), 0); - if (EQ (keyword, Q_test)) test = value; - else if (EQ (keyword, Q_size)) size = value; - else if (EQ (keyword, Q_rehash_size)) rehash_size = value; - else if (EQ (keyword, Q_rehash_threshold)) rehash_threshold = value; - else if (EQ (keyword, Q_weakness)) weakness = value; - else if (EQ (keyword, Q_type))/*obsolete*/ weakness = value; - else invalid_constant ("Invalid hash table property keyword", keyword); + if (EQ (weakness, Qunbound)) + { + if (EQ (weakness, Qunbound) && !EQ (type, Qunbound)) + { + weakness = type; + } + else + { + weakness = Qnil; + } } - - if (i < nargs) - sferror ("Hash table property requires a value", args[i]); +#endif #define VALIDATE_VAR(var) \ if (!NILP (var)) hash_table_##var##_validate (Q##var, var, ERROR_ME); @@ -1041,27 +1049,21 @@ (hash_table)) { const Lisp_Hash_Table *ht_old = xhash_table (hash_table); - Lisp_Hash_Table *ht = ALLOC_LCRECORD_TYPE (Lisp_Hash_Table, &lrecord_hash_table); - COPY_LCRECORD (ht, ht_old); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (hash_table); + Lisp_Hash_Table *ht = XHASH_TABLE (obj); + copy_lisp_object (obj, hash_table); -#ifdef NEW_GC - ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), - ht_old->size + 1, - &lrecord_hash_table_entry); -#else /* not NEW_GC */ - ht->hentries = xnew_array (htentry, ht_old->size + 1); -#endif /* not NEW_GC */ + /* We leave room for one never-occupied sentinel htentry at the end. */ + ht->hentries = allocate_hash_table_entries (ht_old->size + 1); memcpy (ht->hentries, ht_old->hentries, (ht_old->size + 1) * sizeof (htentry)); - hash_table = wrap_hash_table (ht); - if (! EQ (ht->next_weak, Qunbound)) { ht->next_weak = Vall_weak_hash_tables; - Vall_weak_hash_tables = hash_table; + Vall_weak_hash_tables = obj; } - return hash_table; + return obj; } static void @@ -1075,13 +1077,8 @@ old_entries = ht->hentries; -#ifdef NEW_GC - ht->hentries = (htentry *) alloc_lrecord_array (sizeof (htentry), - new_size + 1, - &lrecord_hash_table_entry); -#else /* not NEW_GC */ - ht->hentries = xnew_array_and_zero (htentry, new_size + 1); -#endif /* not NEW_GC */ + /* We leave room for one never-occupied sentinel htentry at the end. */ + ht->hentries = allocate_hash_table_entries (new_size + 1); new_entries = ht->hentries; compute_hash_table_derived_values (ht); @@ -1107,13 +1104,8 @@ pdump_reorganize_hash_table (Lisp_Object hash_table) { const Lisp_Hash_Table *ht = xhash_table (hash_table); -#ifdef NEW_GC - htentry *new_entries = - (htentry *) alloc_lrecord_array (sizeof (htentry), ht->size + 1, - &lrecord_hash_table_entry); -#else /* not NEW_GC */ - htentry *new_entries = xnew_array_and_zero (htentry, ht->size + 1); -#endif /* not NEW_GC */ + /* We leave room for one never-occupied sentinel htentry at the end. */ + htentry *new_entries = allocate_hash_table_entries (ht->size + 1); htentry *e, *sentinel; for (e = ht->hentries, sentinel = e + ht->size; e < sentinel; e++) @@ -1560,7 +1552,7 @@ Lisp_Object mo_obj = (obj); \ if (!marked_p (mo_obj)) \ { \ - kkcc_gc_stack_push_lisp_object (mo_obj, 0, -1); \ + kkcc_gc_stack_push_lisp_object_0 (mo_obj); \ did_mark = 1; \ } \ } while (0) @@ -1829,6 +1821,14 @@ /************************************************************************/ void +hash_table_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (hash_table, memory_usage); +#endif +} + +void syms_of_elhash (void) { DEFSUBR (Fhash_table_p); @@ -1854,6 +1854,7 @@ DEFSYMBOL_MULTIWORD_PREDICATE (Qhash_tablep); DEFSYMBOL (Qhash_table); DEFSYMBOL (Qhashtable); + DEFSYMBOL (Qmake_hash_table); DEFSYMBOL (Qweakness); DEFSYMBOL (Qvalue); DEFSYMBOL (Qkey_or_value); @@ -1877,11 +1878,20 @@ } void +vars_of_elhash (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY + (hash_table, memusage_stats_list, list1 (intern ("hash-entries"))); +#endif /* MEMORY_USAGE_STATS */ +} + +void init_elhash_once_early (void) { - INIT_LRECORD_IMPLEMENTATION (hash_table); + INIT_LISP_OBJECT (hash_table); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (hash_table_entry); + INIT_LISP_OBJECT (hash_table_entry); #endif /* NEW_GC */ /* This must NOT be staticpro'd */
--- a/src/elhash.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/elhash.h Mon Mar 29 21:28:13 2010 -0500 @@ -25,7 +25,7 @@ typedef struct Lisp_Hash_Table Lisp_Hash_Table; -DECLARE_LRECORD (hash_table, Lisp_Hash_Table); +DECLARE_LISP_OBJECT (hash_table, Lisp_Hash_Table); #define XHASH_TABLE(x) XRECORD (x, hash_table, Lisp_Hash_Table) #define wrap_hash_table(p) wrap_record (p, hash_table) @@ -36,7 +36,7 @@ typedef struct htentry { #ifdef NEW_GC - struct lrecord_header lheader; + NORMAL_LISP_OBJECT_HEADER lheader; #endif /* NEW_GC */ Lisp_Object key; Lisp_Object value; @@ -48,7 +48,7 @@ typedef struct htentry Lisp_Hash_Table_Entry; -DECLARE_LRECORD (hash_table_entry, Lisp_Hash_Table_Entry); +DECLARE_LISP_OBJECT (hash_table_entry, Lisp_Hash_Table_Entry); #define XHASH_TABLE_ENTRY(x) \ XRECORD (x, hash_table_entry, Lisp_Hash_Table_Entry)
--- a/src/emacs.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/emacs.c Mon Mar 29 21:28:13 2010 -0500 @@ -766,6 +766,7 @@ while (argv[elt]) { xfree (argv[elt]); + argv[elt] = 0; elt++; } xfree (argv); @@ -1464,13 +1465,32 @@ /* Make sure that eistrings can be created. */ init_eistring_once_early (); - + } +#ifdef PDUMP + else if (!restart) /* after successful pdump_load() + (note, we are inside ifdef PDUMP) */ + { + reinit_alloc_early (); + reinit_gc_early (); + reinit_symbols_early (); +#ifndef NEW_GC + reinit_opaque_early (); +#endif /* not NEW_GC */ + reinit_eistring_early (); +#ifdef WITH_NUMBER_TYPES + reinit_vars_of_number (); +#endif + } +#endif /* PDUMP */ + + if (!initialized) + { /* Now declare all the symbols and define all the Lisp primitives. The *only* thing that the syms_of_*() functions are allowed to do is call one of the following: - INIT_LRECORD_IMPLEMENTATION() + INIT_LISP_OBJECT() defsymbol(), DEFSYMBOL(), or DEFSYMBOL_MULTIWORD_PREDICATE() defsubr() (i.e. DEFSUBR) deferror(), DEFERROR(), or DEFERROR_STANDARD() @@ -1489,6 +1509,7 @@ #ifdef NEW_GC syms_of_vdb (); #endif /* NEW_GC */ + syms_of_array (); syms_of_buffer (); syms_of_bytecode (); syms_of_callint (); @@ -1538,8 +1559,10 @@ syms_of_frame (); syms_of_general (); syms_of_glyphs (); +#ifdef HAVE_WINDOW_SYSTEM syms_of_glyphs_eimage (); syms_of_glyphs_shared (); +#endif syms_of_glyphs_widget (); syms_of_gui (); syms_of_gutter (); @@ -1547,6 +1570,7 @@ syms_of_intl (); syms_of_keymap (); syms_of_lread (); + syms_of_lstream (); syms_of_macros (); syms_of_marker (); syms_of_md5 (); @@ -1730,7 +1754,36 @@ #if defined (HAVE_POSTGRESQL) && !defined (HAVE_SHLIB) syms_of_postgresql (); #endif - + } + + if (!initialized +#ifdef PDUMP + || !restart +#endif + ) + { + buffer_objects_create (); + casetab_objects_create (); + extent_objects_create (); + face_objects_create (); + frame_objects_create (); + glyph_objects_create (); + hash_table_objects_create (); + lstream_objects_create (); +#ifdef MULE + mule_charset_objects_create (); +#endif +#ifdef HAVE_SCROLLBARS + scrollbar_objects_create (); +#endif +#ifdef HAVE_GTK + ui_gtk_objects_create (); +#endif + window_objects_create (); + } + + if (!initialized) + { /* Now create the subtypes for the types that have them. We do this before the vars_*() because more symbols may get initialized here. */ @@ -1873,7 +1926,9 @@ called before the any calls to the other macros. */ image_instantiator_format_create (); +#ifdef HAVE_WINDOW_SYSTEM image_instantiator_format_create_glyphs_eimage (); +#endif image_instantiator_format_create_glyphs_widget (); #ifdef HAVE_TTY image_instantiator_format_create_glyphs_tty (); @@ -1892,17 +1947,6 @@ else if (!restart) /* after successful pdump_load() (note, we are inside ifdef PDUMP) */ { - reinit_alloc_early (); - reinit_gc_early (); - reinit_symbols_early (); -#ifndef NEW_GC - reinit_opaque_early (); -#endif /* not NEW_GC */ - reinit_eistring_early (); -#ifdef WITH_NUMBER_TYPES - reinit_vars_of_number (); -#endif - reinit_console_type_create_stream (); #ifdef HAVE_TTY reinit_console_type_create_tty (); @@ -2021,8 +2065,8 @@ - make_int() - make_char() - make_extent() - - BASIC_ALLOC_LCRECORD() - - ALLOC_LCRECORD_TYPE() + - ALLOC_NORMAL_LISP_OBJECT() + - ALLOC_SIZED_LISP_OBJECT() - Fcons() - listN() - make_lcrecord_list() @@ -2054,6 +2098,7 @@ vars_of_buffer (); vars_of_bytecode (); vars_of_callint (); + vars_of_casetab (); vars_of_chartab (); vars_of_cmdloop (); vars_of_cmds (); @@ -2074,6 +2119,7 @@ vars_of_dragdrop (); #endif vars_of_editfns (); + vars_of_elhash (); vars_of_emacs (); vars_of_eval (); @@ -2104,7 +2150,9 @@ vars_of_frame (); vars_of_gc (); vars_of_glyphs (); +#ifdef HAVE_WINDOW_SYSTEM vars_of_glyphs_eimage (); +#endif vars_of_glyphs_widget (); vars_of_gui (); vars_of_gutter (); @@ -2299,6 +2347,7 @@ { /* Now do additional vars_of_*() initialization that happens both at dump time and after pdump load. */ + reinit_vars_of_alloc (); reinit_vars_of_buffer (); reinit_vars_of_bytecode (); reinit_vars_of_console (); @@ -2312,7 +2361,6 @@ #endif reinit_vars_of_event_stream (); reinit_vars_of_events (); - reinit_vars_of_extents (); reinit_vars_of_file_coding (); reinit_vars_of_fileio (); #ifdef USE_C_FONT_LOCK @@ -4056,6 +4104,20 @@ in_assert_failed--; } +/* This is called when an assert() fails or when ABORT() is called -- both + of those are defined in the preprocessor to an expansion involving + assert_failed(). */ +void +assert_equal_failed (const Ascbyte *file, int line, EMACS_INT x, EMACS_INT y, + const Ascbyte *exprx, const Ascbyte *expry) +{ + Ascbyte bigstr[1000]; /* #### Could overflow, but avoids any need to do any + allocation, even alloca(), hence safer */ + sprintf (bigstr, "%s (%ld) should == %s (%ld) but doesn't", + exprx, x, expry, y); + assert_failed (file, line, bigstr); +} + /* -------------------------------------- */ /* low-memory notification */ /* -------------------------------------- */
--- a/src/emodules.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/emodules.c Mon Mar 29 21:28:13 2010 -0500 @@ -257,9 +257,13 @@ if (dll_close (modules[mod].dlhandle) == 0) { xfree (modules[mod].soname); + modules[mod].soname = 0; xfree (modules[mod].modname); + modules[mod].modname = 0; xfree (modules[mod].modver); + modules[mod].modver = 0; xfree (modules[mod].modtitle); + modules[mod].modtitle = 0; modules[mod].dlhandle = 0; modules[mod].used = 0; }
--- a/src/eval.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/eval.c Mon Mar 29 21:28:13 2010 -0500 @@ -418,6 +418,29 @@ static Lisp_Object maybe_get_trapping_problems_backtrace (void); + +/* When parsing keyword arguments; is some element of NARGS + :allow-other-keys, and is that element followed by a non-nil Lisp + object? */ + +Boolint +non_nil_allow_other_keys_p (Elemcount offset, int nargs, Lisp_Object *args) +{ + Lisp_Object key, value; + while (offset + 1 < nargs) + { + key = args[offset++]; + value = args[offset++]; + if (EQ (key, Q_allow_other_keys)) + { + /* The ANSI Common Lisp standard says the first value for a given + keyword overrides. */ + return !NILP (value); + } + } + return 0; +} + /************************************************************************/ /* The subr object type */ /************************************************************************/ @@ -432,7 +455,7 @@ const Ascbyte *trailer = subr->prompt ? " (interactive)>" : ">"; if (print_readably) - printing_unreadable_object ("%s%s%s", header, name, trailer); + printing_unreadable_object_fmt ("%s%s%s", header, name, trailer); write_ascstring (printcharfun, header); write_ascstring (printcharfun, name); @@ -444,11 +467,10 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("subr", subr, - 1, /*dumpable-flag*/ - 0, print_subr, 0, 0, 0, - subr_description, - Lisp_Subr); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("subr", subr, + 0, print_subr, 0, 0, 0, + subr_description, + Lisp_Subr); /************************************************************************/ /* Entering the debugger */ @@ -3050,6 +3072,12 @@ } DOESNT_RETURN +invalid_keyword_argument (Lisp_Object function, Lisp_Object keyword) +{ + signal_error_1 (Qinvalid_keyword_argument, list2 (function, keyword)); +} + +DOESNT_RETURN invalid_constant (const Ascbyte *reason, Lisp_Object frob) { signal_error (Qinvalid_constant, reason, frob); @@ -4491,6 +4519,7 @@ Bytecount sizem; struct multiple_value *mv; Elemcount i, allocated_count; + Lisp_Object mvobj; assert (count != 1); @@ -4516,8 +4545,8 @@ sizem = FLEXIBLE_ARRAY_STRUCT_SIZEOF (multiple_value, Lisp_Object, contents, allocated_count); - mv = (multiple_value *) BASIC_ALLOC_LCRECORD (sizem, - &lrecord_multiple_value); + mvobj = ALLOC_SIZED_LISP_OBJECT (sizem, multiple_value); + mv = XMULTIPLE_VALUE (mvobj); mv->count = count; mv->first_desired = first_desired; @@ -4529,7 +4558,7 @@ mv->contents[1 + (i - first_desired)] = Qunbound; } - return wrap_multiple_value (mv); + return mvobj; } void @@ -4576,13 +4605,13 @@ if (print_readably) { - printing_unreadable_object ("multiple values"); + printing_unreadable_object_fmt ("#<multiple values 0x%x>", + LISP_OBJECT_UID (obj)); } - if (0 == count) - { - write_msg_string (printcharfun, "#<zero-length multiple value>"); - } + write_fmt_string (printcharfun, + "#<INTERNAL OBJECT (XEmacs bug?) %d multiple values," + " data (", count); for (index = 0; index < count;) { @@ -4603,9 +4632,11 @@ if (count > 1 && index < count) { - write_ascstring (printcharfun, " ;\n"); + write_ascstring (printcharfun, " "); } } + + write_fmt_string (printcharfun, ") 0x%x>", LISP_OBJECT_UID (obj)); } static Lisp_Object @@ -4623,12 +4654,11 @@ } static Bytecount -size_multiple_value (const void *lheader) +size_multiple_value (Lisp_Object obj) { return FLEXIBLE_ARRAY_STRUCT_SIZEOF (struct multiple_value, Lisp_Object, contents, - ((struct multiple_value *) lheader)-> - allocated_count); + XMULTIPLE_VALUE (obj)->allocated_count); } static const struct memory_description multiple_value_description[] = { @@ -4640,15 +4670,14 @@ { XD_END } }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("multiple-value", multiple_value, - 1, /*dumpable-flag*/ - mark_multiple_value, - print_multiple_value, 0, - 0, /* No equal method. */ - 0, /* No hash method. */ - multiple_value_description, - size_multiple_value, - struct multiple_value); +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("multiple-value", multiple_value, + mark_multiple_value, + print_multiple_value, 0, + 0, /* No equal method. */ + 0, /* No hash method. */ + multiple_value_description, + size_multiple_value, + struct multiple_value); /* Given that FIRST and UPPER are the inclusive lower and exclusive upper bounds for the multiple values we're interested in, modify (or don't) the @@ -7236,8 +7265,8 @@ void syms_of_eval (void) { - INIT_LRECORD_IMPLEMENTATION (subr); - INIT_LRECORD_IMPLEMENTATION (multiple_value); + INIT_LISP_OBJECT (subr); + INIT_LISP_OBJECT (multiple_value); DEFSYMBOL (Qinhibit_quit); DEFSYMBOL (Qautoload);
--- a/src/event-Xt.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/event-Xt.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,6 +2,7 @@ Copyright (C) 1991-5, 1997 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1996, 2001, 2002, 2003, 2010 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -133,8 +134,6 @@ static int last_quit_check_signal_tick_count; -Lisp_Object Qsans_modifiers; - #define THIS_IS_X #include "event-xlike-inc.c" @@ -1898,6 +1897,25 @@ break; case ConfigureNotify: + { + XEvent xev; + + /* Let's eat all events of that type to avoid useless + reconfigurations. */ + while (XCheckTypedWindowEvent + (DEVICE_X_DISPLAY (XDEVICE (FRAME_DEVICE (f))), + XtWindow (FRAME_X_TEXT_WIDGET (f)), + ConfigureNotify, + &xev) + == True); + } + /* #### NOTE: in fact, the frame faces didn't really change, but if some + #### of them have their background-placement property set to + #### absolute, we need a redraw. This is semantically equivalent to + #### changing the background pixmap. -- dvl */ + x_get_frame_text_position (f); + MARK_FRAME_FACES_CHANGED (f); + #ifdef HAVE_XIM XIM_SetGeometry (f); #endif @@ -3024,8 +3042,6 @@ void syms_of_event_Xt (void) { - DEFSYMBOL (Qsans_modifiers); - DEFSYMBOL (Qself_insert_command); } void
--- a/src/event-gtk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/event-gtk.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* The event_stream interface for X11 with gtk, and/or tty frames. Copyright (C) 1991-5, 1997 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1996, 2001, 2002, 2003 Ben Wing. + Copyright (C) 1996, 2001, 2002, 2003, 2010 Ben Wing. Copyright (C) 2000 William Perry. This file is part of XEmacs. @@ -86,8 +86,6 @@ static int last_quit_check_signal_tick_count; -Lisp_Object Qsans_modifiers; - /* * Identify if the keysym is a modifier. This implementation mirrors x.org's * IsModifierKey(), but for GDK keysyms. @@ -1616,7 +1614,6 @@ void syms_of_event_gtk (void) { - DEFSYMBOL (Qsans_modifiers); } void
--- a/src/event-stream.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/event-stream.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,7 +2,7 @@ Copyright (C) 1991, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 1996, 2001, 2002, 2003, 2010 Ben Wing. + Copyright (C) 1995, 1996, 2001, 2002, 2003, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -243,6 +243,8 @@ Lisp_Object Qself_insert_defer_undo; +Lisp_Object Qsans_modifiers; + int in_modal_loop; /* the number of keyboard characters read. callint.c wants this. */ @@ -330,10 +332,6 @@ #define CHECK_COMMAND_BUILDER(x) CHECK_RECORD (x, command_builder) #define CONCHECK_COMMAND_BUILDER(x) CONCHECK_RECORD (x, command_builder) -#ifndef NEW_GC -static Lisp_Object Vcommand_builder_free_list; -#endif /* not NEW_GC */ - static const struct memory_description command_builder_description [] = { { XD_LISP_OBJECT, offsetof (struct command_builder, current_events) }, { XD_LISP_OBJECT, offsetof (struct command_builder, most_current_event) }, @@ -356,25 +354,22 @@ } static void -finalize_command_builder (void *header, int for_disksave) +finalize_command_builder (Lisp_Object obj) { - if (!for_disksave) + struct command_builder *b = XCOMMAND_BUILDER (obj); + if (b->echo_buf) { - struct command_builder *b = (struct command_builder *) header; - if (b->echo_buf) - { - xfree (b->echo_buf); - b->echo_buf = 0; - } + xfree (b->echo_buf); + b->echo_buf = 0; } } -DEFINE_LRECORD_IMPLEMENTATION ("command-builder", command_builder, - 0, /*dumpable-flag*/ - mark_command_builder, internal_object_printer, - finalize_command_builder, 0, 0, - command_builder_description, - struct command_builder); +DEFINE_NODUMP_LISP_OBJECT ("command-builder", command_builder, + mark_command_builder, + internal_object_printer, + finalize_command_builder, 0, 0, + command_builder_description, + struct command_builder); static void reset_command_builder_event_chain (struct command_builder *builder) @@ -389,13 +384,7 @@ Lisp_Object allocate_command_builder (Lisp_Object console, int with_echo_buf) { - Lisp_Object builder_obj = -#ifdef NEW_GC - wrap_pointer_1 (alloc_lrecord_type (struct command_builder, - &lrecord_command_builder)); -#else /* not NEW_GC */ - alloc_managed_lcrecord (Vcommand_builder_free_list); -#endif /* not NEW_GC */ + Lisp_Object builder_obj = ALLOC_NORMAL_LISP_OBJECT (command_builder); struct command_builder *builder = XCOMMAND_BUILDER (builder_obj); builder->console = console; @@ -466,12 +455,7 @@ xfree (builder->echo_buf); builder->echo_buf = NULL; } -#ifdef NEW_GC - free_lrecord (wrap_command_builder (builder)); -#else /* not NEW_GC */ - free_managed_lcrecord (Vcommand_builder_free_list, - wrap_command_builder (builder)); -#endif /* not NEW_GC */ + free_normal_lisp_object (wrap_command_builder (builder)); } static void @@ -1035,10 +1019,6 @@ static Lisp_Object pending_timeout_list, pending_async_timeout_list; -#ifndef NEW_GC -static Lisp_Object Vtimeout_free_list; -#endif /* not NEW_GC */ - static Lisp_Object mark_timeout (Lisp_Object obj) { @@ -1053,10 +1033,9 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("timeout", timeout, - 1, /*dumpable-flag*/ - mark_timeout, internal_object_printer, - 0, 0, 0, timeout_description, Lisp_Timeout); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("timeout", timeout, + mark_timeout, timeout_description, + Lisp_Timeout); /* Generate a timeout and return its ID. */ @@ -1066,12 +1045,7 @@ Lisp_Object function, Lisp_Object object, int async_p) { -#ifdef NEW_GC - Lisp_Object op = - wrap_pointer_1 (alloc_lrecord_type (Lisp_Timeout, &lrecord_timeout)); -#else /* not NEW_GC */ - Lisp_Object op = alloc_managed_lcrecord (Vtimeout_free_list); -#endif /* not NEW_GC */ + Lisp_Object op = ALLOC_NORMAL_LISP_OBJECT (timeout); Lisp_Timeout *timeout = XTIMEOUT (op); EMACS_TIME current_time; EMACS_TIME interval; @@ -1147,7 +1121,7 @@ op = XCAR (rest); timeout = XTIMEOUT (op); /* We make sure to snarf the data out of the timeout object before - we free it with free_managed_lcrecord(). */ + we free it with free_normal_lisp_object(). */ id = timeout->id; *function = timeout->function; *object = timeout->object; @@ -1189,11 +1163,7 @@ *timeout_list = noseeum_cons (op, *timeout_list); } else -#ifdef NEW_GC - free_lrecord (op); -#else /* not NEW_GC */ - free_managed_lcrecord (Vtimeout_free_list, op); -#endif /* not NEW_GC */ + free_normal_lisp_object (op); UNGCPRO; return id; @@ -1230,11 +1200,7 @@ signal_remove_async_interval_timeout (timeout->interval_id); else event_stream_remove_timeout (timeout->interval_id); -#ifdef NEW_GC - free_lrecord (op); -#else /* not NEW_GC */ - free_managed_lcrecord (Vtimeout_free_list, op); -#endif /* not NEW_GC */ + free_normal_lisp_object (op); } } @@ -4875,8 +4841,8 @@ void syms_of_event_stream (void) { - INIT_LRECORD_IMPLEMENTATION (command_builder); - INIT_LRECORD_IMPLEMENTATION (timeout); + INIT_LISP_OBJECT (command_builder); + INIT_LISP_OBJECT (timeout); DEFSYMBOL (Qdisabled); DEFSYMBOL (Qcommand_event_p); @@ -4922,6 +4888,8 @@ DEFSYMBOL (Qnext_event); DEFSYMBOL (Qdispatch_event); + + DEFSYMBOL (Qsans_modifiers); } void @@ -4930,15 +4898,6 @@ recent_keys_ring_index = 0; recent_keys_ring_size = 100; num_input_chars = 0; -#ifndef NEW_GC - Vtimeout_free_list = make_lcrecord_list (sizeof (Lisp_Timeout), - &lrecord_timeout); - staticpro_nodump (&Vtimeout_free_list); - Vcommand_builder_free_list = - make_lcrecord_list (sizeof (struct command_builder), - &lrecord_command_builder); - staticpro_nodump (&Vcommand_builder_free_list); -#endif /* not NEW_GC */ the_low_level_timeout_blocktype = Blocktype_new (struct low_level_timeout_blocktype); something_happened = 0;
--- a/src/events.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/events.c Mon Mar 29 21:28:13 2010 -0500 @@ -62,7 +62,7 @@ /* definition of event object */ /************************************************************************/ -/* #### Ad-hoc hack. Should be part of define_lrecord_implementation */ +/* #### Ad-hoc hack. Should be an object method. */ void clear_event_resource (void) { @@ -74,14 +74,10 @@ deinitialize_event (Lisp_Object ev) { Lisp_Event *event = XEVENT (ev); - int i; - /* Preserve the old UID for this event, for tracking it */ - unsigned int old_uid = event->lheader.uid; - for (i = 0; i < (int) (sizeof (Lisp_Event) / sizeof (int)); i++) - ((int *) event) [i] = 0xdeadbeef; /* -559038737 base 10 */ - set_lheader_implementation (&event->lheader, &lrecord_event); - event->lheader.uid = old_uid; + deadbeef_memory ((Rawbyte *) event + sizeof (event->lheader), + sizeof (*event) - sizeof (event->lheader)); + set_event_type (event, dead_event); SET_EVENT_CHANNEL (event, Qnil); XSET_EVENT_NEXT (ev, Qnil); @@ -91,12 +87,7 @@ void zero_event (Lisp_Event *e) { - /* Preserve the old UID for this event, for tracking it */ - unsigned int old_uid = e->lheader.uid; - - xzero (*e); - set_lheader_implementation (&e->lheader, &lrecord_event); - e->lheader.uid = old_uid; + zero_nonsized_lisp_object (wrap_event (e)); set_event_type (e, empty_event); SET_EVENT_CHANNEL (e, Qnil); SET_EVENT_NEXT (e, Qnil); @@ -212,59 +203,50 @@ #ifdef EVENT_DATA_AS_OBJECTS -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("key-data", key_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - key_data_description, - Lisp_Key_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("key-data", key_data, + 0, internal_object_printer, 0, 0, 0, + key_data_description, + Lisp_Key_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("button-data", button_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - button_data_description, - Lisp_Button_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("button-data", button_data, + 0, internal_object_printer, 0, 0, 0, + button_data_description, + Lisp_Button_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("motion-data", motion_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - motion_data_description, - Lisp_Motion_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("motion-data", motion_data, + 0, internal_object_printer, 0, 0, 0, + motion_data_description, + Lisp_Motion_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("process-data", process_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - process_data_description, - Lisp_Process_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("process-data", process_data, + 0, internal_object_printer, 0, 0, 0, + process_data_description, + Lisp_Process_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("timeout-data", timeout_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - timeout_data_description, - Lisp_Timeout_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("timeout-data", timeout_data, + 0, internal_object_printer, 0, 0, 0, + timeout_data_description, + Lisp_Timeout_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("eval-data", eval_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - eval_data_description, - Lisp_Eval_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("eval-data", eval_data, + 0, internal_object_printer, 0, 0, 0, + eval_data_description, + Lisp_Eval_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("misc-user-data", misc_user_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - misc_user_data_description, - Lisp_Misc_User_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("misc-user-data", misc_user_data, + 0, internal_object_printer, 0, 0, 0, + misc_user_data_description, + Lisp_Misc_User_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("magic-eval-data", magic_eval_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - magic_eval_data_description, - Lisp_Magic_Eval_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("magic-eval-data", magic_eval_data, + 0, internal_object_printer, 0, 0, 0, + magic_eval_data_description, + Lisp_Magic_Eval_Data); -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("magic-data", magic_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - magic_data_description, - Lisp_Magic_Data); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("magic-data", magic_data, + 0, internal_object_printer, 0, 0, 0, + magic_data_description, + Lisp_Magic_Data); #endif /* EVENT_DATA_AS_OBJECTS */ @@ -322,7 +304,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_object ("#<event>"); + printing_unreadable_object_fmt ("#<event 0x%x>", LISP_OBJECT_UID (obj)); switch (XEVENT (obj)->event_type) { @@ -380,7 +362,7 @@ write_ascstring (printcharfun, "#<UNKNOWN-EVENT-TYPE"); break; } - write_ascstring (printcharfun, ">"); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static int @@ -507,11 +489,11 @@ return 0; /* unreached */ } -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("event", event, - 0, /*dumpable-flag*/ - mark_event, print_event, 0, event_equal, - event_hash, event_description, - Lisp_Event); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("event", event, + mark_event, print_event, 0, + event_equal, event_hash, + event_description, + Lisp_Event); DEFUN ("make-event", Fmake_event, 0, 2, 0, /* Return a new event of type TYPE, with properties described by PLIST. @@ -2556,17 +2538,17 @@ void syms_of_events (void) { - INIT_LRECORD_IMPLEMENTATION (event); + INIT_LISP_OBJECT (event); #ifdef EVENT_DATA_AS_OBJECTS - INIT_LRECORD_IMPLEMENTATION (key_data); - INIT_LRECORD_IMPLEMENTATION (button_data); - INIT_LRECORD_IMPLEMENTATION (motion_data); - INIT_LRECORD_IMPLEMENTATION (process_data); - INIT_LRECORD_IMPLEMENTATION (timeout_data); - INIT_LRECORD_IMPLEMENTATION (eval_data); - INIT_LRECORD_IMPLEMENTATION (misc_user_data); - INIT_LRECORD_IMPLEMENTATION (magic_eval_data); - INIT_LRECORD_IMPLEMENTATION (magic_data); + INIT_LISP_OBJECT (key_data); + INIT_LISP_OBJECT (button_data); + INIT_LISP_OBJECT (motion_data); + INIT_LISP_OBJECT (process_data); + INIT_LISP_OBJECT (timeout_data); + INIT_LISP_OBJECT (eval_data); + INIT_LISP_OBJECT (misc_user_data); + INIT_LISP_OBJECT (magic_eval_data); + INIT_LISP_OBJECT (magic_data); #endif /* EVENT_DATA_AS_OBJECTS */ DEFSUBR (Fcharacter_to_event); @@ -2639,7 +2621,7 @@ { Vevent_resource = Qnil; #ifdef NEW_GC - staticpro (&Vevent_resource); + staticpro_nodump (&Vevent_resource); #endif /* NEW_GC */ }
--- a/src/events.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/events.h Mon Mar 29 21:28:13 2010 -0500 @@ -123,7 +123,7 @@ struct Lisp_Key_Data { #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ /* What keysym this is; a character or a symbol. */ Lisp_Object keysym; @@ -186,7 +186,7 @@ #define SET_KEY_DATA_MODIFIERS(d, m) ((d)->modifiers = m) #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (key_data, Lisp_Key_Data); +DECLARE_LISP_OBJECT (key_data, Lisp_Key_Data); #define XKEY_DATA(x) XRECORD (x, key_data, Lisp_Key_Data) #define wrap_key_data(p) wrap_record (p, key_data) #define KEY_DATAP(x) RECORDP (x, key_data) @@ -219,7 +219,7 @@ struct Lisp_Button_Data { #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ /* What button went down or up. */ int button; @@ -232,7 +232,7 @@ typedef struct Lisp_Button_Data Lisp_Button_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (button_data, Lisp_Button_Data); +DECLARE_LISP_OBJECT (button_data, Lisp_Button_Data); #define XBUTTON_DATA(x) XRECORD (x, button_data, Lisp_Button_Data) #define wrap_button_data(p) wrap_record (p, button_data) #define BUTTON_DATAP(x) RECORDP (x, button_data) @@ -271,7 +271,7 @@ struct Lisp_Motion_Data { #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ /* Where it was after it moved (in pixels). */ int x, y; @@ -281,7 +281,7 @@ typedef struct Lisp_Motion_Data Lisp_Motion_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (motion_data, Lisp_Motion_Data); +DECLARE_LISP_OBJECT (motion_data, Lisp_Motion_Data); #define XMOTION_DATA(x) XRECORD (x, motion_data, Lisp_Motion_Data) #define wrap_motion_data(p) wrap_record (p, motion_data) #define MOTION_DATAP(x) RECORDP (x, motion_data) @@ -313,7 +313,7 @@ struct Lisp_Process_Data { #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ /* the XEmacs "process" object in question */ Lisp_Object process; @@ -321,7 +321,7 @@ typedef struct Lisp_Process_Data Lisp_Process_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (process_data, Lisp_Process_Data); +DECLARE_LISP_OBJECT (process_data, Lisp_Process_Data); #define XPROCESS_DATA(x) XRECORD (x, process_data, Lisp_Process_Data) #define wrap_process_data(p) wrap_record (p, process_data) #define PROCESS_DATAP(x) RECORDP (x, process_data) @@ -352,7 +352,7 @@ object The object passed to that function. */ #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ int interval_id; int id_number; @@ -362,7 +362,7 @@ typedef struct Lisp_Timeout_Data Lisp_Timeout_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (timeout_data, Lisp_Timeout_Data); +DECLARE_LISP_OBJECT (timeout_data, Lisp_Timeout_Data); #define XTIMEOUT_DATA(x) XRECORD (x, timeout_data, Lisp_Timeout_Data) #define wrap_timeout_data(p) wrap_record(p, timeout_data) #define TIMEOUT_DATAP(x) RECORDP (x, timeout_data) @@ -411,7 +411,7 @@ object Argument of function. */ #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ Lisp_Object function; Lisp_Object object; @@ -419,7 +419,7 @@ typedef struct Lisp_Eval_Data Lisp_Eval_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (eval_data, Lisp_Eval_Data); +DECLARE_LISP_OBJECT (eval_data, Lisp_Eval_Data); #define XEVAL_DATA(x) XRECORD (x, eval_data, Lisp_Eval_Data) #define wrap_eval_data(p) wrap_record(p, eval_data) #define EVAL_DATAP(x) RECORDP (x, eval_data) @@ -464,7 +464,7 @@ values for other types of misc_user_events. */ #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ Lisp_Object function; Lisp_Object object; @@ -475,7 +475,7 @@ typedef struct Lisp_Misc_User_Data Lisp_Misc_User_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (misc_user_data, Lisp_Misc_User_Data); +DECLARE_LISP_OBJECT (misc_user_data, Lisp_Misc_User_Data); #define XMISC_USER_DATA(x) XRECORD (x, misc_user_data, Lisp_Misc_User_Data) #define wrap_misc_user_data(p) wrap_record(p, misc_user_data) #define MISC_USER_DATAP(x) RECORDP (x, misc_user_data) @@ -541,7 +541,7 @@ */ #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ void (*internal_function) (Lisp_Object); Lisp_Object object; @@ -549,7 +549,7 @@ typedef struct Lisp_Magic_Eval_Data Lisp_Magic_Eval_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (magic_eval_data, Lisp_Magic_Eval_Data); +DECLARE_LISP_OBJECT (magic_eval_data, Lisp_Magic_Eval_Data); #define XMAGIC_EVAL_DATA(x) XRECORD (x, magic_eval_data, Lisp_Magic_Eval_Data) #define wrap_magic_eval_data(p) wrap_record(p, magic_eval_data) #define MAGIC_EVAL_DATAP(x) RECORDP (x, magic_eval_data) @@ -597,7 +597,7 @@ */ #ifdef EVENT_DATA_AS_OBJECTS - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; #endif /* EVENT_DATA_AS_OBJECTS */ union { @@ -616,7 +616,7 @@ typedef struct Lisp_Magic_Data Lisp_Magic_Data; #ifdef EVENT_DATA_AS_OBJECTS -DECLARE_LRECORD (magic_data, Lisp_Magic_Data); +DECLARE_LISP_OBJECT (magic_data, Lisp_Magic_Data); #define XMAGIC_DATA(x) XRECORD (x, magic_data, Lisp_Magic_Data) #define wrap_magic_data(p) wrap_record(p, magic_data) #define MAGIC_DATAP(x) RECORDP (x, magic_data) @@ -660,7 +660,7 @@ struct Lisp_Timeout { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; int id; /* Id we use to identify the timeout over its lifetime */ int interval_id; /* Id for this particular interval; this may be different each time the timeout is @@ -675,7 +675,7 @@ }; typedef struct Lisp_Timeout Lisp_Timeout; -DECLARE_LRECORD (timeout, Lisp_Timeout); +DECLARE_LISP_OBJECT (timeout, Lisp_Timeout); #define XTIMEOUT(x) XRECORD (x, timeout, Lisp_Timeout) #define wrap_timeout(p) wrap_record (p, timeout) #define TIMEOUTP(x) RECORDP (x, timeout) @@ -690,7 +690,7 @@ - Likewise for events chained in the command builder. - Otherwise it's Qnil. */ - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; Lisp_Object next; emacs_event_type event_type; @@ -747,14 +747,14 @@ #endif /* not EVENT_DATA_AS_OBJECTS */ }; -DECLARE_LRECORD (event, Lisp_Event); +DECLARE_LISP_OBJECT (event, Lisp_Event); #define XEVENT(x) XRECORD (x, event, Lisp_Event) #define wrap_event(p) wrap_record (p, event) #define EVENTP(x) RECORDP (x, event) #define CHECK_EVENT(x) CHECK_RECORD (x, event) #define CONCHECK_EVENT(x) CONCHECK_RECORD (x, event) -DECLARE_LRECORD (command_builder, struct command_builder); +DECLARE_LISP_OBJECT (command_builder, struct command_builder); #define EVENT_CHANNEL(a) ((a)->channel) #define XEVENT_CHANNEL(ev) (XEVENT (ev)->channel) @@ -1117,7 +1117,7 @@ */ struct command_builder { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object console; /* back pointer to the console this command builder is for */ #if 0
--- a/src/extents-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/extents-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,5 @@ /* Copyright (c) 1994, 1995 Free Software Foundation. - Copyright (c) 1995, 1996, 2002 Ben Wing. + Copyright (c) 1995, 1996, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -27,7 +27,7 @@ struct extent { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; Memxpos start; Memxpos end; @@ -101,35 +101,42 @@ have this structure around and thus the size of an extent is smaller. */ typedef struct extent_auxiliary extent_auxiliary; + +#define EXTENT_AUXILIARY_SLOTS \ + SLOT (begin_glyph) \ + SLOT (end_glyph) \ + SLOT (parent) \ + /* We use a weak list here. Originally I didn't do this and \ + depended on having the extent's finalization method remove \ + itself from its parent's children list. This runs into \ + lots and lots of problems though because everything is in \ + a really really bizarre state when an extent's finalization \ + method is called (it happens in sweep_extents() by way of \ + ADDITIONAL_FREE_extent()) and it's extremely difficult to \ + avoid getting hosed by just-freed objects. */ \ + SLOT (children) \ + SLOT (invisible) \ + SLOT (read_only) \ + SLOT (mouse_face) \ + SLOT (initial_redisplay_function) \ + SLOT (before_change_functions) \ + SLOT (after_change_functions) + + struct extent_auxiliary { - struct LCRECORD_HEADER header; - - Lisp_Object begin_glyph; - Lisp_Object end_glyph; - Lisp_Object parent; - /* We use a weak list here. Originally I didn't do this and - depended on having the extent's finalization method remove - itself from its parent's children list. This runs into - lots and lots of problems though because everything is in - a really really bizarre state when an extent's finalization - method is called (it happens in sweep_extents() by way of - ADDITIONAL_FREE_extent()) and it's extremely difficult to - avoid getting hosed by just-freed objects. */ - Lisp_Object children; - Lisp_Object invisible; - Lisp_Object read_only; - Lisp_Object mouse_face; - Lisp_Object initial_redisplay_function; - Lisp_Object before_change_functions, after_change_functions; + NORMAL_LISP_OBJECT_HEADER header; +#define SLOT(x) Lisp_Object x; + EXTENT_AUXILIARY_SLOTS +#undef SLOT int priority; }; -extern struct extent_auxiliary extent_auxiliary_defaults; +extern Lisp_Object Vextent_auxiliary_defaults; struct extent_info { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; struct extent_list *extents; struct stack_of_extents *soe; @@ -153,7 +160,7 @@ { return e->flags.has_aux ? XEXTENT_AUXILIARY (XCAR (e->plist)) : - & extent_auxiliary_defaults; + XEXTENT_AUXILIARY (Vextent_auxiliary_defaults); } #define extent_no_chase_aux_field(e, field) (extent_aux_or_default(e)->field) @@ -167,8 +174,8 @@ #define set_extent_no_chase_aux_field(e, field, value) do { \ EXTENT sencaf_e = (e); \ if (! sencaf_e->flags.has_aux) \ - allocate_extent_auxiliary (sencaf_e); \ - XEXTENT_AUXILIARY (XCAR (sencaf_e->plist))->field = (value);\ + attach_extent_auxiliary (sencaf_e); \ + XEXTENT_AUXILIARY (XCAR (sencaf_e->plist))->field = (value); \ } while (0) #define set_extent_no_chase_normal_field(e, field, value) \
--- a/src/extents.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/extents.c Mon Mar 29 21:28:13 2010 -0500 @@ -231,95 +231,13 @@ #include "gutter.h" /* ------------------------------- */ -/* gap array */ -/* ------------------------------- */ - -/* Note that this object is not extent-specific and should perhaps be - moved into another file. */ - -/* Holds a marker that moves as elements in the array are inserted and - deleted, similar to standard markers. */ - -typedef struct gap_array_marker -{ -#ifdef NEW_GC - struct lrecord_header header; -#endif /* NEW_GC */ - int pos; - struct gap_array_marker *next; -} Gap_Array_Marker; - - -/* Holds a "gap array", which is an array of elements with a gap located - in it. Insertions and deletions with a high degree of locality - are very fast, essentially in constant time. Array positions as - used and returned in the gap array functions are independent of - the gap. */ - -/* Layout of gap array: - - <------ gap ------><---- gapsize ----><----- numels - gap ----> - <---------------------- numels + gapsize ---------------------> - - For marking purposes, we use two extra variables computed from - the others -- the offset to the data past the gap, plus the number - of elements in that data: - - offset_past_gap = elsize * (gap + gapsize) - els_past_gap = numels - gap -*/ - - -typedef struct gap_array -{ -#ifdef NEW_GC - struct lrecord_header header; -#endif /* NEW_GC */ - Elemcount gap; - Elemcount gapsize; - Elemcount numels; - Bytecount elsize; - /* Redundant numbers computed from the others, for marking purposes */ - Bytecount offset_past_gap; - Elemcount els_past_gap; - Gap_Array_Marker *markers; - /* this is a stretchy array */ - char array[1]; -} Gap_Array; - -#ifndef NEW_GC -static Gap_Array_Marker *gap_array_marker_freelist; -#endif /* not NEW_GC */ - -/* Convert a "memory position" (i.e. taking the gap into account) into - the address of the element at (i.e. after) that position. "Memory - positions" are only used internally and are of type Memxpos. - "Array positions" are used externally and are of type int. */ -#define GAP_ARRAY_MEMEL_ADDR(ga, memel) ((ga)->array + (ga)->elsize*(memel)) - -/* Number of elements currently in a gap array */ -#define GAP_ARRAY_NUM_ELS(ga) ((ga)->numels) - -#define GAP_ARRAY_ARRAY_TO_MEMORY_POS(ga, pos) \ - ((pos) <= (ga)->gap ? (pos) : (pos) + (ga)->gapsize) - -#define GAP_ARRAY_MEMORY_TO_ARRAY_POS(ga, pos) \ - ((pos) <= (ga)->gap ? (pos) : (pos) - (ga)->gapsize) - -/* Convert an array position into the address of the element at - (i.e. after) that position. */ -#define GAP_ARRAY_EL_ADDR(ga, pos) ((pos) < (ga)->gap ? \ - GAP_ARRAY_MEMEL_ADDR(ga, pos) : \ - GAP_ARRAY_MEMEL_ADDR(ga, (pos) + (ga)->gapsize)) - -/* ------------------------------- */ /* extent list */ /* ------------------------------- */ typedef struct extent_list_marker { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Gap_Array_Marker *m; int endp; @@ -329,7 +247,7 @@ typedef struct extent_list { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Gap_Array *start; Gap_Array *end; @@ -379,13 +297,7 @@ #define EXTENT_E_LESS_EQUAL(e1,e2) \ EXTENT_E_LESS_EQUAL_VALS (e1, extent_start (e2), extent_end (e2)) -#define EXTENT_GAP_ARRAY_AT(ga, pos) (* (EXTENT *) GAP_ARRAY_EL_ADDR(ga, pos)) - -/* ------------------------------- */ -/* auxiliary extent structure */ -/* ------------------------------- */ - -struct extent_auxiliary extent_auxiliary_defaults; +#define EXTENT_GAP_ARRAY_AT(ga, pos) gap_array_at (ga, pos, EXTENT) /* ------------------------------- */ /* buffer-extent primitives */ @@ -394,7 +306,7 @@ typedef struct stack_of_extents { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Extent_List *extents; Memxpos pos; /* Position of stack of extents. EXTENTS is the list of @@ -442,6 +354,8 @@ Lisp_Object Vlast_highlighted_extent; +Lisp_Object Vextent_auxiliary_defaults; + Lisp_Object QSin_map_extents_internal; Fixnum mouse_highlight_priority; @@ -510,269 +424,7 @@ changes */ int in_modeline_generation; - -/************************************************************************/ -/* Generalized gap array */ -/************************************************************************/ - -/* This generalizes the "array with a gap" model used to store buffer - characters. This is based on the stuff in insdel.c and should - probably be merged with it. This is not extent-specific and should - perhaps be moved into a separate file. */ - -/* ------------------------------- */ -/* internal functions */ -/* ------------------------------- */ - -/* Adjust the gap array markers in the range (FROM, TO]. Parallel to - adjust_markers() in insdel.c. */ - -static void -gap_array_adjust_markers (Gap_Array *ga, Memxpos from, - Memxpos to, Elemcount amount) -{ - Gap_Array_Marker *m; - - for (m = ga->markers; m; m = m->next) - m->pos = do_marker_adjustment (m->pos, from, to, amount); -} - -static void -gap_array_recompute_derived_values (Gap_Array *ga) -{ - ga->offset_past_gap = ga->elsize * (ga->gap + ga->gapsize); - ga->els_past_gap = ga->numels - ga->gap; -} - -/* Move the gap to array position POS. Parallel to move_gap() in - insdel.c but somewhat simplified. */ - -static void -gap_array_move_gap (Gap_Array *ga, Elemcount pos) -{ - Elemcount gap = ga->gap; - Elemcount gapsize = ga->gapsize; - - if (pos < gap) - { - memmove (GAP_ARRAY_MEMEL_ADDR (ga, pos + gapsize), - GAP_ARRAY_MEMEL_ADDR (ga, pos), - (gap - pos)*ga->elsize); - gap_array_adjust_markers (ga, (Memxpos) pos, (Memxpos) gap, - gapsize); - } - else if (pos > gap) - { - memmove (GAP_ARRAY_MEMEL_ADDR (ga, gap), - GAP_ARRAY_MEMEL_ADDR (ga, gap + gapsize), - (pos - gap)*ga->elsize); - gap_array_adjust_markers (ga, (Memxpos) (gap + gapsize), - (Memxpos) (pos + gapsize), - gapsize); - } - ga->gap = pos; - - gap_array_recompute_derived_values (ga); -} - -/* Make the gap INCREMENT characters longer. Parallel to make_gap() in - insdel.c. The gap array may be moved, so assign the return value back - to the array pointer. */ - -static Gap_Array * -gap_array_make_gap (Gap_Array *ga, Elemcount increment) -{ - Elemcount real_gap_loc; - Elemcount old_gap_size; - - /* If we have to get more space, get enough to last a while. We use - a geometric progression that saves on realloc space. */ - increment += 100 + ga->numels / 8; - -#ifdef NEW_GC - ga = (Gap_Array *) mc_realloc (ga, - offsetof (Gap_Array, array) + - (ga->numels + ga->gapsize + increment) * - ga->elsize); -#else /* not NEW_GC */ - ga = (Gap_Array *) xrealloc (ga, - offsetof (Gap_Array, array) + - (ga->numels + ga->gapsize + increment) * - ga->elsize); -#endif /* not NEW_GC */ - if (ga == 0) - memory_full (); - - real_gap_loc = ga->gap; - old_gap_size = ga->gapsize; - - /* Call the newly allocated space a gap at the end of the whole space. */ - ga->gap = ga->numels + ga->gapsize; - ga->gapsize = increment; - - /* Move the new gap down to be consecutive with the end of the old one. - This adjusts the markers properly too. */ - gap_array_move_gap (ga, real_gap_loc + old_gap_size); - - /* Now combine the two into one large gap. */ - ga->gapsize += old_gap_size; - ga->gap = real_gap_loc; - - gap_array_recompute_derived_values (ga); - - return ga; -} - -/* ------------------------------- */ -/* external functions */ -/* ------------------------------- */ - -/* Insert NUMELS elements (pointed to by ELPTR) into the specified - gap array at POS. The gap array may be moved, so assign the - return value back to the array pointer. */ - -static Gap_Array * -gap_array_insert_els (Gap_Array *ga, Elemcount pos, void *elptr, - Elemcount numels) -{ - assert (pos >= 0 && pos <= ga->numels); - if (ga->gapsize < numels) - ga = gap_array_make_gap (ga, numels - ga->gapsize); - if (pos != ga->gap) - gap_array_move_gap (ga, pos); - - memcpy (GAP_ARRAY_MEMEL_ADDR (ga, ga->gap), (char *) elptr, - numels*ga->elsize); - ga->gapsize -= numels; - ga->gap += numels; - ga->numels += numels; - gap_array_recompute_derived_values (ga); - /* This is the equivalent of insert-before-markers. - - #### Should only happen if marker is "moves forward at insert" type. - */ - - gap_array_adjust_markers (ga, pos - 1, pos, numels); - return ga; -} - -/* Delete NUMELS elements from the specified gap array, starting at FROM. */ - -static void -gap_array_delete_els (Gap_Array *ga, Elemcount from, Elemcount numdel) -{ - Elemcount to = from + numdel; - Elemcount gapsize = ga->gapsize; - - assert (from >= 0); - assert (numdel >= 0); - assert (to <= ga->numels); - - /* Make sure the gap is somewhere in or next to what we are deleting. */ - if (to < ga->gap) - gap_array_move_gap (ga, to); - if (from > ga->gap) - gap_array_move_gap (ga, from); - - /* Relocate all markers pointing into the new, larger gap - to point at the end of the text before the gap. */ - gap_array_adjust_markers (ga, to + gapsize, to + gapsize, - - numdel - gapsize); - - ga->gapsize += numdel; - ga->numels -= numdel; - ga->gap = from; - gap_array_recompute_derived_values (ga); -} - -static Gap_Array_Marker * -gap_array_make_marker (Gap_Array *ga, Elemcount pos) -{ - Gap_Array_Marker *m; - - assert (pos >= 0 && pos <= ga->numels); -#ifdef NEW_GC - m = alloc_lrecord_type (Gap_Array_Marker, &lrecord_gap_array_marker); -#else /* not NEW_GC */ - if (gap_array_marker_freelist) - { - m = gap_array_marker_freelist; - gap_array_marker_freelist = gap_array_marker_freelist->next; - } - else - m = xnew (Gap_Array_Marker); -#endif /* not NEW_GC */ - - m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); - m->next = ga->markers; - ga->markers = m; - return m; -} - -static void -gap_array_delete_marker (Gap_Array *ga, Gap_Array_Marker *m) -{ - Gap_Array_Marker *p, *prev; - - for (prev = 0, p = ga->markers; p && p != m; prev = p, p = p->next) - ; - assert (p); - if (prev) - prev->next = p->next; - else - ga->markers = p->next; -#ifndef NEW_GC - m->next = gap_array_marker_freelist; - m->pos = 0xDEADBEEF; /* -559038737 base 10 */ - gap_array_marker_freelist = m; -#endif /* not NEW_GC */ -} - -#ifndef NEW_GC -static void -gap_array_delete_all_markers (Gap_Array *ga) -{ - Gap_Array_Marker *p, *next; - - for (p = ga->markers; p; p = next) - { - next = p->next; - p->next = gap_array_marker_freelist; - p->pos = 0xDEADBEEF; /* -559038737 as an int */ - gap_array_marker_freelist = p; - } -} -#endif /* not NEW_GC */ - -static void -gap_array_move_marker (Gap_Array *ga, Gap_Array_Marker *m, Elemcount pos) -{ - assert (pos >= 0 && pos <= ga->numels); - m->pos = GAP_ARRAY_ARRAY_TO_MEMORY_POS (ga, pos); -} - -#define gap_array_marker_pos(ga, m) \ - GAP_ARRAY_MEMORY_TO_ARRAY_POS (ga, (m)->pos) - -static Gap_Array * -make_gap_array (Elemcount elsize) -{ -#ifdef NEW_GC - Gap_Array *ga = alloc_lrecord_type (Gap_Array, &lrecord_gap_array); -#else /* not NEW_GC */ - Gap_Array *ga = xnew_and_zero (Gap_Array); -#endif /* not NEW_GC */ - ga->elsize = elsize; - return ga; -} - -#ifndef NEW_GC -static void -free_gap_array (Gap_Array *ga) -{ - gap_array_delete_all_markers (ga); - xfree (ga); -} -#endif /* not NEW_GC */ +int debug_soe; /************************************************************************/ @@ -792,7 +444,7 @@ */ /* Number of elements in an extent list */ -#define extent_list_num_els(el) GAP_ARRAY_NUM_ELS (el->start) +#define extent_list_num_els(el) gap_array_length (el->start) /* Return the position at which EXTENT is located in the specified extent list (in the display order if ENDP is 0, in the e-order otherwise). @@ -806,7 +458,7 @@ extent_list_locate (Extent_List *el, EXTENT extent, int endp, int *foundp) { Gap_Array *ga = endp ? el->end : el->start; - int left = 0, right = GAP_ARRAY_NUM_ELS (ga); + int left = 0, right = gap_array_length (ga); int oldfoundpos, foundpos; int found; @@ -826,7 +478,7 @@ /* Now we're at the beginning of all equal extents. */ found = 0; oldfoundpos = foundpos = left; - while (foundpos < GAP_ARRAY_NUM_ELS (ga)) + while (foundpos < gap_array_length (ga)) { EXTENT e = EXTENT_GAP_ARRAY_AT (ga, foundpos); if (e == extent) @@ -881,7 +533,7 @@ { Gap_Array *ga = endp ? el->end : el->start; - assert (pos >= 0 && pos < GAP_ARRAY_NUM_ELS (ga)); + assert (pos >= 0 && pos < gap_array_length (ga)); return EXTENT_GAP_ARRAY_AT (ga, pos); } @@ -918,8 +570,8 @@ static void extent_list_delete_all (Extent_List *el) { - gap_array_delete_els (el->start, 0, GAP_ARRAY_NUM_ELS (el->start)); - gap_array_delete_els (el->end, 0, GAP_ARRAY_NUM_ELS (el->end)); + gap_array_delete_els (el->start, 0, gap_array_length (el->start)); + gap_array_delete_els (el->end, 0, gap_array_length (el->end)); } static Extent_List_Marker * @@ -928,7 +580,7 @@ Extent_List_Marker *m; #ifdef NEW_GC - m = alloc_lrecord_type (Extent_List_Marker, &lrecord_extent_list_marker); + m = XEXTENT_LIST_MARKER (ALLOC_NORMAL_LISP_OBJECT (extent_list_marker)); #else /* not NEW_GC */ if (extent_list_marker_freelist) { @@ -977,12 +629,12 @@ allocate_extent_list (void) { #ifdef NEW_GC - Extent_List *el = alloc_lrecord_type (Extent_List, &lrecord_extent_list); + Extent_List *el = XEXTENT_LIST (ALLOC_NORMAL_LISP_OBJECT (extent_list)); #else /* not NEW_GC */ Extent_List *el = xnew (Extent_List); #endif /* not NEW_GC */ - el->start = make_gap_array (sizeof (EXTENT)); - el->end = make_gap_array (sizeof (EXTENT)); + el->start = make_gap_array (sizeof (EXTENT), 1); + el->end = make_gap_array (sizeof (EXTENT), 1); el->markers = 0; return el; } @@ -1003,48 +655,49 @@ /************************************************************************/ static const struct memory_description extent_auxiliary_description[] ={ - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, begin_glyph) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, end_glyph) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, parent) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, children) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, invisible) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, read_only) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, mouse_face) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, initial_redisplay_function) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, before_change_functions) }, - { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, after_change_functions) }, +#define SLOT(x) \ + { XD_LISP_OBJECT, offsetof (struct extent_auxiliary, x) }, + EXTENT_AUXILIARY_SLOTS +#undef SLOT { XD_END } }; static Lisp_Object mark_extent_auxiliary (Lisp_Object obj) { struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); - mark_object (data->begin_glyph); - mark_object (data->end_glyph); - mark_object (data->invisible); - mark_object (data->children); - mark_object (data->read_only); - mark_object (data->mouse_face); - mark_object (data->initial_redisplay_function); - mark_object (data->before_change_functions); - mark_object (data->after_change_functions); - return data->parent; -} - -DEFINE_LRECORD_IMPLEMENTATION ("extent-auxiliary", extent_auxiliary, - 0, /*dumpable-flag*/ - mark_extent_auxiliary, internal_object_printer, - 0, 0, 0, extent_auxiliary_description, - struct extent_auxiliary); +#define SLOT(x) mark_object (data->x); + EXTENT_AUXILIARY_SLOTS +#undef SLOT + + return Qnil; +} + +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("extent-auxiliary", + extent_auxiliary, + mark_extent_auxiliary, + extent_auxiliary_description, + struct extent_auxiliary); + + +static Lisp_Object +allocate_extent_auxiliary (void) +{ + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (extent_auxiliary); + struct extent_auxiliary *data = XEXTENT_AUXILIARY (obj); + +#define SLOT(x) data->x = Qnil; + EXTENT_AUXILIARY_SLOTS +#undef SLOT + + return obj; +} + void -allocate_extent_auxiliary (EXTENT ext) -{ - Lisp_Object extent_aux; - struct extent_auxiliary *data = - ALLOC_LCRECORD_TYPE (struct extent_auxiliary, &lrecord_extent_auxiliary); - COPY_LCRECORD (data, &extent_auxiliary_defaults); - extent_aux = wrap_extent_auxiliary (data); - ext->plist = Fcons (extent_aux, ext->plist); +attach_extent_auxiliary (EXTENT ext) +{ + Lisp_Object obj = allocate_extent_auxiliary (); + + ext->plist = Fcons (obj, ext->plist); ext->flags.has_aux = 1; } @@ -1080,69 +733,7 @@ #endif /* not NEW_GC */ static void soe_invalidate (Lisp_Object obj); -extern const struct sized_memory_description gap_array_marker_description; - -static const struct memory_description gap_array_marker_description_1[] = { -#ifdef NEW_GC - { XD_LISP_OBJECT, offsetof (Gap_Array_Marker, next) }, -#else /* not NEW_GC */ - { XD_BLOCK_PTR, offsetof (Gap_Array_Marker, next), 1, - { &gap_array_marker_description } }, -#endif /* not NEW_GC */ - { XD_END } -}; - -#ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("gap-array-marker", gap_array_marker, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - gap_array_marker_description_1, - struct gap_array_marker); -#else /* not NEW_GC */ -const struct sized_memory_description gap_array_marker_description = { - sizeof (Gap_Array_Marker), - gap_array_marker_description_1 -}; -#endif /* not NEW_GC */ - -static const struct memory_description lispobj_gap_array_description_1[] = { - { XD_ELEMCOUNT, offsetof (Gap_Array, gap) }, - { XD_BYTECOUNT, offsetof (Gap_Array, offset_past_gap) }, - { XD_ELEMCOUNT, offsetof (Gap_Array, els_past_gap) }, -#ifdef NEW_GC - { XD_LISP_OBJECT, offsetof (Gap_Array, markers) }, -#else /* not NEW_GC */ - { XD_BLOCK_PTR, offsetof (Gap_Array, markers), 1, - { &gap_array_marker_description }, XD_FLAG_NO_KKCC }, -#endif /* not NEW_GC */ - { XD_BLOCK_ARRAY, offsetof (Gap_Array, array), XD_INDIRECT (0, 0), - { &lisp_object_description } }, - { XD_BLOCK_ARRAY, XD_INDIRECT (1, offsetof (Gap_Array, array)), - XD_INDIRECT (2, 0), { &lisp_object_description } }, - { XD_END } -}; - -#ifdef NEW_GC - -static Bytecount -size_gap_array (const void *lheader) -{ - Gap_Array *ga = (Gap_Array *) lheader; - return offsetof (Gap_Array, array) + (ga->numels + ga->gapsize) * ga->elsize; -} - -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("gap-array", gap_array, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - lispobj_gap_array_description_1, - size_gap_array, - struct gap_array); -#else /* not NEW_GC */ -static const struct sized_memory_description lispobj_gap_array_description = { - sizeof (Gap_Array), - lispobj_gap_array_description_1 -}; - +#ifndef NEW_GC extern const struct sized_memory_description extent_list_marker_description; #endif /* not NEW_GC */ @@ -1160,11 +751,10 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("extent-list-marker", extent_list_marker, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - extent_list_marker_description_1, - struct extent_list_marker); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("extent-list-marker", + extent_list_marker, + 0, extent_list_marker_description_1, + struct extent_list_marker); #else /* not NEW_GC */ const struct sized_memory_description extent_list_marker_description = { sizeof (Extent_List_Marker), @@ -1189,11 +779,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("extent-list", extent_list, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - extent_list_description_1, - struct extent_list); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("extent-list", extent_list, + 0, extent_list_description_1, + struct extent_list); #else /* not NEW_GC */ static const struct sized_memory_description extent_list_description = { sizeof (Extent_List), @@ -1212,11 +800,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("stack-of-extents", stack_of_extents, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - stack_of_extents_description_1, - struct stack_of_extents); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("stack-of-extents", stack_of_extents, + 0, stack_of_extents_description_1, + struct stack_of_extents); #else /* not NEW_GC */ static const struct sized_memory_description stack_of_extents_description = { sizeof (Stack_Of_Extents), @@ -1267,24 +853,13 @@ return Qnil; } -#ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("extent-info", extent_info, - 0, /*dumpable-flag*/ - mark_extent_info, internal_object_printer, - 0, 0, 0, - extent_info_description, - struct extent_info); -#else /* not NEW_GC */ +#ifndef NEW_GC + static void -finalize_extent_info (void *header, int for_disksave) -{ - struct extent_info *data = (struct extent_info *) header; - - if (for_disksave) - return; - - data->soe = 0; - data->extents = 0; +finalize_extent_info (Lisp_Object obj) +{ + struct extent_info *data = XEXTENT_INFO (obj); + if (data->soe) { free_soe (data->soe); @@ -1297,25 +872,23 @@ } } -DEFINE_LRECORD_IMPLEMENTATION ("extent-info", extent_info, - 0, /*dumpable-flag*/ - mark_extent_info, internal_object_printer, - finalize_extent_info, 0, 0, - extent_info_description, - struct extent_info); #endif /* not NEW_GC */ + +DEFINE_NODUMP_LISP_OBJECT ("extent-info", extent_info, + mark_extent_info, internal_object_printer, + IF_OLD_GC (finalize_extent_info), 0, 0, + extent_info_description, + struct extent_info); static Lisp_Object allocate_extent_info (void) { - Lisp_Object extent_info; - struct extent_info *data = - ALLOC_LCRECORD_TYPE (struct extent_info, &lrecord_extent_info); - - extent_info = wrap_extent_info (data); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (extent_info); + struct extent_info *data = XEXTENT_INFO (obj); + data->extents = allocate_extent_list (); data->soe = 0; - return extent_info; + return obj; } void @@ -1472,15 +1045,11 @@ void uninit_buffer_extents (struct buffer *b) { -#ifndef NEW_GC - struct extent_info *data = XEXTENT_INFO (b->extent_info); -#endif /* not NEW_GC */ - /* Don't destroy the extents here -- there may still be children extents pointing to the extents. */ detach_all_extents (wrap_buffer (b)); #ifndef NEW_GC - finalize_extent_info (data, 0); + finalize_extent_info (b->extent_info); #endif /* not NEW_GC */ } @@ -1551,24 +1120,7 @@ return info->soe; } -/* #### don't even think of #define'ing this, the prototype of - print_extent_1 has changed! */ -/* #define SOE_DEBUG */ - -#ifdef SOE_DEBUG - -static void print_extent_1 (char *buf, Lisp_Object extent); - -static void -print_extent_2 (EXTENT e) -{ - Lisp_Object extent; - char buf[200]; - - extent = wrap_extent (e); - print_extent_1 (buf, extent); - fputs (buf, stdout); -} +#ifdef DEBUG_XEMACS static void soe_dump (Lisp_Object obj) @@ -1580,29 +1132,29 @@ if (!soe) { - printf ("No SOE"); + stderr_out ("No SOE"); return; } sel = soe->extents; - printf ("SOE pos is %d (memxpos %d)\n", - soe->pos < 0 ? soe->pos : - buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), - soe->pos); + stderr_out ("SOE pos is %ld (memxpos %ld)\n", + soe->pos < 0 ? soe->pos : + buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), + soe->pos); for (endp = 0; endp < 2; endp++) { - printf (endp ? "SOE end:" : "SOE start:"); + stderr_out (endp ? "SOE end:" : "SOE start:"); for (i = 0; i < extent_list_num_els (sel); i++) { EXTENT e = extent_list_at (sel, i, endp); - putchar ('\t'); - print_extent_2 (e); + stderr_out ("\t"); + debug_print (wrap_extent (e)); } - putchar ('\n'); + stderr_out ("\n"); } - putchar ('\n'); -} - -#endif + stderr_out ("\n"); +} + +#endif /* DEBUG_XEMACS */ /* Insert EXTENT into OBJ's stack of extents, if necessary. */ @@ -1611,23 +1163,30 @@ { Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); -#ifdef SOE_DEBUG - printf ("Inserting into SOE: "); - print_extent_2 (extent); - putchar ('\n'); +#ifdef DEBUG_XEMACS + if (debug_soe) + { + stderr_out ("Inserting into SOE: "); + debug_print (wrap_extent (extent)); + stderr_out ("\n"); + } #endif if (!soe || soe->pos < extent_start (extent) || soe->pos > extent_end (extent)) { -#ifdef SOE_DEBUG - printf ("(not needed)\n\n"); +#ifdef DEBUG_XEMACS + if (debug_soe) + stderr_out ("(not needed)\n\n"); #endif return; } extent_list_insert (soe->extents, extent); -#ifdef SOE_DEBUG - puts ("SOE afterwards is:"); - soe_dump (obj); +#ifdef DEBUG_XEMACS + if (debug_soe) + { + stderr_out ("SOE afterwards is:\n"); + soe_dump (obj); + } #endif } @@ -1638,23 +1197,30 @@ { Stack_Of_Extents *soe = buffer_or_string_stack_of_extents (obj); -#ifdef SOE_DEBUG - printf ("Deleting from SOE: "); - print_extent_2 (extent); - putchar ('\n'); +#ifdef DEBUG_XEMACS + if (debug_soe) + { + stderr_out ("Deleting from SOE: "); + debug_print (wrap_extent (extent)); + stderr_out ("\n"); + } #endif if (!soe || soe->pos < extent_start (extent) || soe->pos > extent_end (extent)) { -#ifdef SOE_DEBUG - puts ("(not needed)\n"); +#ifdef DEBUG_XEMACS + if (debug_soe) + stderr_out ("(not needed)\n\n"); #endif return; } extent_list_delete (soe->extents, extent); -#ifdef SOE_DEBUG - puts ("SOE afterwards is:"); - soe_dump (obj); +#ifdef DEBUG_XEMACS + if (debug_soe) + { + stderr_out ("SOE afterwards is:\n"); + soe_dump (obj); + } #endif } @@ -1674,11 +1240,12 @@ assert (bel); #endif -#ifdef SOE_DEBUG - printf ("Moving SOE from %d (memxpos %d) to %d (memxpos %d)\n", - soe->pos < 0 ? soe->pos : - buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), soe->pos, - buffer_or_string_memxpos_to_bytexpos (obj, pos), pos); +#ifdef DEBUG_XEMACS + if (debug_soe) + stderr_out ("Moving SOE from %ld (memxpos %ld) to %ld (memxpos %ld)\n", + soe->pos < 0 ? soe->pos : + buffer_or_string_memxpos_to_bytexpos (obj, soe->pos), soe->pos, + buffer_or_string_memxpos_to_bytexpos (obj, pos), pos); #endif if (soe->pos < pos) { @@ -1692,8 +1259,9 @@ } else { -#ifdef SOE_DEBUG - puts ("(not needed)\n"); +#ifdef DEBUG_XEMACS + if (debug_soe) + stderr_out ("(not needed)\n\n"); #endif return; } @@ -1778,9 +1346,12 @@ } soe->pos = pos; -#ifdef SOE_DEBUG - puts ("SOE afterwards is:"); - soe_dump (obj); +#ifdef DEBUG_XEMACS + if (debug_soe) + { + stderr_out ("SOE afterwards is:\n"); + soe_dump (obj); + } #endif } @@ -1800,8 +1371,8 @@ allocate_soe (void) { #ifdef NEW_GC - struct stack_of_extents *soe = - alloc_lrecord_type (struct stack_of_extents, &lrecord_stack_of_extents); + struct stack_of_extents *soe = + XSTACK_OF_EXTENTS (ALLOC_NORMAL_LISP_OBJECT (stack_of_extents)); #else /* not NEW_GC */ struct stack_of_extents *soe = xnew_and_zero (struct stack_of_extents); #endif /* not NEW_GC */ @@ -3222,10 +2793,10 @@ Lisp_Object function = extent_initial_redisplay_function (e); Lisp_Object obj; - /* printf ("initial redisplay function called!\n "); */ - - /* print_extent_2 (e); - printf ("\n"); */ + /* stderr_out ("initial redisplay function called!\n "); */ + + /* debug_print (wrap_extent (e)); + stderr_out ("\n"); */ /* FIXME: One should probably inhibit the displaying of this extent to reduce flicker */ @@ -3253,7 +2824,7 @@ /* These are the basic helper functions for handling the allocation of extent objects. They are similar to the functions for other - lrecord objects. allocate_extent() is in alloc.c, not here. */ + frob-block objects. allocate_extent() is in alloc.c, not here. */ static Lisp_Object mark_extent (Lisp_Object obj) @@ -3310,8 +2881,6 @@ if (NILP (v)) continue; write_fmt_string_lisp (printcharfun, "%S ", 1, XCAR (tail)); } - - write_fmt_string (printcharfun, "0x%lx", (long) ext); } static void @@ -3355,10 +2924,11 @@ if (print_readably) { if (!EXTENT_LIVE_P (XEXTENT (obj))) - printing_unreadable_object ("#<destroyed extent>"); + printing_unreadable_object_fmt ("#<destroyed extent 0x%x>", + LISP_OBJECT_UID (obj)); else - printing_unreadable_object ("#<extent 0x%lx>", - (long) XEXTENT (obj)); + printing_unreadable_object_fmt ("#<extent 0x%x>", + LISP_OBJECT_UID (obj)); } if (!EXTENT_LIVE_P (XEXTENT (obj))) @@ -3368,17 +2938,19 @@ write_ascstring (printcharfun, "#<extent "); print_extent_1 (obj, printcharfun, escapeflag); write_ascstring (printcharfun, extent_detached_p (XEXTENT (obj)) - ? " from " : " in "); + ? "from " : "in "); write_fmt_string (printcharfun, "%s%s%s", title, name, posttitle); } } else { if (print_readably) - printing_unreadable_object ("#<extent>"); + printing_unreadable_object_fmt ("#<extent 0x%x>", + LISP_OBJECT_UID (obj)); write_ascstring (printcharfun, "#<extent"); } - write_ascstring (printcharfun, ">"); + + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static int @@ -3479,20 +3051,17 @@ return Fextent_properties (obj); } -DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("extent", extent, - 1, /*dumpable-flag*/ - mark_extent, - print_extent, - /* NOTE: If you declare a - finalization method here, - it will NOT be called. - Shaft city. */ - 0, - extent_equal, extent_hash, - extent_description, - extent_getprop, extent_putprop, - extent_remprop, extent_plist, - struct extent); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("extent", extent, + mark_extent, + print_extent, + /* NOTE: If you declare a + finalization method here, + it will NOT be called. + Shaft city. */ + 0, + extent_equal, extent_hash, + extent_description, + struct extent); /************************************************************************/ /* basic extent accessors */ @@ -4059,12 +3628,10 @@ /* also need to copy the aux struct. It won't work for this extent to share the same aux struct as the original one. */ - struct extent_auxiliary *data = - ALLOC_LCRECORD_TYPE (struct extent_auxiliary, - &lrecord_extent_auxiliary); - - COPY_LCRECORD (data, XEXTENT_AUXILIARY (XCAR (original->plist))); - XCAR (e->plist) = wrap_extent_auxiliary (data); + Lisp_Object ea = ALLOC_NORMAL_LISP_OBJECT (extent_auxiliary); + + copy_lisp_object (ea, XCAR (original->plist)); + XCAR (e->plist) = ea; } { @@ -7371,7 +6938,7 @@ use the text-property primitives.) This function looks only at extents created using the text-property primitives. -To look at all extents, use `next-single-char-property-change'. +To look at all extents, use `previous-single-char-property-change'. */ (pos, prop, object, limit)) { @@ -7398,7 +6965,7 @@ use the text-property primitives.) This function looks at all extents. To look at only extents created using the -text-property primitives, use `next-single-char-property-change'. +text-property primitives, use `next-single-property-change'. */ (pos, prop, object, limit)) { @@ -7426,7 +6993,7 @@ use the text-property primitives.) This function looks at all extents. To look at only extents created using the -text-property primitives, use `next-single-char-property-change'. +text-property primitives, use `previous-single-property-change'. */ (pos, prop, object, limit)) { @@ -7436,9 +7003,8 @@ #ifdef MEMORY_USAGE_STATS -int -compute_buffer_extent_usage (struct buffer *UNUSED (b), - struct overhead_stats *UNUSED (ovstats)) +Bytecount +compute_buffer_extent_usage (struct buffer *UNUSED (b)) { /* #### not yet written */ return 0; @@ -7452,17 +7018,24 @@ /************************************************************************/ void +extent_objects_create (void) +{ + OBJECT_HAS_METHOD (extent, getprop); + OBJECT_HAS_METHOD (extent, putprop); + OBJECT_HAS_METHOD (extent, remprop); + OBJECT_HAS_METHOD (extent, plist); +} + +void syms_of_extents (void) { - INIT_LRECORD_IMPLEMENTATION (extent); - INIT_LRECORD_IMPLEMENTATION (extent_info); - INIT_LRECORD_IMPLEMENTATION (extent_auxiliary); + INIT_LISP_OBJECT (extent); + INIT_LISP_OBJECT (extent_info); + INIT_LISP_OBJECT (extent_auxiliary); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (gap_array_marker); - INIT_LRECORD_IMPLEMENTATION (gap_array); - INIT_LRECORD_IMPLEMENTATION (extent_list_marker); - INIT_LRECORD_IMPLEMENTATION (extent_list); - INIT_LRECORD_IMPLEMENTATION (stack_of_extents); + INIT_LISP_OBJECT (extent_list_marker); + INIT_LISP_OBJECT (extent_list); + INIT_LISP_OBJECT (stack_of_extents); #endif /* NEW_GC */ DEFSYMBOL (Qextentp); @@ -7582,24 +7155,17 @@ } void -reinit_vars_of_extents (void) -{ - extent_auxiliary_defaults.begin_glyph = Qnil; - extent_auxiliary_defaults.end_glyph = Qnil; - extent_auxiliary_defaults.parent = Qnil; - extent_auxiliary_defaults.children = Qnil; - extent_auxiliary_defaults.priority = 0; - extent_auxiliary_defaults.invisible = Qnil; - extent_auxiliary_defaults.read_only = Qnil; - extent_auxiliary_defaults.mouse_face = Qnil; - extent_auxiliary_defaults.initial_redisplay_function = Qnil; - extent_auxiliary_defaults.before_change_functions = Qnil; - extent_auxiliary_defaults.after_change_functions = Qnil; -} - -void vars_of_extents (void) { +#ifdef DEBUG_XEMACS + DEFVAR_BOOL ("debug-soe", &debug_soe /* +If non-nil, display debugging information about the SOE ("stack of extents"). +The SOE is a cache of extents overlapping a specified region, used to +speed up `map-extents' and certain other functions. +*/ ); + debug_soe = 0; +#endif /* DEBUG_XEMACS */ + DEFVAR_INT ("mouse-highlight-priority", &mouse_highlight_priority /* The priority to use for the mouse-highlighting pseudo-extent that is used to highlight extents with the `mouse-face' attribute set. @@ -7641,4 +7207,8 @@ QSin_map_extents_internal = build_defer_string ("(in map-extents-internal)"); staticpro (&QSin_map_extents_internal); -} + + Vextent_auxiliary_defaults = + allocate_extent_auxiliary (); + staticpro (&Vextent_auxiliary_defaults); +}
--- a/src/extents.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/extents.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,5 @@ /* Copyright (c) 1994, 1995 Free Software Foundation. - Copyright (c) 1995, 1996, 2002 Ben Wing. + Copyright (c) 1995, 1996, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -23,7 +23,7 @@ #ifndef INCLUDED_extents_h_ #define INCLUDED_extents_h_ -DECLARE_LRECORD (extent, struct extent); +DECLARE_LISP_OBJECT (extent, struct extent); #define XEXTENT(x) XRECORD (x, extent, struct extent) #define wrap_extent(p) wrap_record (p, extent) #define EXTENTP(x) RECORDP (x, extent) @@ -32,7 +32,7 @@ struct extent_auxiliary; -DECLARE_LRECORD (extent_auxiliary, struct extent_auxiliary); +DECLARE_LISP_OBJECT (extent_auxiliary, struct extent_auxiliary); #define XEXTENT_AUXILIARY(x) \ XRECORD (x, extent_auxiliary, struct extent_auxiliary) #define wrap_extent_auxiliary(p) wrap_record (p, extent_auxiliary) @@ -42,7 +42,7 @@ struct extent_info; -DECLARE_LRECORD (extent_info, struct extent_info); +DECLARE_LISP_OBJECT (extent_info, struct extent_info); #define XEXTENT_INFO(x) XRECORD (x, extent_info, struct extent_info) #define wrap_extent_info(p) wrap_record (p, extent_info) #define EXTENT_INFOP(x) RECORDP (x, extent_info) @@ -50,28 +50,9 @@ #define CONCHECK_EXTENT_INFO(x) CONCHECK_RECORD (x, extent_info) #ifdef NEW_GC -struct gap_array_marker; - -DECLARE_LRECORD (gap_array_marker, struct gap_array_marker); -#define XGAP_ARRAY_MARKER(x) \ - XRECORD (x, gap_array_marker, struct gap_array_marker) -#define wrap_gap_array_marker(p) wrap_record (p, gap_array_marker) -#define GAP_ARRAY_MARKERP(x) RECORDP (x, gap_array_marker) -#define CHECK_GAP_ARRAY_MARKER(x) CHECK_RECORD (x, gap_array_marker) -#define CONCHECK_GAP_ARRAY_MARKER(x) CONCHECK_RECORD (x, gap_array_marker) - -struct gap_array; - -DECLARE_LRECORD (gap_array, struct gap_array); -#define XGAP_ARRAY(x) XRECORD (x, gap_array, struct gap_array) -#define wrap_gap_array(p) wrap_record (p, gap_array) -#define GAP_ARRAYP(x) RECORDP (x, gap_array) -#define CHECK_GAP_ARRAY(x) CHECK_RECORD (x, gap_array) -#define CONCHECK_GAP_ARRAY(x) CONCHECK_RECORD (x, gap_array) - struct extent_list_marker; -DECLARE_LRECORD (extent_list_marker, struct extent_list_marker); +DECLARE_LISP_OBJECT (extent_list_marker, struct extent_list_marker); #define XEXTENT_LIST_MARKER(x) \ XRECORD (x, extent_list_marker, struct extent_list_marker) #define wrap_extent_list_marker(p) wrap_record (p, extent_list_marker) @@ -81,7 +62,7 @@ struct extent_list; -DECLARE_LRECORD (extent_list, struct extent_list); +DECLARE_LISP_OBJECT (extent_list, struct extent_list); #define XEXTENT_LIST(x) XRECORD (x, extent_list, struct extent_list) #define wrap_extent_list(p) wrap_record (p, extent_list) #define EXTENT_LISTP(x) RECORDP (x, extent_list) @@ -90,7 +71,7 @@ struct stack_of_extents; -DECLARE_LRECORD (stack_of_extents, struct stack_of_extents); +DECLARE_LISP_OBJECT (stack_of_extents, struct stack_of_extents); #define XSTACK_OF_EXTENTS(x) \ XRECORD (x, stack_of_extents, struct stack_of_extents) #define wrap_stack_of_extents(p) wrap_record (p, stack_of_extents) @@ -228,7 +209,7 @@ /* from alloc.c */ struct extent *allocate_extent (void); -void allocate_extent_auxiliary (EXTENT ext); +void attach_extent_auxiliary (EXTENT ext); void init_buffer_extents (struct buffer *b); void uninit_buffer_extents (struct buffer *b); @@ -237,8 +218,7 @@ #endif #ifdef MEMORY_USAGE_STATS -int compute_buffer_extent_usage (struct buffer *b, - struct overhead_stats *ovstats); +Bytecount compute_buffer_extent_usage (struct buffer *b); #endif #endif /* INCLUDED_extents_h_ */
--- a/src/faces.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/faces.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995, 1996, 2001, 2002, 2005, 2010 Ben Wing. Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -42,7 +43,7 @@ Lisp_Object Qfacep; Lisp_Object Qforeground, Qbackground, Qdisplay_table; -Lisp_Object Qbackground_pixmap, Qunderline, Qdim; +Lisp_Object Qbackground_pixmap, Qbackground_placement, Qunderline, Qdim; Lisp_Object Qblinking, Qstrikethru; Lisp_Object Qinit_face_from_resources; @@ -111,6 +112,7 @@ mark_object (face->font); mark_object (face->display_table); mark_object (face->background_pixmap); + mark_object (face->background_placement); mark_object (face->underline); mark_object (face->strikethru); mark_object (face->highlight); @@ -162,6 +164,9 @@ internal_equal (f1->font, f2->font, depth) && internal_equal (f1->display_table, f2->display_table, depth) && internal_equal (f1->background_pixmap, f2->background_pixmap, depth) && + internal_equal (f1->background_placement, + f2->background_placement, + depth) && internal_equal (f1->underline, f2->underline, depth) && internal_equal (f1->strikethru, f2->strikethru, depth) && internal_equal (f1->highlight, f2->highlight, depth) && @@ -192,18 +197,19 @@ Lisp_Face *f = XFACE (obj); return - (EQ (prop, Qforeground) ? f->foreground : - EQ (prop, Qbackground) ? f->background : - EQ (prop, Qfont) ? f->font : - EQ (prop, Qdisplay_table) ? f->display_table : - EQ (prop, Qbackground_pixmap) ? f->background_pixmap : - EQ (prop, Qunderline) ? f->underline : - EQ (prop, Qstrikethru) ? f->strikethru : - EQ (prop, Qhighlight) ? f->highlight : - EQ (prop, Qdim) ? f->dim : - EQ (prop, Qblinking) ? f->blinking : - EQ (prop, Qreverse) ? f->reverse : - EQ (prop, Qdoc_string) ? f->doc_string : + (EQ (prop, Qforeground) ? f->foreground : + EQ (prop, Qbackground) ? f->background : + EQ (prop, Qfont) ? f->font : + EQ (prop, Qdisplay_table) ? f->display_table : + EQ (prop, Qbackground_pixmap) ? f->background_pixmap : + EQ (prop, Qbackground_placement) ? f->background_placement : + EQ (prop, Qunderline) ? f->underline : + EQ (prop, Qstrikethru) ? f->strikethru : + EQ (prop, Qhighlight) ? f->highlight : + EQ (prop, Qdim) ? f->dim : + EQ (prop, Qblinking) ? f->blinking : + EQ (prop, Qreverse) ? f->reverse : + EQ (prop, Qdoc_string) ? f->doc_string : external_plist_get (&f->plist, prop, 0, ERROR_ME)); } @@ -212,16 +218,17 @@ { Lisp_Face *f = XFACE (obj); - if (EQ (prop, Qforeground) || - EQ (prop, Qbackground) || - EQ (prop, Qfont) || - EQ (prop, Qdisplay_table) || - EQ (prop, Qbackground_pixmap) || - EQ (prop, Qunderline) || - EQ (prop, Qstrikethru) || - EQ (prop, Qhighlight) || - EQ (prop, Qdim) || - EQ (prop, Qblinking) || + if (EQ (prop, Qforeground) || + EQ (prop, Qbackground) || + EQ (prop, Qfont) || + EQ (prop, Qdisplay_table) || + EQ (prop, Qbackground_pixmap) || + EQ (prop, Qbackground_placement) || + EQ (prop, Qunderline) || + EQ (prop, Qstrikethru) || + EQ (prop, Qhighlight) || + EQ (prop, Qdim) || + EQ (prop, Qblinking) || EQ (prop, Qreverse)) return 0; @@ -242,16 +249,17 @@ { Lisp_Face *f = XFACE (obj); - if (EQ (prop, Qforeground) || - EQ (prop, Qbackground) || - EQ (prop, Qfont) || - EQ (prop, Qdisplay_table) || - EQ (prop, Qbackground_pixmap) || - EQ (prop, Qunderline) || - EQ (prop, Qstrikethru) || - EQ (prop, Qhighlight) || - EQ (prop, Qdim) || - EQ (prop, Qblinking) || + if (EQ (prop, Qforeground) || + EQ (prop, Qbackground) || + EQ (prop, Qfont) || + EQ (prop, Qdisplay_table) || + EQ (prop, Qbackground_pixmap) || + EQ (prop, Qbackground_placement) || + EQ (prop, Qunderline) || + EQ (prop, Qstrikethru) || + EQ (prop, Qhighlight) || + EQ (prop, Qdim) || + EQ (prop, Qblinking) || EQ (prop, Qreverse)) return -1; @@ -270,17 +278,18 @@ Lisp_Face *face = XFACE (obj); Lisp_Object result = face->plist; - result = cons3 (Qreverse, face->reverse, result); - result = cons3 (Qblinking, face->blinking, result); - result = cons3 (Qdim, face->dim, result); - result = cons3 (Qhighlight, face->highlight, result); - result = cons3 (Qstrikethru, face->strikethru, result); - result = cons3 (Qunderline, face->underline, result); - result = cons3 (Qbackground_pixmap, face->background_pixmap, result); - result = cons3 (Qdisplay_table, face->display_table, result); - result = cons3 (Qfont, face->font, result); - result = cons3 (Qbackground, face->background, result); - result = cons3 (Qforeground, face->foreground, result); + result = cons3 (Qreverse, face->reverse, result); + result = cons3 (Qblinking, face->blinking, result); + result = cons3 (Qdim, face->dim, result); + result = cons3 (Qhighlight, face->highlight, result); + result = cons3 (Qstrikethru, face->strikethru, result); + result = cons3 (Qunderline, face->underline, result); + result = cons3 (Qbackground_placement, face->background_placement, result); + result = cons3 (Qbackground_pixmap, face->background_pixmap, result); + result = cons3 (Qdisplay_table, face->display_table, result); + result = cons3 (Qfont, face->font, result); + result = cons3 (Qbackground, face->background, result); + result = cons3 (Qforeground, face->foreground, result); return result; } @@ -293,6 +302,7 @@ { XD_LISP_OBJECT, offsetof (Lisp_Face, font) }, { XD_LISP_OBJECT, offsetof (Lisp_Face, display_table) }, { XD_LISP_OBJECT, offsetof (Lisp_Face, background_pixmap) }, + { XD_LISP_OBJECT, offsetof (Lisp_Face, background_placement) }, { XD_LISP_OBJECT, offsetof (Lisp_Face, underline) }, { XD_LISP_OBJECT, offsetof (Lisp_Face, strikethru) }, { XD_LISP_OBJECT, offsetof (Lisp_Face, highlight) }, @@ -304,13 +314,10 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("face", face, - 1, /*dumpable-flag*/ - mark_face, print_face, 0, face_equal, - face_hash, face_description, - face_getprop, - face_putprop, face_remprop, - face_plist, Lisp_Face); +DEFINE_DUMPABLE_LISP_OBJECT ("face", face, + mark_face, print_face, 0, face_equal, + face_hash, face_description, + Lisp_Face); /************************************************************************/ /* face read syntax */ @@ -386,6 +393,7 @@ f->font = Qnil; f->display_table = Qnil; f->background_pixmap = Qnil; + f->background_placement = Qnil; f->underline = Qnil; f->strikethru = Qnil; f->highlight = Qnil; @@ -399,7 +407,8 @@ static Lisp_Face * allocate_face (void) { - Lisp_Face *result = ALLOC_LCRECORD_TYPE (Lisp_Face, &lrecord_face); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (face); + Lisp_Face *result = XFACE (obj); reset_face (result); return result; @@ -845,6 +854,8 @@ set_font_attached_to (f->font, face, Qfont); f->background_pixmap = Fmake_specifier (Qimage); set_image_attached_to (f->background_pixmap, face, Qbackground_pixmap); + f->background_placement = Fmake_specifier (Qface_background_placement); + set_face_background_placement_attached_to (f->background_placement, face); f->display_table = Fmake_specifier (Qdisplay_table); f->underline = Fmake_specifier (Qface_boolean); set_face_boolean_attached_to (f->underline, face, Qunderline); @@ -873,6 +884,9 @@ set_specifier_fallback (f->background_pixmap, Fget (Vdefault_face, Qbackground_pixmap, Qunbound)); + set_specifier_fallback (f->background_placement, + Fget (Vdefault_face, Qbackground_placement, + Qunbound)); set_specifier_fallback (f->display_table, Fget (Vdefault_face, Qdisplay_table, Qunbound)); set_specifier_fallback (f->underline, @@ -1067,6 +1081,7 @@ mark_object (cachel->background); mark_object (cachel->display_table); mark_object (cachel->background_pixmap); + mark_object (cachel->background_placement); } } @@ -1423,6 +1438,9 @@ FROB (background_pixmap); MAYBE_UNFROB_BACKGROUND_PIXMAP; } + + FROB (background_placement); + #undef FROB #undef MAYBE_UNFROB_BACKGROUND_PIXMAP @@ -1486,6 +1504,7 @@ FROB (background); FROB (display_table); FROB (background_pixmap); + FROB (background_placement); FROB (underline); FROB (strikethru); FROB (highlight); @@ -1536,6 +1555,7 @@ } cachel->display_table = Qunbound; cachel->background_pixmap = Qunbound; + cachel->background_placement = Qunbound; FACE_CACHEL_FONT_SPECIFIED (cachel)->size = sizeof(cachel->font_specified); FACE_CACHEL_FONT_UPDATED (cachel)->size = sizeof(cachel->font_updated); } @@ -1629,7 +1649,7 @@ int compute_face_cachel_usage (face_cachel_dynarr *face_cachels, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { int total = 0; @@ -1637,12 +1657,12 @@ { int i; - total += Dynarr_memory_usage (face_cachels, ovstats); + total += Dynarr_memory_usage (face_cachels, ustats); for (i = 0; i < Dynarr_length (face_cachels); i++) { int_dynarr *merged = Dynarr_at (face_cachels, i).merged_faces; if (merged) - total += Dynarr_memory_usage (merged, ovstats); + total += Dynarr_memory_usage (merged, ustats); } } @@ -1901,8 +1921,8 @@ /* If the locale could affect the frame value, then call update_EmacsFrames just in case. */ if (default_face && - (EQ (property, Qforeground) || - EQ (property, Qbackground) || + (EQ (property, Qforeground) || + EQ (property, Qbackground) || EQ (property, Qfont))) update_EmacsFrames (locale, property); @@ -1996,6 +2016,7 @@ COPY_PROPERTY (font); COPY_PROPERTY (display_table); COPY_PROPERTY (background_pixmap); + COPY_PROPERTY (background_placement); COPY_PROPERTY (underline); COPY_PROPERTY (strikethru); COPY_PROPERTY (highlight); @@ -2088,9 +2109,18 @@ void +face_objects_create (void) +{ + OBJECT_HAS_METHOD (face, getprop); + OBJECT_HAS_METHOD (face, putprop); + OBJECT_HAS_METHOD (face, remprop); + OBJECT_HAS_METHOD (face, plist); +} + +void syms_of_faces (void) { - INIT_LRECORD_IMPLEMENTATION (face); + INIT_LISP_OBJECT (face); /* Qdefault, Qwidget, Qleft_margin, Qright_margin defined in general.c */ DEFSYMBOL (Qmodeline); @@ -2126,6 +2156,7 @@ /* Qfont defined in general.c */ DEFSYMBOL (Qdisplay_table); DEFSYMBOL (Qbackground_pixmap); + DEFSYMBOL (Qbackground_placement); DEFSYMBOL (Qunderline); DEFSYMBOL (Qstrikethru); /* Qhighlight, Qreverse defined in general.c */ @@ -2199,6 +2230,7 @@ syms[n++] = Qfont; syms[n++] = Qdisplay_table; syms[n++] = Qbackground_pixmap; + syms[n++] = Qbackground_placement; syms[n++] = Qunderline; syms[n++] = Qstrikethru; syms[n++] = Qhighlight; @@ -2517,6 +2549,9 @@ set_specifier_fallback (Fget (Vmodeline_face, Qbackground_pixmap, Qnil), Fget (Vgui_element_face, Qbackground_pixmap, Qunbound)); + set_specifier_fallback (Fget (Vmodeline_face, Qbackground_placement, Qnil), + Fget (Vgui_element_face, Qbackground_placement, + Qunbound)); /* toolbar is another gui element */ Vtoolbar_face = Fmake_face (Qtoolbar, @@ -2529,6 +2564,9 @@ set_specifier_fallback (Fget (Vtoolbar_face, Qbackground_pixmap, Qnil), Fget (Vgui_element_face, Qbackground_pixmap, Qunbound)); + set_specifier_fallback (Fget (Vtoolbar_face, Qbackground_placement, Qnil), + Fget (Vgui_element_face, Qbackground_placement, + Qunbound)); /* vertical divider is another gui element */ Vvertical_divider_face = Fmake_face (Qvertical_divider, @@ -2543,6 +2581,10 @@ Qunbound), Fget (Vgui_element_face, Qbackground_pixmap, Qunbound)); + set_specifier_fallback (Fget (Vvertical_divider_face, Qbackground_placement, + Qnil), + Fget (Vgui_element_face, Qbackground_placement, + Qunbound)); /* widget is another gui element */ Vwidget_face = Fmake_face (Qwidget,
--- a/src/faces.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/faces.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,7 @@ /* Face data structures. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995, 2002, 2010 Ben Wing + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -34,7 +35,7 @@ struct Lisp_Face { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object name; Lisp_Object doc_string; @@ -47,6 +48,7 @@ Lisp_Object display_table; Lisp_Object background_pixmap; + Lisp_Object background_placement; Lisp_Object underline; Lisp_Object strikethru; @@ -119,7 +121,7 @@ struct face_cachel { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ /* There are two kinds of cachels; those created from a single face and those created by merging more than one face. In the former @@ -172,6 +174,7 @@ Lisp_Object display_table; Lisp_Object background_pixmap; + Lisp_Object background_placement; unsigned int underline :1; unsigned int strikethru :1; @@ -188,6 +191,7 @@ unsigned int background_specified :1; unsigned int display_table_specified :1; unsigned int background_pixmap_specified :1; + unsigned int background_placement_specified :1; unsigned int strikethru_specified :1; unsigned int underline_specified :1; @@ -236,7 +240,7 @@ #ifdef NEW_GC typedef struct face_cachel Lisp_Face_Cachel; -DECLARE_LRECORD (face_cachel, Lisp_Face_Cachel); +DECLARE_LISP_OBJECT (face_cachel, Lisp_Face_Cachel); #define XFACE_CACHEL(x) \ XRECORD (x, face_cachel, Lisp_Face_Cachel) @@ -246,7 +250,7 @@ #define CONCHECK_FACE_CACHEL(x) CONCHECK_RECORD (x, face_cachel) #endif /* NEW_GC */ -DECLARE_LRECORD (face, Lisp_Face); +DECLARE_LISP_OBJECT (face, Lisp_Face); #define XFACE(x) XRECORD (x, face, Lisp_Face) #define wrap_face(p) wrap_record (p, face) #define FACEP(x) RECORDP (x, face) @@ -277,7 +281,7 @@ #ifdef MEMORY_USAGE_STATS int compute_face_cachel_usage (face_cachel_dynarr *face_cachels, - struct overhead_stats *ovstats); + struct usage_stats *ustats); #endif /* MEMORY_USAGE_STATS */ EXFUN (Fface_name, 1); @@ -340,6 +344,8 @@ (WINDOW_FACE_CACHEL (window, index)->display_table) #define WINDOW_FACE_CACHEL_BACKGROUND_PIXMAP(window, index) \ (WINDOW_FACE_CACHEL (window, index)->background_pixmap) +#define WINDOW_FACE_CACHEL_BACKGROUND_PLACEMENT(window, index) \ + (WINDOW_FACE_CACHEL (window, index)->background_placement) #define WINDOW_FACE_CACHEL_DIRTY(window, index) \ (WINDOW_FACE_CACHEL (window, index)->dirty) #define WINDOW_FACE_CACHEL_UNDERLINE_P(window, index) \ @@ -396,6 +402,11 @@ FACE_PROPERTY_INSTANCE (face, Qdisplay_table, domain, 0, Qzero) #define FACE_BACKGROUND_PIXMAP(face, domain) \ FACE_PROPERTY_INSTANCE (face, Qbackground_pixmap, domain, 0, Qzero) + +extern Lisp_Object Qbackground_placement; +#define FACE_BACKGROUND_PLACEMENT(face, domain) \ + FACE_PROPERTY_INSTANCE (face, Qbackground_placement, domain, 0, Qzero) + #define FACE_UNDERLINE_P(face, domain) \ (!NILP (FACE_PROPERTY_INSTANCE (face, Qunderline, domain, 0, Qzero))) #define FACE_STRIKETHRU_P(face, domain) \
--- a/src/file-coding.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/file-coding.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,7 +2,7 @@ #### rename me to coding-system.c or coding.c Copyright (C) 1991, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2000, 2001, 2002, 2003, 2005 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2003, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -297,7 +297,7 @@ { Lisp_Coding_System *c = XCODING_SYSTEM (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<coding-system %s ", 1, c->name); print_coding_system_properties (obj, printcharfun); @@ -318,21 +318,19 @@ #ifndef NEW_GC static void -finalize_coding_system (void *header, int for_disksave) +finalize_coding_system (Lisp_Object obj) { - Lisp_Object cs = wrap_coding_system ((Lisp_Coding_System *) header); /* Since coding systems never go away, this function is not necessary. But it would be necessary if we changed things so that coding systems could go away. */ - if (!for_disksave) /* see comment in lstream.c */ - MAYBE_XCODESYSMETH (cs, finalize, (cs)); + MAYBE_XCODESYSMETH (obj, finalize, (obj)); } #endif /* not NEW_GC */ static Bytecount -sizeof_coding_system (const void *header) +sizeof_coding_system (Lisp_Object obj) { - const Lisp_Coding_System *p = (const Lisp_Coding_System *) header; + const Lisp_Coding_System *p = XCODING_SYSTEM (obj); return offsetof (Lisp_Coding_System, data) + p->methods->extra_data_size; } @@ -379,24 +377,13 @@ 0, coding_system_empty_extra_description_1 }; -#ifdef NEW_GC -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("coding-system", coding_system, - 1, /*dumpable-flag*/ - mark_coding_system, - print_coding_system, - 0, 0, 0, coding_system_description, - sizeof_coding_system, - Lisp_Coding_System); -#else /* not NEW_GC */ -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("coding-system", coding_system, - 1, /*dumpable-flag*/ - mark_coding_system, - print_coding_system, - finalize_coding_system, - 0, 0, coding_system_description, - sizeof_coding_system, - Lisp_Coding_System); -#endif /* not NEW_GC */ +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("coding-system", coding_system, + mark_coding_system, + print_coding_system, + IF_OLD_GC (finalize_coding_system), + 0, 0, coding_system_description, + sizeof_coding_system, + Lisp_Coding_System); /************************************************************************/ /* Creating coding systems */ @@ -1005,9 +992,8 @@ Lisp_Object name) { Bytecount total_size = offsetof (Lisp_Coding_System, data) + data_size; - Lisp_Coding_System *codesys = - (Lisp_Coding_System *) BASIC_ALLOC_LCRECORD (total_size, - &lrecord_coding_system); + Lisp_Object obj = ALLOC_SIZED_LISP_OBJECT (total_size, coding_system); + Lisp_Coding_System *codesys = XCODING_SYSTEM (obj); codesys->methods = codesys_meths; #define MARKED_SLOT(x) codesys->x = Qnil; @@ -1407,13 +1393,15 @@ } DEFUN ("make-coding-system-internal", Fmake_coding_system_internal, 2, 4, 0, /* -See `make-coding-system'. This does much of the work of that function. - +Create a new coding system object, and register NAME as its name. + +With Mule support, this does much of the work of `make-coding-system'. Without Mule support, it does all the work of that function, and an alias -exists, mapping `make-coding-system' to -`make-coding-system-internal'. You'll need a non-Mule XEmacs to read the -complete docstring. Or you can just read it in make-coding-system.el; -something like the following should work: +exists, mapping `make-coding-system' to `make-coding-system-internal'. + +You'll need a Mule XEmacs to read the complete docstring. Or you can +just read it in make-coding-system.el; something like the following +should work: \\[find-function-other-window] find-file RET \\[find-file] mule/make-coding-system.el RET @@ -1452,12 +1440,8 @@ invalid_operation_2 ("Coding systems not same type", old_coding_system, new_coding_system); - { - Lisp_Coding_System *to = XCODING_SYSTEM (new_coding_system); - Lisp_Coding_System *from = XCODING_SYSTEM (old_coding_system); - COPY_SIZED_LCRECORD (to, from, sizeof_coding_system (from)); - to->name = new_name; - } + copy_lisp_object (new_coding_system, old_coding_system); + XCODING_SYSTEM (new_coding_system)->name = new_name; return new_coding_system; } @@ -2720,6 +2704,7 @@ Lstream_delete (XLSTREAM ((data->lstreams)[i])); } xfree (data->lstreams); + data->lstreams = 0; } } @@ -4508,7 +4493,7 @@ void syms_of_file_coding (void) { - INIT_LRECORD_IMPLEMENTATION (coding_system); + INIT_LISP_OBJECT (coding_system); DEFSUBR (Fvalid_coding_system_type_p); DEFSUBR (Fcoding_system_type_list);
--- a/src/file-coding.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/file-coding.h Mon Mar 29 21:28:13 2010 -0500 @@ -188,7 +188,7 @@ struct Lisp_Coding_System { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; struct coding_system_methods *methods; #define CODING_SYSTEM_SLOT_DECLARATION @@ -208,7 +208,7 @@ }; typedef struct Lisp_Coding_System Lisp_Coding_System; -DECLARE_LRECORD (coding_system, Lisp_Coding_System); +DECLARE_LISP_OBJECT (coding_system, Lisp_Coding_System); #define XCODING_SYSTEM(x) XRECORD (x, coding_system, Lisp_Coding_System) #define wrap_coding_system(p) wrap_record (p, coding_system) #define CODING_SYSTEMP(x) RECORDP (x, coding_system) @@ -363,14 +363,13 @@ stick around until GC time. (File handles can also be closed when EOF is signalled; but some data must stick around after this point, for the benefit of canonicalize_after_coding. See the convert method.) - Called only once (NOT called at disksave time). Optional. */ + Called only once. Optional. */ void (*finalize_coding_stream_method) (struct coding_stream *str); /* Finalize method: Clean up type-specific data (e.g. free allocated data) attached to the coding system (i.e. in struct TYPE_coding_system), when the coding system is about to be garbage - collected. (Currently not called.) Called only once (NOT called at - disksave time). Optional. */ + collected. (Currently not called.) Called only once. Optional. */ void (*finalize_method) (Lisp_Object codesys); /* Conversion end type method: Does this coding system encode bytes -> @@ -807,8 +806,7 @@ void (*detect_method) (struct detection_state *st, const unsigned char *src, Bytecount n); /* Finalize detection state method: Clean up any allocated data in the - detection state. Called only once (NOT called at disksave time). - Optional. */ + detection state. Called only once. Optional. */ void (*finalize_detection_state_method) (struct detection_state *st); };
--- a/src/floatfns.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/floatfns.c Mon Mar 29 21:28:13 2010 -0500 @@ -194,11 +194,10 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("float", float, - 1, /*dumpable-flag*/ - mark_float, print_float, 0, float_equal, - float_hash, float_description, - Lisp_Float); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("float", float, + mark_float, print_float, 0, + float_equal, float_hash, + float_description, Lisp_Float); /* Extract a Lisp number as a `double', or signal an error. */ @@ -2483,7 +2482,7 @@ void syms_of_floatfns (void) { - INIT_LRECORD_IMPLEMENTATION (float); + INIT_LISP_OBJECT (float); /* Trig functions. */
--- a/src/fns.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fns.c Mon Mar 29 21:28:13 2010 -0500 @@ -119,9 +119,9 @@ } static Bytecount -size_bit_vector (const void *lheader) +size_bit_vector (Lisp_Object obj) { - Lisp_Bit_Vector *v = (Lisp_Bit_Vector *) lheader; + Lisp_Bit_Vector *v = XBIT_VECTOR (obj); return FLEXIBLE_ARRAY_STRUCT_SIZEOF (Lisp_Bit_Vector, unsigned long, bits, BIT_VECTOR_LONG_STORAGE (bit_vector_length (v))); } @@ -131,15 +131,14 @@ }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("bit-vector", bit_vector, - 1, /*dumpable-flag*/ - mark_bit_vector, - print_bit_vector, 0, - bit_vector_equal, - bit_vector_hash, - bit_vector_description, - size_bit_vector, - Lisp_Bit_Vector); +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("bit-vector", bit_vector, + mark_bit_vector, + print_bit_vector, 0, + bit_vector_equal, + bit_vector_hash, + bit_vector_description, + size_bit_vector, + Lisp_Bit_Vector); DEFUN ("identity", Fidentity, 1, 1, 0, /* @@ -947,30 +946,6 @@ return arg; } -DEFUN ("substring", Fsubstring, 2, 3, 0, /* -Return the substring of STRING starting at START and ending before END. -END may be nil or omitted; then the substring runs to the end of STRING. -If START or END is negative, it counts from the end. -Relevant parts of the string-extent-data are copied to the new string. -*/ - (string, start, end)) -{ - Charcount ccstart, ccend; - Bytecount bstart, blen; - Lisp_Object val; - - CHECK_STRING (string); - CHECK_INT (start); - get_string_range_char (string, start, end, &ccstart, &ccend, - GB_HISTORICAL_STRING_BEHAVIOR); - bstart = string_index_char_to_byte (string, ccstart); - blen = string_offset_char_to_byte_len (string, bstart, ccend - ccstart); - val = make_string (XSTRING_DATA (string) + bstart, blen); - /* Copy any applicable extent information into the new string. */ - copy_string_extents (val, string, 0, bstart, blen); - return val; -} - DEFUN ("subseq", Fsubseq, 2, 3, 0, /* Return the subsequence of SEQUENCE starting at START and ending before END. END may be omitted; then the subsequence runs to the end of SEQUENCE. @@ -983,11 +958,25 @@ { EMACS_INT len, s, e; + if (STRINGP (sequence)) + { + Charcount ccstart, ccend; + Bytecount bstart, blen; + Lisp_Object val; + + CHECK_INT (start); + get_string_range_char (sequence, start, end, &ccstart, &ccend, + GB_HISTORICAL_STRING_BEHAVIOR); + bstart = string_index_char_to_byte (sequence, ccstart); + blen = string_offset_char_to_byte_len (sequence, bstart, ccend - ccstart); + val = make_string (XSTRING_DATA (sequence) + bstart, blen); + /* Copy any applicable extent information into the new string. */ + copy_string_extents (val, sequence, 0, bstart, blen); + return val; + } + CHECK_SEQUENCE (sequence); - if (STRINGP (sequence)) - return Fsubstring (sequence, start, end); - len = XINT (Flength (sequence)); CHECK_INT (start); @@ -4766,7 +4755,7 @@ void syms_of_fns (void) { - INIT_LRECORD_IMPLEMENTATION (bit_vector); + INIT_LISP_OBJECT (bit_vector); DEFSYMBOL (Qstring_lessp); DEFSYMBOL (Qidentity); @@ -4796,7 +4785,6 @@ DEFSUBR (Fcopy_sequence); DEFSUBR (Fcopy_alist); DEFSUBR (Fcopy_tree); - DEFSUBR (Fsubstring); DEFSUBR (Fsubseq); DEFSUBR (Fnthcdr); DEFSUBR (Fnth);
--- a/src/font-mgr.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/font-mgr.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ Copyright (C) 2003 Eric Knauel and Matthias Neubauer Copyright (C) 2005 Eric Knauel Copyright (C) 2004-2009 Free Software Foundation, Inc. +Copyright (C) 2010 Ben Wing. Authors: Eric Knauel <knauel@informatik.uni-tuebingen.de> Matthias Neubauer <neubauer@informatik.uni-freiburg.de> @@ -93,9 +94,9 @@ ****************************************************************/ static void -finalize_fc_pattern (void *header, int UNUSED (for_disksave)) +finalize_fc_pattern (Lisp_Object obj) { - struct fc_pattern *p = (struct fc_pattern *) header; + struct fc_pattern *p = XFC_PATTERN (obj); if (p->fcpatPtr) { FcPatternDestroy (p->fcpatPtr); @@ -103,16 +104,6 @@ } } -static void -print_fc_pattern (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED(escapeflag)) -{ - struct fc_pattern *c = XFCPATTERN (obj); - if (print_readably) - printing_unreadable_object ("#<fc-pattern 0x%x>", c->header.uid); - write_fmt_string (printcharfun, "#<fc-pattern 0x%x>", c->header.uid); -} - /* #### We really need an equal method and a hash method (required if you have an equal method). For the equal method, we can probably use one or both of @@ -142,10 +133,10 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION("fc-pattern", fc_pattern, 0, - 0, print_fc_pattern, finalize_fc_pattern, - 0, 0, fcpattern_description, - struct fc_pattern); +DEFINE_NODUMP_LISP_OBJECT ("fc-pattern", fc_pattern, + 0, external_object_printer, finalize_fc_pattern, + 0, 0, fcpattern_description, + struct fc_pattern); /* * Helper Functions @@ -226,7 +217,7 @@ */ (object)) { - return FCPATTERNP(object) ? Qt : Qnil; + return FC_PATTERNP(object) ? Qt : Qnil; } DEFUN("fc-pattern-create", Ffc_pattern_create, 0, 0, 0, /* @@ -234,11 +225,10 @@ */ ()) { - fc_pattern *fcpat = - ALLOC_LCRECORD_TYPE (struct fc_pattern, &lrecord_fc_pattern); + fc_pattern *fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern)); - fcpat->fcpatPtr = FcPatternCreate(); - return wrap_fcpattern(fcpat); + fcpat->fcpatPtr = FcPatternCreate (); + return wrap_fc_pattern (fcpat); } DEFUN("fc-name-parse", Ffc_name_parse, 1, 1, 0, /* @@ -246,13 +236,12 @@ */ (name)) { - struct fc_pattern *fcpat = - ALLOC_LCRECORD_TYPE (struct fc_pattern, &lrecord_fc_pattern); + fc_pattern *fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern)); - CHECK_STRING(name); + CHECK_STRING (name); fcpat->fcpatPtr = FcNameParse ((FcChar8 *) extract_fcapi_string (name)); - return wrap_fcpattern(fcpat); + return wrap_fc_pattern (fcpat); } /* #### Ga-a-ack! Xft's similar function is actually a different API. @@ -264,8 +253,8 @@ { FcChar8 *name; Lisp_Object result; - CHECK_FCPATTERN(pattern); - name = FcNameUnparse (XFCPATTERN_PTR (pattern)); + CHECK_FC_PATTERN(pattern); + name = FcNameUnparse (XFC_PATTERN_PTR (pattern)); result = build_fcapi_string (name); xfree (name); return result; @@ -277,11 +266,11 @@ (pattern)) { struct fc_pattern *copy = NULL; - CHECK_FCPATTERN(pattern); + CHECK_FC_PATTERN (pattern); - copy = ALLOC_LCRECORD_TYPE (struct fc_pattern, &lrecord_fc_pattern); - copy->fcpatPtr = FcPatternDuplicate(XFCPATTERN_PTR(pattern)); - return wrap_fcpattern(copy); + copy = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern)); + copy->fcpatPtr = FcPatternDuplicate (XFC_PATTERN_PTR (pattern)); + return wrap_fc_pattern (copy); } DEFUN("fc-pattern-add", Ffc_pattern_add, 3, 3, 0, /* @@ -297,11 +286,11 @@ const Extbyte *obj; FcPattern *fcpat; - CHECK_FCPATTERN(pattern); - CHECK_STRING(property); + CHECK_FC_PATTERN (pattern); + CHECK_STRING (property); obj = fc_intern (property); - fcpat = XFCPATTERN_PTR (pattern); + fcpat = XFC_PATTERN_PTR (pattern); if (STRINGP(value)) { @@ -332,10 +321,10 @@ { Bool res; - CHECK_FCPATTERN(pattern); + CHECK_FC_PATTERN(pattern); CHECK_STRING(property); - res = FcPatternDel(XFCPATTERN_PTR(pattern), extract_fcapi_string (property)); + res = FcPatternDel(XFC_PATTERN_PTR(pattern), extract_fcapi_string (property)); return res ? Qt : Qnil; } @@ -425,7 +414,7 @@ /* process arguments */ - CHECK_FCPATTERN (pattern); + CHECK_FC_PATTERN (pattern); #if 0 /* Don't support the losing symbol-for-property interface. */ @@ -449,7 +438,7 @@ if (!NILP (type)) CHECK_SYMBOL (type); /* get property */ - fc_result = FcPatternGet (XFCPATTERN_PTR (pattern), + fc_result = FcPatternGet (XFC_PATTERN_PTR (pattern), fc_property, NILP (id) ? 0 : XINT(id), &fc_value); @@ -517,17 +506,16 @@ /* Linear search: fc_configs are not going to multiply like conses. */ { LIST_LOOP_2 (cfg, configs) - if (fc == XFCCONFIG_PTR (cfg)) + if (fc == XFC_CONFIG_PTR (cfg)) return cfg; } { - fc_config *fccfg = - ALLOC_LCRECORD_TYPE (struct fc_config, &lrecord_fc_config); + fc_config *fccfg = XFC_CONFIG (ALLOC_NORMAL_LISP_OBJECT (fc_config)); fccfg->fccfgPtr = fc; - configs = Fcons (wrap_fcconfig (fccfg), configs); + configs = Fcons (wrap_fc_config (fccfg), configs); XWEAK_LIST_LIST (Vfc_config_weak_list) = configs; - return wrap_fcconfig (fccfg); + return wrap_fc_config (fccfg); } } @@ -539,8 +527,8 @@ Lisp_Object value = Qnil; FcStrList *thing_list; - CHECK_FCCONFIG (config); - thing_list = (*getter) (XFCCONFIG_PTR(config)); + CHECK_FC_CONFIG (config); + thing_list = (*getter) (XFC_CONFIG_PTR(config)); /* Yes, we need to do this check -- sheesh, Keith! */ if (!thing_list) return Qnil; @@ -562,10 +550,9 @@ invalid_state ("failed to create FcFontSet", Qunbound); for (idx = 0; idx < fontset->nfont; ++idx) { - fcpat = - ALLOC_LCRECORD_TYPE (struct fc_pattern, &lrecord_fc_pattern); + fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern)); fcpat->fcpatPtr = FcPatternDuplicate (fontset->fonts[idx]); - fontlist = Fcons (wrap_fcpattern(fcpat), fontlist); + fontlist = Fcons (wrap_fc_pattern(fcpat), fontlist); } if (destroyp) FcFontSetDestroy (fontset); @@ -577,7 +564,7 @@ */ (object)) { - return FCCONFIGP (object) ? Qt : Qnil; + return FC_CONFIGP (object) ? Qt : Qnil; } DEFUN("fc-config-create", Ffc_config_create, 0, 0, 0, /* @@ -610,8 +597,8 @@ in-memory version is in sync with the disk version. */ (config)) { - CHECK_FCCONFIG (config); - return FcConfigUptoDate (XFCCONFIG_PTR (config)) == FcFalse ? Qnil : Qt; + CHECK_FC_CONFIG (config); + return FcConfigUptoDate (XFC_CONFIG_PTR (config)) == FcFalse ? Qnil : Qt; } DEFUN("fc-config-build-fonts", Ffc_config_build_fonts, 1, 1, 0, /* @@ -623,8 +610,8 @@ XEmacs: signal out-of-memory, or return nil on success. */ (config)) { - CHECK_FCCONFIG (config); - if (FcConfigBuildFonts (XFCCONFIG_PTR (config)) == FcFalse) + CHECK_FC_CONFIG (config); + if (FcConfigBuildFonts (XFC_CONFIG_PTR (config)) == FcFalse) out_of_memory ("FcConfigBuildFonts failed", config); return Qnil; } @@ -665,9 +652,9 @@ information. */ (config)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); /* Surely FcConfigGetCache just casts an FcChar8* to char*. */ - return build_fcapi_string ((FcChar8 *) FcConfigGetCache (XFCCONFIG_PTR (config))); + return build_fcapi_string ((FcChar8 *) FcConfigGetCache (XFC_CONFIG_PTR (config))); } DEFUN("fc-config-get-fonts", Ffc_config_get_fonts, 2, 2, 0, /* @@ -684,7 +671,7 @@ FcSetName name = FcSetSystem; FcFontSet *fs = NULL; - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); CHECK_SYMBOL (set); if (EQ (set, intern ("fc-set-system"))) @@ -694,7 +681,7 @@ else wtaerror ("must be in (fc-set-system fc-set-application)", set); - fs = FcConfigGetFonts (XFCCONFIG_PTR (config), name); + fs = FcConfigGetFonts (XFC_CONFIG_PTR (config), name); return fs ? fontset_to_list (fs, DestroyNo) : Qnil; } @@ -708,7 +695,7 @@ */ (config)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); /* *sigh* "Success" DOES NOT mean you have any fonts available. It is easy to crash fontconfig, and XEmacs with it. Without the following check, this will do it: @@ -717,7 +704,7 @@ (set-face-font 'default "serif-12")) */ - if (FcConfigBuildFonts (XFCCONFIG_PTR (config)) == FcFalse) + if (FcConfigBuildFonts (XFC_CONFIG_PTR (config)) == FcFalse) out_of_memory ("FcConfigBuildFonts failed", config); /* #### We'd like to avoid this consing, and FcConfigGetFonts sometimes returns NULL, but it doesn't always. This will do for now .... */ @@ -725,7 +712,7 @@ && NILP (Ffc_config_get_fonts (config, intern ("fc-set-application")))) signal_error (intern ("args-out-of-range"), "no fonts found", config); /* Should never happen, but I don't trust Keith anymore .... */ - if (FcConfigSetCurrent (XFCCONFIG_PTR (config)) == FcFalse) + if (FcConfigSetCurrent (XFC_CONFIG_PTR (config)) == FcFalse) out_of_memory ("FcConfigBuildFonts failed in set", config); return Qnil; } @@ -739,7 +726,7 @@ #### Unimplemented. */ (config)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); signal_error (Qunimplemented, "no method to convert FcBlanks object", intern ("fc-config-get-blanks")); } @@ -752,8 +739,8 @@ the last check. */ (config)) { - CHECK_FCCONFIG (config); - return make_int (FcConfigGetRescanInterval (XFCCONFIG_PTR (config))); + CHECK_FC_CONFIG (config); + return make_int (FcConfigGetRescanInterval (XFC_CONFIG_PTR (config))); } DEFUN("fc-config-set-rescan-interval", Ffc_config_set_rescan_interval, 2, 2, 0, /* @@ -763,9 +750,9 @@ XEmacs: signal such error, or return nil on success. */ (config, rescan_interval)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); CHECK_INT (rescan_interval); - if (FcConfigSetRescanInterval (XFCCONFIG_PTR (config), + if (FcConfigSetRescanInterval (XFC_CONFIG_PTR (config), XINT (rescan_interval)) == FcFalse) signal_error (Qio_error, "FcConfigSetRescanInverval barfed", intern ("fc-config-set-rescan-interval")); @@ -779,10 +766,10 @@ Adds an application-specific font to the configuration. */ (config, file)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); CHECK_STRING (file); if (FcConfigAppFontAddFile - (XFCCONFIG_PTR (config), + (XFC_CONFIG_PTR (config), /* #### FIXME! is Qfile_name right? */ (FcChar8 *) LISP_STRING_TO_EXTERNAL (file, Qfile_name)) == FcFalse) return Qnil; @@ -798,10 +785,10 @@ the application-specific set of fonts. */ (config, dir)) { - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); CHECK_STRING (dir); if (FcConfigAppFontAddDir - (XFCCONFIG_PTR (config), + (XFC_CONFIG_PTR (config), /* #### FIXME! is Qfile_name right? */ (FcChar8 *) LISP_STRING_TO_EXTERNAL (dir, Qfile_name)) == FcFalse) return Qnil; @@ -815,8 +802,8 @@ Clears the set of application-specific fonts. */ (config)) { - CHECK_FCCONFIG (config); - FcConfigAppFontClear (XFCCONFIG_PTR (config)); + CHECK_FC_CONFIG (config); + FcConfigAppFontClear (XFC_CONFIG_PTR (config)); return Qnil; } @@ -888,8 +875,8 @@ specified point size (default 12), dpi (default 75) and scale (default 1). */ (pattern)) { - CHECK_FCPATTERN (pattern); - FcDefaultSubstitute (XFCPATTERN_PTR (pattern)); + CHECK_FC_PATTERN (pattern); + FcDefaultSubstitute (XFC_PATTERN_PTR (pattern)); return Qnil; } @@ -923,14 +910,14 @@ wtaerror ("need `fc-match-pattern' or `fc-match-font'", kind); /* Typecheck arguments */ - CHECK_FCPATTERN (pattern); - if (!NILP (testpat)) CHECK_FCPATTERN (testpat); - if (!NILP (config)) CHECK_FCCONFIG (config); + CHECK_FC_PATTERN (pattern); + if (!NILP (testpat)) CHECK_FC_PATTERN (testpat); + if (!NILP (config)) CHECK_FC_CONFIG (config); return (FcConfigSubstituteWithPat - (NILP (config) ? FcConfigGetCurrent () : XFCCONFIG_PTR (config), - XFCPATTERN_PTR (pattern), - NILP (testpat) ? NULL : XFCPATTERN_PTR (testpat), + (NILP (config) ? FcConfigGetCurrent () : XFC_CONFIG_PTR (config), + XFC_PATTERN_PTR (pattern), + NILP (testpat) ? NULL : XFC_PATTERN_PTR (testpat), knd) == FcTrue) ? Qt : Qnil; } @@ -957,14 +944,14 @@ if (NILP (config)) { config = Ffc_config_get_current (); } - CHECK_FCPATTERN (pattern); - CHECK_FCPATTERN (font); - CHECK_FCCONFIG (config); + CHECK_FC_PATTERN (pattern); + CHECK_FC_PATTERN (font); + CHECK_FC_CONFIG (config); /* I don't think this can fail? */ - return wrap_fcpattern (FcFontRenderPrepare (XFCCONFIG_PTR(config), - XFCPATTERN_PTR(font), - XFCPATTERN_PTR(pattern))); + return wrap_fc_pattern (FcFontRenderPrepare (XFC_CONFIG_PTR(config), + XFC_PATTERN_PTR(font), + XFC_PATTERN_PTR(pattern))); } DEFUN("fc-font-match", Ffc_font_match, 2, 3, 0, /* @@ -985,18 +972,18 @@ FcPattern *p; FcConfig *fcc; - CHECK_FCPATTERN(pattern); + CHECK_FC_PATTERN(pattern); if (NILP(device)) return Qnil; CHECK_X_DEVICE(device); if (!DEVICE_LIVE_P(XDEVICE(device))) return Qnil; if (!NILP (config)) - CHECK_FCCONFIG (config); + CHECK_FC_CONFIG (config); - res_fcpat = ALLOC_LCRECORD_TYPE (struct fc_pattern, &lrecord_fc_pattern); - p = XFCPATTERN_PTR(pattern); - fcc = NILP (config) ? FcConfigGetCurrent () : XFCCONFIG_PTR (config); + res_fcpat = XFC_PATTERN (ALLOC_NORMAL_LISP_OBJECT (fc_pattern)); + p = XFC_PATTERN_PTR(pattern); + fcc = NILP (config) ? FcConfigGetCurrent () : XFC_CONFIG_PTR (config); FcConfigSubstitute (fcc, p, FcMatchPattern); FcDefaultSubstitute (p); @@ -1013,7 +1000,7 @@ return Qfc_internal_error; } else - return wrap_fcpattern(res_fcpat); + return wrap_fc_pattern(res_fcpat); } /* #### fix this name to correspond to Ben's new nomenclature */ @@ -1033,13 +1020,13 @@ FcObjectSet *os; FcFontSet *fontset; - CHECK_FCPATTERN (pattern); + CHECK_FC_PATTERN (pattern); CHECK_LIST (properties); os = FcObjectSetCreate (); string_list_to_fcobjectset (properties, os); /* #### why don't we need to do the "usual substitutions"? */ - fontset = FcFontList (NULL, XFCPATTERN_PTR (pattern), os); + fontset = FcFontList (NULL, XFC_PATTERN_PTR (pattern), os); FcObjectSetDestroy (os); return fontset_to_list (fontset, DestroyYes); @@ -1065,12 +1052,12 @@ match other font-listing APIs. */ (UNUSED (device), pattern, trim, nosub)) { - CHECK_FCPATTERN (pattern); + CHECK_FC_PATTERN (pattern); { FcConfig *fcc = FcConfigGetCurrent(); FcFontSet *fontset; - FcPattern *p = XFCPATTERN_PTR (pattern); + FcPattern *p = XFC_PATTERN_PTR (pattern); FcResult fcresult; if (NILP(nosub)) /* #### temporary debug hack */ @@ -1096,9 +1083,9 @@ */ static void -finalize_fc_config (void *header, int UNUSED (for_disksave)) +finalize_fc_config (Lisp_Object obj) { - struct fc_config *p = (struct fc_config *) header; + struct fc_config *p = XFC_CONFIG (obj); if (p->fccfgPtr && p->fccfgPtr != FcConfigGetCurrent()) { /* If we get here, all of *our* references are garbage (see comment on @@ -1109,25 +1096,15 @@ p->fccfgPtr = 0; } -static void -print_fc_config (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED(escapeflag)) -{ - struct fc_config *c = XFCCONFIG (obj); - if (print_readably) - printing_unreadable_object ("#<fc-config 0x%x>", c->header.uid); - write_fmt_string (printcharfun, "#<fc-config 0x%x>", c->header.uid); -} - static const struct memory_description fcconfig_description [] = { /* #### nothing here, is this right?? */ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION("fc-config", fc_config, 0, - 0, print_fc_config, finalize_fc_config, 0, 0, - fcconfig_description, - struct fc_config); +DEFINE_NODUMP_LISP_OBJECT ("fc-config", fc_config, + 0, external_object_printer, finalize_fc_config, + 0, 0, fcconfig_description, + struct fc_config); DEFUN("fc-init", Ffc_init, 0, 0, 0, /* -- Function: FcBool FcInit (void) @@ -1299,7 +1276,7 @@ void syms_of_font_mgr (void) { - INIT_LRECORD_IMPLEMENTATION(fc_pattern); + INIT_LISP_OBJECT(fc_pattern); DEFSYMBOL_MULTIWORD_PREDICATE(Qfc_patternp); @@ -1328,7 +1305,7 @@ DEFSUBR(Fxlfd_font_name_p); #ifdef FONTCONFIG_EXPOSE_CONFIG - INIT_LRECORD_IMPLEMENTATION(fc_config); + INIT_LISP_OBJECT(fc_config); DEFSYMBOL_MULTIWORD_PREDICATE(Qfc_configp);
--- a/src/font-mgr.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/font-mgr.h Mon Mar 29 21:28:13 2010 -0500 @@ -54,38 +54,38 @@ struct fc_pattern { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; FcPattern *fcpatPtr; }; typedef struct fc_pattern fc_pattern; -DECLARE_LRECORD(fc_pattern, struct fc_pattern); -#define XFCPATTERN(x) XRECORD (x, fc_pattern, struct fc_pattern) -#define wrap_fcpattern(p) wrap_record (p, fc_pattern) -#define FCPATTERNP(x) RECORDP (x, fc_pattern) -#define CHECK_FCPATTERN(x) CHECK_RECORD (x, fc_pattern) -#define CONCHECK_FCPATTERN(x) CONCHECK_RECORD (x, fc_pattern) -#define XFCPATTERN_PTR(x) (XFCPATTERN(x)->fcpatPtr) +DECLARE_LISP_OBJECT(fc_pattern, struct fc_pattern); +#define XFC_PATTERN(x) XRECORD (x, fc_pattern, struct fc_pattern) +#define wrap_fc_pattern(p) wrap_record (p, fc_pattern) +#define FC_PATTERNP(x) RECORDP (x, fc_pattern) +#define CHECK_FC_PATTERN(x) CHECK_RECORD (x, fc_pattern) +#define CONCHECK_FC_PATTERN(x) CONCHECK_RECORD (x, fc_pattern) +#define XFC_PATTERN_PTR(x) (XFC_PATTERN(x)->fcpatPtr) #define FONTCONFIG_EXPOSE_CONFIG #ifdef FONTCONFIG_EXPOSE_CONFIG struct fc_config { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; FcConfig *fccfgPtr; }; typedef struct fc_config fc_config; -DECLARE_LRECORD(fc_config, struct fc_config); -#define XFCCONFIG(x) XRECORD (x, fc_config, struct fc_config) -#define wrap_fcconfig(p) wrap_record (p, fc_config) -#define FCCONFIGP(x) RECORDP (x, fc_config) -#define CHECK_FCCONFIG(x) CHECK_RECORD (x, fc_config) -#define CONCHECK_FCCONFIG(x) CONCHECK_RECORD (x, fc_config) -#define XFCCONFIG_PTR(x) (XFCCONFIG(x)->fccfgPtr) +DECLARE_LISP_OBJECT(fc_config, struct fc_config); +#define XFC_CONFIG(x) XRECORD (x, fc_config, struct fc_config) +#define wrap_fc_config(p) wrap_record (p, fc_config) +#define FC_CONFIGP(x) RECORDP (x, fc_config) +#define CHECK_FC_CONFIG(x) CHECK_RECORD (x, fc_config) +#define CONCHECK_FC_CONFIG(x) CONCHECK_RECORD (x, fc_config) +#define XFC_CONFIG_PTR(x) (XFC_CONFIG(x)->fccfgPtr) #endif /* FONTCONFIG_EXPOSE_CONFIG */
--- a/src/fontcolor-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fontcolor-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,7 @@ /* Generic object functions -- header implementation. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995, 1996, 2002 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -93,13 +94,38 @@ #define CONCHECK_FACE_BOOLEAN_SPECIFIER(x) \ CONCHECK_SPECIFIER_TYPE (x, face_boolean) +/***************************************************************************** + * Background Placement Specifier Object * + *****************************************************************************/ + +struct face_background_placement_specifier +{ + Lisp_Object face; /* face this is attached to, or nil */ +}; + +#define FACE_BACKGROUND_PLACEMENT_SPECIFIER_DATA(g) \ + SPECIFIER_TYPE_DATA (g, face_background_placement) +#define FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE(g) \ + (FACE_BACKGROUND_PLACEMENT_SPECIFIER_DATA (g)->face) + +DECLARE_SPECIFIER_TYPE (face_background_placement); +extern Lisp_Object Qface_background_placement, Qabsolute, Qrelative; +#define XFACE_BACKGROUND_PLACEMENT_SPECIFIER(x) \ + XSPECIFIER_TYPE (x, face_background_placement) +#define FACE_BACKGROUND_PLACEMENT_SPECIFIERP(x) \ + SPECIFIER_TYPEP (x, face_background_placement) +#define CHECK_FACE_BACKGROUND_PLACEMENT_SPECIFIER(x) \ + CHECK_SPECIFIER_TYPE (x, face_background_placement) +#define CONCHECK_FACE_BACKGROUND_PLACEMENT_SPECIFIER(x) \ + CONCHECK_SPECIFIER_TYPE (x, face_background_placement) + /**************************************************************************** * Color Instance Object * ****************************************************************************/ struct Lisp_Color_Instance { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object name; Lisp_Object device; @@ -119,7 +145,7 @@ struct Lisp_Font_Instance { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object name; /* the instantiator used to create the font instance */ Lisp_Object truename; /* used by the device-specific methods; we need to call them to get the truename (#### in reality,
--- a/src/fontcolor-tty-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fontcolor-tty-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -30,13 +30,13 @@ struct tty_color_instance_data { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Lisp_Object symbol; /* so we don't have to constantly call Fintern() */ }; #ifdef NEW_GC -DECLARE_LRECORD (tty_color_instance_data, struct tty_color_instance_data); +DECLARE_LISP_OBJECT (tty_color_instance_data, struct tty_color_instance_data); #define XTTY_COLOR_INSTANCE_DATA(x) \ XRECORD (x, tty_color_instance_data, struct tty_color_instance_data) #define wrap_tty_color_instance_data(p) \ @@ -56,13 +56,13 @@ struct tty_font_instance_data { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Lisp_Object charset; }; #ifdef NEW_GC -DECLARE_LRECORD (tty_font_instance_data, struct tty_font_instance_data); +DECLARE_LISP_OBJECT (tty_font_instance_data, struct tty_font_instance_data); #define XTTY_FONT_INSTANCE_DATA(x) \ XRECORD (x, tty_font_instance_data, struct tty_font_instance_data) #define wrap_tty_font_instance_data(p) \
--- a/src/fontcolor-tty.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fontcolor-tty.c Mon Mar 29 21:28:13 2010 -0500 @@ -43,12 +43,10 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("tty-color-instance-data", - tty_color_instance_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - tty_color_instance_data_description_1, - struct tty_color_instance_data); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("tty-color-instance-data", + tty_color_instance_data, + 0, tty_color_instance_data_description_1, + struct tty_color_instance_data); #else /* not NEW_GC */ const struct sized_memory_description tty_color_instance_data_description = { sizeof (struct tty_color_instance_data), tty_color_instance_data_description_1 @@ -61,12 +59,10 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("tty-font-instance-data", - tty_font_instance_data, - 0, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - tty_font_instance_data_description_1, - struct tty_font_instance_data); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("tty-font-instance-data", + tty_font_instance_data, 0, + tty_font_instance_data_description_1, + struct tty_font_instance_data); #else /* not NEW_GC */ const struct sized_memory_description tty_font_instance_data_description = { sizeof (struct tty_font_instance_data), tty_font_instance_data_description_1 @@ -195,8 +191,8 @@ /* Don't allocate the data until we're sure that we will succeed. */ #ifdef NEW_GC - c->data = alloc_lrecord_type (struct tty_color_instance_data, - &lrecord_tty_color_instance_data); + c->data = + XTTY_COLOR_INSTANCE_DATA (ALLOC_NORMAL_LISP_OBJECT (tty_color_instance_data)); #else /* not NEW_GC */ c->data = xnew (struct tty_color_instance_data); #endif /* not NEW_GC */ @@ -223,7 +219,10 @@ { #ifndef NEW_GC if (c->data) - xfree (c->data); + { + xfree (c->data); + c->data = 0; + } #endif /* not NEW_GC */ } @@ -280,8 +279,8 @@ /* Don't allocate the data until we're sure that we will succeed. */ #ifdef NEW_GC - f->data = alloc_lrecord_type (struct tty_font_instance_data, - &lrecord_tty_font_instance_data); + f->data = + XTTY_FONT_INSTANCE_DATA (ALLOC_NORMAL_LISP_OBJECT (tty_font_instance_data)); #else /* not NEW_GC */ f->data = xnew (struct tty_font_instance_data); #endif /* not NEW_GC */ @@ -318,7 +317,10 @@ { #ifndef NEW_GC if (f->data) - xfree (f->data); + { + xfree (f->data); + f->data = 0; + } #endif /* not NEW_GC */ } @@ -397,8 +399,8 @@ syms_of_fontcolor_tty (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (tty_color_instance_data); - INIT_LRECORD_IMPLEMENTATION (tty_font_instance_data); + INIT_LISP_OBJECT (tty_color_instance_data); + INIT_LISP_OBJECT (tty_font_instance_data); #endif /* NEW_GC */ DEFSUBR (Fregister_tty_color);
--- a/src/fontcolor.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fontcolor.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,6 +2,7 @@ Copyright (C) 1995 Free Software Foundation, Inc. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995, 1996, 2002, 2004, 2005, 2010 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -103,25 +104,22 @@ { Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<color-instance %s", 1, c->name); write_fmt_string_lisp (printcharfun, " on %s", 1, c->device); if (!NILP (c->device)) /* Vthe_null_color_instance */ MAYBE_DEVMETH (XDEVICE (c->device), print_color_instance, (c, printcharfun, escapeflag)); - write_fmt_string (printcharfun, " 0x%x>", c->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_color_instance (void *header, int for_disksave) +finalize_color_instance (Lisp_Object obj) { - Lisp_Color_Instance *c = (Lisp_Color_Instance *) header; + Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); if (!NILP (c->device)) - { - if (for_disksave) finalose (c); - MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); - } + MAYBE_DEVMETH (XDEVICE (c->device), finalize_color_instance, (c)); } static int @@ -150,13 +148,12 @@ LISP_HASH (obj))); } -DEFINE_LRECORD_IMPLEMENTATION ("color-instance", color_instance, - 0, /*dumpable-flag*/ - mark_color_instance, print_color_instance, - finalize_color_instance, color_instance_equal, - color_instance_hash, - color_instance_description, - Lisp_Color_Instance); +DEFINE_NODUMP_LISP_OBJECT ("color-instance", color_instance, + mark_color_instance, print_color_instance, + finalize_color_instance, color_instance_equal, + color_instance_hash, + color_instance_description, + Lisp_Color_Instance); DEFUN ("make-color-instance", Fmake_color_instance, 1, 3, 0, /* Return a new `color-instance' object named NAME (a string). @@ -177,13 +174,15 @@ */ (name, device, noerror)) { + Lisp_Object obj; Lisp_Color_Instance *c; int retval; CHECK_STRING (name); device = wrap_device (decode_device (device)); - c = ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); + obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); + c = XCOLOR_INSTANCE (obj); c->name = name; c->device = device; c->data = 0; @@ -195,7 +194,7 @@ if (!retval) return Qnil; - return wrap_color_instance (c); + return obj; } DEFUN ("color-instance-p", Fcolor_instance_p, 1, 1, 0, /* @@ -320,7 +319,7 @@ { Lisp_Font_Instance *f = XFONT_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<font-instance %S", 1, f->name); write_fmt_string_lisp (printcharfun, " on %s", 1, f->device); if (!NILP (f->device)) @@ -329,17 +328,16 @@ (f, printcharfun, escapeflag)); } - write_fmt_string (printcharfun, " 0x%x>", f->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_font_instance (void *header, int for_disksave) +finalize_font_instance (Lisp_Object obj) { - Lisp_Font_Instance *f = (Lisp_Font_Instance *) header; + Lisp_Font_Instance *f = XFONT_INSTANCE (obj); if (!NILP (f->device)) { - if (for_disksave) finalose (f); MAYBE_DEVMETH (XDEVICE (f->device), finalize_font_instance, (f)); } } @@ -368,12 +366,11 @@ depth + 1); } -DEFINE_LRECORD_IMPLEMENTATION ("font-instance", font_instance, - 0, /*dumpable-flag*/ - mark_font_instance, print_font_instance, - finalize_font_instance, font_instance_equal, - font_instance_hash, font_instance_description, - Lisp_Font_Instance); +DEFINE_NODUMP_LISP_OBJECT ("font-instance", font_instance, + mark_font_instance, print_font_instance, + finalize_font_instance, font_instance_equal, + font_instance_hash, font_instance_description, + Lisp_Font_Instance); /* #### Why is this exposed to Lisp? Used in: @@ -394,6 +391,7 @@ */ (name, device, noerror, charset)) { + Lisp_Object obj; Lisp_Font_Instance *f; int retval = 0; Error_Behavior errb = decode_error_behavior_flag (noerror); @@ -405,7 +403,8 @@ device = wrap_device (decode_device (device)); - f = ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); + obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); + f = XFONT_INSTANCE (obj); f->name = name; f->truename = Qnil; f->device = device; @@ -426,7 +425,7 @@ if (!retval) return Qnil; - return wrap_font_instance (f); + return obj; } DEFUN ("font-instance-p", Ffont_instance_p, 1, 1, 0, /* @@ -1212,6 +1211,130 @@ } +/***************************************************************************** + Face Background Placement Object + ****************************************************************************/ +Lisp_Object Qabsolute, Qrelative; + +static const struct memory_description +face_background_placement_specifier_description[] = { + { XD_LISP_OBJECT, offsetof (struct face_background_placement_specifier, + face) }, + { XD_END } +}; + +DEFINE_SPECIFIER_TYPE_WITH_DATA (face_background_placement); +Lisp_Object Qface_background_placement; + +static void +face_background_placement_create (Lisp_Object obj) +{ + Lisp_Specifier *face_background_placement + = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); + + FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = Qnil; +} + +static void +face_background_placement_mark (Lisp_Object obj) +{ + Lisp_Specifier *face_background_placement + = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); + + mark_object + (FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement)); +} + +/* No equal or hash methods; ignore the face the background-placement is based + off of for `equal' */ + +extern Lisp_Object Qbackground_placement; + +static Lisp_Object +face_background_placement_instantiate (Lisp_Object UNUSED (specifier), + Lisp_Object UNUSED (matchspec), + Lisp_Object domain, + Lisp_Object instantiator, + Lisp_Object depth, + int no_fallback) +{ + /* When called, we're inside of call_with_suspended_errors(), + so we can freely error. */ + if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) + return instantiator; + else if (VECTORP (instantiator)) + { + assert (XVECTOR_LENGTH (instantiator) == 1); + + return FACE_PROPERTY_INSTANCE_1 + (Fget_face (XVECTOR_DATA (instantiator)[0]), + Qbackground_placement, domain, ERROR_ME, no_fallback, depth); + } + else + ABORT (); /* Eh? */ + + return Qunbound; +} + +static void +face_background_placement_validate (Lisp_Object instantiator) +{ + if (EQ (instantiator, Qabsolute) || EQ (instantiator, Qrelative)) + return; + else if (VECTORP (instantiator) && + (XVECTOR_LENGTH (instantiator) == 1)) + { + Lisp_Object face = XVECTOR_DATA (instantiator)[0]; + + Fget_face (face); /* just to check that the face exists -- dvl */ + } + else if (VECTORP (instantiator)) + sferror ("Wrong length for background-placement inheritance spec", + instantiator); + else + invalid_argument + ("\ +Background-placement instantiator must be absolute, relative or vector", + instantiator); +} + +static void +face_background_placement_after_change (Lisp_Object specifier, + Lisp_Object locale) +{ + Lisp_Object face + = FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE + (XFACE_BACKGROUND_PLACEMENT_SPECIFIER (specifier)); + + if (!NILP (face)) + { + face_property_was_changed (face, Qbackground_placement, locale); + if (BUFFERP (locale)) + XBUFFER (locale)->buffer_local_face_property = 1; + } +} + +void +set_face_background_placement_attached_to (Lisp_Object obj, Lisp_Object face) +{ + Lisp_Specifier *face_background_placement + = XFACE_BACKGROUND_PLACEMENT_SPECIFIER (obj); + + FACE_BACKGROUND_PLACEMENT_SPECIFIER_FACE (face_background_placement) = face; +} + +DEFUN ("face-background-placement-specifier-p", Fface_background_placement_specifier_p, 1, 1, 0, /* +Return non-nil if OBJECT is a face-background-placement specifier. + +See `make-face-background-placement-specifier' for a description of possible +face-background-placement instantiators. +*/ + (object)) +{ + return FACE_BACKGROUND_PLACEMENT_SPECIFIERP (object) ? Qt : Qnil; +} + + /************************************************************************/ /* initialization */ /************************************************************************/ @@ -1219,12 +1342,13 @@ void syms_of_fontcolor (void) { - INIT_LRECORD_IMPLEMENTATION (color_instance); - INIT_LRECORD_IMPLEMENTATION (font_instance); + INIT_LISP_OBJECT (color_instance); + INIT_LISP_OBJECT (font_instance); DEFSUBR (Fcolor_specifier_p); DEFSUBR (Ffont_specifier_p); DEFSUBR (Fface_boolean_specifier_p); + DEFSUBR (Fface_background_placement_specifier_p); DEFSYMBOL_MULTIWORD_PREDICATE (Qcolor_instancep); DEFSUBR (Fmake_color_instance); @@ -1249,6 +1373,10 @@ /* Qcolor, Qfont defined in general.c */ DEFSYMBOL (Qface_boolean); + + DEFSYMBOL (Qface_background_placement); + DEFSYMBOL (Qabsolute); + DEFSYMBOL (Qrelative); } void @@ -1258,26 +1386,35 @@ INITIALIZE_SPECIFIER_TYPE_WITH_DATA (font, "font", "font-specifier-p"); INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_boolean, "face-boolean", "face-boolean-specifier-p"); + INITIALIZE_SPECIFIER_TYPE_WITH_DATA (face_background_placement, + "face-background-placement", + "\ +face-background-placement-specifier-p"); SPECIFIER_HAS_METHOD (color, instantiate); SPECIFIER_HAS_METHOD (font, instantiate); SPECIFIER_HAS_METHOD (face_boolean, instantiate); + SPECIFIER_HAS_METHOD (face_background_placement, instantiate); SPECIFIER_HAS_METHOD (color, validate); SPECIFIER_HAS_METHOD (font, validate); SPECIFIER_HAS_METHOD (face_boolean, validate); + SPECIFIER_HAS_METHOD (face_background_placement, validate); SPECIFIER_HAS_METHOD (color, create); SPECIFIER_HAS_METHOD (font, create); SPECIFIER_HAS_METHOD (face_boolean, create); + SPECIFIER_HAS_METHOD (face_background_placement, create); SPECIFIER_HAS_METHOD (color, mark); SPECIFIER_HAS_METHOD (font, mark); SPECIFIER_HAS_METHOD (face_boolean, mark); + SPECIFIER_HAS_METHOD (face_background_placement, mark); SPECIFIER_HAS_METHOD (color, after_change); SPECIFIER_HAS_METHOD (font, after_change); SPECIFIER_HAS_METHOD (face_boolean, after_change); + SPECIFIER_HAS_METHOD (face_background_placement, after_change); #ifdef MULE SPECIFIER_HAS_METHOD (font, validate_matchspec); @@ -1290,26 +1427,26 @@ REINITIALIZE_SPECIFIER_TYPE (color); REINITIALIZE_SPECIFIER_TYPE (font); REINITIALIZE_SPECIFIER_TYPE (face_boolean); + REINITIALIZE_SPECIFIER_TYPE (face_background_placement); } void reinit_vars_of_fontcolor (void) { - staticpro_nodump (&Vthe_null_color_instance); { - Lisp_Color_Instance *c = - ALLOC_LCRECORD_TYPE (Lisp_Color_Instance, &lrecord_color_instance); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (color_instance); + Lisp_Color_Instance *c = XCOLOR_INSTANCE (obj); c->name = Qnil; c->device = Qnil; c->data = 0; - Vthe_null_color_instance = wrap_color_instance (c); + Vthe_null_color_instance = obj; + staticpro_nodump (&Vthe_null_color_instance); } - staticpro_nodump (&Vthe_null_font_instance); { - Lisp_Font_Instance *f = - ALLOC_LCRECORD_TYPE (Lisp_Font_Instance, &lrecord_font_instance); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (font_instance); + Lisp_Font_Instance *f = XFONT_INSTANCE (obj); f->name = Qnil; f->truename = Qnil; f->device = Qnil; @@ -1320,7 +1457,8 @@ f->width = 0; f->proportional_p = 0; - Vthe_null_font_instance = wrap_font_instance (f); + Vthe_null_font_instance = obj; + staticpro_nodump (&Vthe_null_font_instance); } }
--- a/src/fontcolor.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/fontcolor.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Generic object functions -- interface. Copyright (C) 1995 Board of Trustees, University of Illinois. - Copyright (C) 1995, 1996, 2002 Ben Wing. + Copyright (C) 1995, 1996, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -30,7 +30,7 @@ * Color Instance Object * ****************************************************************************/ -DECLARE_LRECORD (color_instance, Lisp_Color_Instance); +DECLARE_LISP_OBJECT (color_instance, Lisp_Color_Instance); #define XCOLOR_INSTANCE(x) XRECORD (x, color_instance, Lisp_Color_Instance) #define wrap_color_instance(p) wrap_record (p, color_instance) #define COLOR_INSTANCEP(x) RECORDP (x, color_instance) @@ -51,7 +51,7 @@ void initialize_charset_font_caches (struct device *d); void invalidate_charset_font_caches (Lisp_Object charset); -DECLARE_LRECORD (font_instance, Lisp_Font_Instance); +DECLARE_LISP_OBJECT (font_instance, Lisp_Font_Instance); #define XFONT_INSTANCE(x) XRECORD (x, font_instance, Lisp_Font_Instance) #define wrap_font_instance(p) wrap_record (p, font_instance) #define FONT_INSTANCEP(x) RECORDP (x, font_instance) @@ -76,4 +76,12 @@ void set_face_boolean_attached_to (Lisp_Object obj, Lisp_Object face, Lisp_Object property); +/***************************************************************************** + * Face Background Placement Specifier Object * + *****************************************************************************/ + +void set_face_background_placement_attached_to (Lisp_Object obj, + Lisp_Object face); + + #endif /* INCLUDED_fontcolor_h_ */
--- a/src/frame-gtk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame-gtk.c Mon Mar 29 21:28:13 2010 -0500 @@ -103,11 +103,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("gtk-frame", gtk_frame, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - gtk_frame_data_description_1, - Lisp_Gtk_Frame); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("gtk-frame", gtk_frame, + 0, gtk_frame_data_description_1, + Lisp_Gtk_Frame); #else /* not NEW_GC */ extern const struct sized_memory_description gtk_frame_data_description; @@ -635,13 +633,13 @@ { struct window *win = XWINDOW (f->root_window); - WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f); - WINDOW_TOP (win) = FRAME_TOP_BORDER_END (f); + WINDOW_LEFT (win) = FRAME_PANED_LEFT_EDGE (f); + WINDOW_TOP (win) = FRAME_PANED_TOP_EDGE (f); if (!NILP (f->minibuffer_window)) { win = XWINDOW (f->minibuffer_window); - WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f); + WINDOW_LEFT (win) = FRAME_PANED_LEFT_EDGE (f); } } @@ -974,7 +972,7 @@ /* zero out all slots. */ #ifdef NEW_GC - f->frame_data = alloc_lrecord_type (struct gtk_frame, &lrecord_gtk_frame); + f->frame_data = XGTK_FRAME (ALLOC_NORMAL_LISP_OBJECT (gtk_frame)); #else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct gtk_frame); #endif /* not NEW_GC */ @@ -1475,7 +1473,7 @@ syms_of_frame_gtk (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (gtk_frame); + INIT_LISP_OBJECT (gtk_frame); #endif /* NEW_GC */ DEFSYMBOL (Qtext_widget);
--- a/src/frame-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -41,7 +41,7 @@ struct frame { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Methods for this frame's console. This can also be retrieved through frame->device->console, but it's faster this way. */ @@ -100,17 +100,23 @@ /* Size of toolbars as seen by redisplay. This is used to determine whether to re-layout windows by a call to change_frame_size early in redisplay_frame. */ - int current_toolbar_size[4]; + int current_toolbar_size[NUM_EDGES]; #endif /* Size of gutters as seen by redisplay. This is used to determine whether to re-layout windows by a call to change_frame_size early in redisplay_frame. */ - int current_gutter_bounds[4]; + int current_gutter_bounds[NUM_EDGES]; + + /* Toolbar visibility */ + int toolbar_was_visible[NUM_EDGES]; + + /* gutter visibility */ + int gutter_was_visible[NUM_EDGES]; /* Dynamic arrays of display lines for gutters */ - display_line_dynarr *current_display_lines[4]; - display_line_dynarr *desired_display_lines[4]; + display_line_dynarr *current_display_lines[NUM_EDGES]; + display_line_dynarr *desired_display_lines[NUM_EDGES]; /* A structure of auxiliary data specific to the device type. For example, struct x_frame is for X window frames; defined in @@ -160,16 +166,6 @@ /* True if frame's root window can't be split. */ unsigned int no_split :1; - unsigned int top_toolbar_was_visible :1; - unsigned int bottom_toolbar_was_visible :1; - unsigned int left_toolbar_was_visible :1; - unsigned int right_toolbar_was_visible :1; - /* gutter visibility */ - unsigned int top_gutter_was_visible :1; - unsigned int bottom_gutter_was_visible :1; - unsigned int left_gutter_was_visible :1; - unsigned int right_gutter_was_visible :1; - /* redisplay flags */ unsigned int buffers_changed :1; unsigned int clip_changed :1; @@ -581,13 +577,13 @@ : 0) #define FRAME_THEORETICAL_TOP_TOOLBAR_HEIGHT(f) \ - FRAME_THEORETICAL_TOOLBAR_SIZE (f, TOP_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_SIZE (f, TOP_EDGE) #define FRAME_THEORETICAL_BOTTOM_TOOLBAR_HEIGHT(f) \ - FRAME_THEORETICAL_TOOLBAR_SIZE (f, BOTTOM_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_SIZE (f, BOTTOM_EDGE) #define FRAME_THEORETICAL_LEFT_TOOLBAR_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_SIZE (f, LEFT_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_SIZE (f, LEFT_EDGE) #define FRAME_THEORETICAL_RIGHT_TOOLBAR_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_SIZE (f, RIGHT_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_SIZE (f, RIGHT_EDGE) #define FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH(f, pos) \ (FRAME_RAW_THEORETICAL_TOOLBAR_VISIBLE (f, pos) \ @@ -595,13 +591,13 @@ : 0) #define FRAME_THEORETICAL_TOP_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, TOP_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, TOP_EDGE) #define FRAME_THEORETICAL_BOTTOM_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, BOTTOM_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, BOTTOM_EDGE) #define FRAME_THEORETICAL_LEFT_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, LEFT_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, LEFT_EDGE) #define FRAME_THEORETICAL_RIGHT_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, RIGHT_TOOLBAR) + FRAME_THEORETICAL_TOOLBAR_BORDER_WIDTH (f, RIGHT_EDGE) /* This returns the window-local value rather than the frame-local value; that tells you about what's actually visible rather than what should @@ -670,65 +666,122 @@ 2 * FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, pos)) #define FRAME_REAL_TOP_TOOLBAR_HEIGHT(f) \ - FRAME_REAL_TOOLBAR_SIZE (f, TOP_TOOLBAR) + FRAME_REAL_TOOLBAR_SIZE (f, TOP_EDGE) #define FRAME_REAL_BOTTOM_TOOLBAR_HEIGHT(f) \ - FRAME_REAL_TOOLBAR_SIZE (f, BOTTOM_TOOLBAR) + FRAME_REAL_TOOLBAR_SIZE (f, BOTTOM_EDGE) #define FRAME_REAL_LEFT_TOOLBAR_WIDTH(f) \ - FRAME_REAL_TOOLBAR_SIZE (f, LEFT_TOOLBAR) + FRAME_REAL_TOOLBAR_SIZE (f, LEFT_EDGE) #define FRAME_REAL_RIGHT_TOOLBAR_WIDTH(f) \ - FRAME_REAL_TOOLBAR_SIZE (f, RIGHT_TOOLBAR) + FRAME_REAL_TOOLBAR_SIZE (f, RIGHT_EDGE) #define FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, TOP_TOOLBAR) + FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, TOP_EDGE) #define FRAME_REAL_BOTTOM_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, BOTTOM_TOOLBAR) + FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, BOTTOM_EDGE) #define FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, LEFT_TOOLBAR) + FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, LEFT_EDGE) #define FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH(f) \ - FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, RIGHT_TOOLBAR) + FRAME_REAL_TOOLBAR_BORDER_WIDTH (f, RIGHT_EDGE) #define FRAME_REAL_TOP_TOOLBAR_VISIBLE(f) \ - FRAME_REAL_TOOLBAR_VISIBLE (f, TOP_TOOLBAR) + FRAME_REAL_TOOLBAR_VISIBLE (f, TOP_EDGE) #define FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE(f) \ - FRAME_REAL_TOOLBAR_VISIBLE (f, BOTTOM_TOOLBAR) + FRAME_REAL_TOOLBAR_VISIBLE (f, BOTTOM_EDGE) #define FRAME_REAL_LEFT_TOOLBAR_VISIBLE(f) \ - FRAME_REAL_TOOLBAR_VISIBLE (f, LEFT_TOOLBAR) + FRAME_REAL_TOOLBAR_VISIBLE (f, LEFT_EDGE) #define FRAME_REAL_RIGHT_TOOLBAR_VISIBLE(f) \ - FRAME_REAL_TOOLBAR_VISIBLE (f, RIGHT_TOOLBAR) + FRAME_REAL_TOOLBAR_VISIBLE (f, RIGHT_EDGE) #define FRAME_REAL_TOP_TOOLBAR_BOUNDS(f) \ - FRAME_REAL_TOOLBAR_BOUNDS (f, TOP_TOOLBAR) + FRAME_REAL_TOOLBAR_BOUNDS (f, TOP_EDGE) #define FRAME_REAL_BOTTOM_TOOLBAR_BOUNDS(f) \ - FRAME_REAL_TOOLBAR_BOUNDS (f, BOTTOM_TOOLBAR) + FRAME_REAL_TOOLBAR_BOUNDS (f, BOTTOM_EDGE) #define FRAME_REAL_LEFT_TOOLBAR_BOUNDS(f) \ - FRAME_REAL_TOOLBAR_BOUNDS (f, LEFT_TOOLBAR) + FRAME_REAL_TOOLBAR_BOUNDS (f, LEFT_EDGE) #define FRAME_REAL_RIGHT_TOOLBAR_BOUNDS(f) \ - FRAME_REAL_TOOLBAR_BOUNDS (f, RIGHT_TOOLBAR) + FRAME_REAL_TOOLBAR_BOUNDS (f, RIGHT_EDGE) /************************************************************************/ /* frame dimensions defined using toolbars and gutters */ /************************************************************************/ -/* #### These should be using the gutter sizes, but aren't yet */ +/* Bounds of the area framed by the toolbars is the client area -- + (0, 0) - (FRAME_PIXWIDTH, FRAME_PIXHEIGHT). */ -#define FRAME_TOP_BORDER_START(f) \ +/* Bounds of the area framed by the internal border width -- inside of the + toolbars, outside of everything else. */ + +#define FRAME_TOP_INTERNAL_BORDER_START(f) \ FRAME_REAL_TOP_TOOLBAR_BOUNDS (f) -#define FRAME_TOP_BORDER_END(f) \ - (FRAME_TOP_BORDER_START (f) + FRAME_INTERNAL_BORDER_HEIGHT (f)) +#define FRAME_TOP_INTERNAL_BORDER_END(f) \ + (FRAME_TOP_INTERNAL_BORDER_START (f) + FRAME_INTERNAL_BORDER_HEIGHT (f)) -#define FRAME_BOTTOM_BORDER_START(f) \ - (FRAME_BOTTOM_BORDER_END (f) - FRAME_INTERNAL_BORDER_HEIGHT (f)) -#define FRAME_BOTTOM_BORDER_END(f) \ +#define FRAME_BOTTOM_INTERNAL_BORDER_START(f) \ + (FRAME_BOTTOM_INTERNAL_BORDER_END (f) - FRAME_INTERNAL_BORDER_HEIGHT (f)) +#define FRAME_BOTTOM_INTERNAL_BORDER_END(f) \ (FRAME_PIXHEIGHT (f) - FRAME_REAL_BOTTOM_TOOLBAR_BOUNDS (f)) -#define FRAME_LEFT_BORDER_START(f) \ +#define FRAME_LEFT_INTERNAL_BORDER_START(f) \ FRAME_REAL_LEFT_TOOLBAR_BOUNDS (f) -#define FRAME_LEFT_BORDER_END(f) \ - (FRAME_LEFT_BORDER_START (f) + FRAME_INTERNAL_BORDER_WIDTH (f)) +#define FRAME_LEFT_INTERNAL_BORDER_END(f) \ + (FRAME_LEFT_INTERNAL_BORDER_START (f) + FRAME_INTERNAL_BORDER_WIDTH (f)) -#define FRAME_RIGHT_BORDER_START(f) \ - (FRAME_RIGHT_BORDER_END (f) - FRAME_INTERNAL_BORDER_WIDTH (f)) -#define FRAME_RIGHT_BORDER_END(f) \ +#define FRAME_RIGHT_INTERNAL_BORDER_START(f) \ + (FRAME_RIGHT_INTERNAL_BORDER_END (f) - FRAME_INTERNAL_BORDER_WIDTH (f)) +#define FRAME_RIGHT_INTERNAL_BORDER_END(f) \ (FRAME_PIXWIDTH (f) - FRAME_REAL_RIGHT_TOOLBAR_BOUNDS (f)) +/* Bounds of the area framed by the gutter -- inside of the + toolbars and internal border width. */ + +#define FRAME_TOP_GUTTER_START(f) \ + FRAME_TOP_INTERNAL_BORDER_END (f) +#define FRAME_TOP_GUTTER_END(f) \ + (FRAME_TOP_GUTTER_START (f) + FRAME_TOP_GUTTER_BOUNDS (f)) + +#ifdef BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER +#define FRAME_BOTTOM_GUTTER_START(f) \ + (FRAME_BOTTOM_GUTTER_END (f) - FRAME_BOTTOM_GUTTER_BOUNDS (f)) +#define FRAME_BOTTOM_GUTTER_END(f) \ + FRAME_BOTTOM_INTERNAL_BORDER_START (f) +#endif /* BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER */ + +#define FRAME_LEFT_GUTTER_START(f) \ + FRAME_LEFT_INTERNAL_BORDER_END (f) +#define FRAME_LEFT_GUTTER_END(f) \ + (FRAME_LEFT_GUTTER_START (f) + FRAME_LEFT_GUTTER_BOUNDS (f)) + +#define FRAME_RIGHT_GUTTER_START(f) \ + (FRAME_RIGHT_GUTTER_END (f) - FRAME_RIGHT_GUTTER_BOUNDS (f)) +#define FRAME_RIGHT_GUTTER_END(f) \ + FRAME_RIGHT_INTERNAL_BORDER_START (f) + +/* These are the bounds of the paned area -- inside of the toolbars, + gutters, and internal border width. The paned area is the same as the + area occupied by windows, including the minibuffer. See long comment in + frame.c. */ + +#define FRAME_PANED_TOP_EDGE(f) FRAME_TOP_GUTTER_END (f) +#ifdef BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER +#define FRAME_PANED_BOTTOM_EDGE(f) FRAME_BOTTOM_GUTTER_START (f) +#endif /* BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER */ +#define FRAME_PANED_LEFT_EDGE(f) FRAME_LEFT_GUTTER_END (f) +#define FRAME_PANED_RIGHT_EDGE(f) FRAME_RIGHT_GUTTER_START (f) + +/* Thickness of non-paned area at edge of frame; + + FRAME_PANED_TOP_EDGE (f) == FRAME_NONPANED_SIZE (f, TOP_EDGE) + FRAME_PANED_LEFT_EDGE (f) == FRAME_NONPANED_SIZE (f, LEFT_EDGE) + FRAME_PANED_BOTTOM_EDGE (f) == + FRAME_PIXHEIGHT (f) - FRAME_NONPANED_SIZE (f, BOTTOM_EDGE) + FRAME_PANED_RIGHT_EDGE (f) == + FRAME_PIXWIDTH (f) - FRAME_NONPANED_SIZE (f, RIGHT_EDGE) + +*/ +#define FRAME_NONPANED_SIZE(f, pos) \ + (FRAME_REAL_TOOLBAR_BOUNDS (f, pos) + FRAME_INTERNAL_BORDER_SIZE (f, pos) + \ + FRAME_GUTTER_BOUNDS (f, pos)) + + + #endif /* INCLUDED_frame_impl_h_ */
--- a/src/frame-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -93,11 +93,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("mswindows-frame", mswindows_frame, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - mswindows_frame_data_description_1, - Lisp_Mswindows_Frame); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("mswindows-frame", mswindows_frame, + 0, mswindows_frame_data_description_1, + Lisp_Mswindows_Frame); #else /* not NEW_GC */ extern const struct sized_memory_description mswindows_frame_data_description; @@ -174,8 +172,7 @@ CHECK_INT (height); #ifdef NEW_GC - f->frame_data = alloc_lrecord_type (struct mswindows_frame, - &lrecord_mswindows_frame); + f->frame_data = XMSWINDOWS_FRAME (ALLOC_NORMAL_LISP_OBJECT (mswindows_frame)); #else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct mswindows_frame); #endif /* not NEW_GC */ @@ -1212,7 +1209,7 @@ syms_of_frame_mswindows (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (mswindows_frame); + INIT_LISP_OBJECT (mswindows_frame); #endif /* NEW_GC */ }
--- a/src/frame-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,7 @@ /* Functions for the X window system. Copyright (C) 1989, 1992-5, 1997 Free Software Foundation, Inc. Copyright (C) 1995, 1996, 2001, 2002, 2004, 2010 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -74,11 +75,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("x-frame", x_frame, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - x_frame_data_description_1, - Lisp_X_Frame); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("x-frame", x_frame, + 0, x_frame_data_description_1, + Lisp_X_Frame); #else /* not NEW_GC */ extern const struct sized_memory_description x_frame_data_description; @@ -537,6 +536,23 @@ *y = xwa.y; } +void x_get_frame_text_position (struct frame *f) +{ + Display *dpy = DEVICE_X_DISPLAY (XDEVICE (FRAME_DEVICE (f))); + Window window = XtWindow (FRAME_X_TEXT_WIDGET (f)); + Window root, child; + int x, y; + unsigned int width, height, border_width; + unsigned int depth; + + XGetGeometry (dpy, window, &root, &x, &y, &width, &height, &border_width, + &depth); + XTranslateCoordinates (dpy, window, root, 0, 0, &x, &y, &child); + + FRAME_X_X (f) = x; + FRAME_X_Y (f) = y; +} + #if 0 static void x_smash_bastardly_shell_position (Widget shell) @@ -1434,16 +1450,13 @@ { struct window *win = XWINDOW (f->root_window); - WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f) - + FRAME_LEFT_GUTTER_BOUNDS (f); - WINDOW_TOP (win) = FRAME_TOP_BORDER_END (f) - + FRAME_TOP_GUTTER_BOUNDS (f); + WINDOW_LEFT (win) = FRAME_PANED_LEFT_EDGE (f); + WINDOW_TOP (win) = FRAME_PANED_TOP_EDGE (f); if (!NILP (f->minibuffer_window)) { win = XWINDOW (f->minibuffer_window); - WINDOW_LEFT (win) = FRAME_LEFT_BORDER_END (f) - + FRAME_LEFT_GUTTER_BOUNDS (f); + WINDOW_LEFT (win) = FRAME_PANED_LEFT_EDGE (f); } } @@ -2035,7 +2048,7 @@ { /* zero out all slots. */ #ifdef NEW_GC - f->frame_data = alloc_lrecord_type (struct x_frame, &lrecord_x_frame); + f->frame_data = XX_FRAME (ALLOC_NORMAL_LISP_OBJECT (x_frame)); #else /* not NEW_GC */ f->frame_data = xnew_and_zero (struct x_frame); #endif /* not NEW_GC */ @@ -2119,9 +2132,13 @@ static void x_init_frame_3 (struct frame *f) { - /* Pop up the frame. */ - + /* #### NOTE: This whole business of splitting frame initialization into + #### different functions is somewhat messy. The latest one seems a good + #### place to initialize the edit widget's position because we're sure + #### that the frame is now relalized. -- dvl */ + x_popup_frame (f); + x_get_frame_text_position (f); } static void @@ -2748,7 +2765,7 @@ syms_of_frame_x (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (x_frame); + INIT_LISP_OBJECT (x_frame); #endif /* NEW_GC */ DEFSYMBOL (Qoverride_redirect);
--- a/src/frame.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame.c Mon Mar 29 21:28:13 2010 -0500 @@ -35,43 +35,43 @@ | ###################################################################### | | # toolbar # | | #--------------------------------------------------------------------# | -| # | gutter | # | -| # |--------------------------------------------------------------| # | -| # | | internal border width | | # | -| # | | ******************************************************** | | # | -|w# | | * |s|v* |s* | | #w| -|i# | | * |c|e* |c* | | #i| -|n# | | * |r|r* |r* | | #n| -|d# | | * |o|t* |o* | | #d| -|o# | | * text area |l|.* text area |l* | | #o| -|w# | |i* |l| * |l*i| | #w| -|-# | |n* |b|d* |b*n| | #-| -|m# | |t* |a|i* |a*t| | #m| -|a# | |.* |r|v* |r*.| | #a| -|n# t| | *-------------------------+-|i*----------------------+-* | |t #n| -|a# o|g|b* scrollbar | |d* scrollbar | *b|g|o #a| -|g# o|u|o*-------------------------+-|e*----------------------+-*o|u|o #g| -|e# l|t|r* modeline |r* modeline *r|t|l #e| -|r# b|t|d********************************************************d|t|b #r| -| # a|e|e* =..texttexttex....= |s|v* |s*e|e|a # | -|d# r|r|r*o m=..texttexttextt..=o m|c|e* |c*r|r|r #d| -|e# | | *u a=.exttexttextte...=u a|r|r* |r* | | #e| -|c# | |w*t r=....texttexttex..=t r|o|t* |o*w| | #c| -|o# | |i*s g= etc. =s g|l|.* text area |l*i| | #o| -|r# | |d*i i= =i i|l| * |l*d| | #r| -|a# | |t*d n= =d n|b|d* |b*t| | #a| -|t# | |h*e = inner text area =e |a|i* |a*h| | #t| +| # | internal border | # | +| # | +----------------------------------------------------------+ | # | +| # | | gutter | | # | +| # | |-********************************************************-| | # | +|w# | | *@| scrollbar |v* |s* | | #w| +|i# | | *-+-------------------------|e* |c* | | #i| +|n# | | *s| |r* |r* | | #n| +|d# | | *c| |t* |o* | | #d| +|o# | | *r| |.* text area |l* | | #o| +|w# |i| *o| | * |l* |i| #w| +|-# |n| *l| text area |d* |b* |n| #-| +|m# |t| *l| |i* |a* |t| #m| +|a# |e| *b| |v* |r* |e| #a| +|n# t|r| *a| |i*----------------------+-* |r|t #n| +|a# o|n|g*r| |d* scrollbar |@*g|n|o #a| +|g# o|a|u*-+-------------------------|e*----------------------+-*u|a|o #g| +|e# l|l|t* modeline |r* modeline *t|l|l #e| +|r# b| |t********************************************************t| |b #r| +| # a|b|e* =..texttexttex....= |s|v* |s*e|b|a # | +|d# r|o|r*o m=..texttexttextt..=o m|c|e* |c*r|o|r #d| +|e# |r| *u a=.exttexttextte...=u a|r|r* |r* |r| #e| +|c# |d| *t r=....texttexttex..=t r|o|t* |o* |d| #c| +|o# |e| *s g= etc. =s g|l|.* text area |l* |e| #o| +|r# |r| *i i= =i i|l| * |l* |r| #r| +|a# | | *d n= =d n|b|d* |b* | | #a| +|t# | | *e = inner text area =e |a|i* |a* | | #t| |i# | | * = = |r|v* |r* | | #i| |o# | | *---===================---+-|i*----------------------+-* | | #o| -|n# | | * scrollbar | |d* scrollbar | * | | #n| +|n# | | * scrollbar |@|d* scrollbar |@* | | #n| | # | | *-------------------------+-|e*----------------------+-* | | # | | # | | * modeline |r* modeline * | | # | -| # | | ******************************************************** | | # | -| # | | * minibuffer * | | # | -| # | | ******************************************************** | | # | -| # | | internal border width | | # | -| # |--------------------------------------------------------------| # | -| # | gutter | # | +| # | |-********************************************************-| | # | +| # | | gutter | | # | +| # | |-********************************************************-| | # | +| # | |@* minibuffer *@| | # | +| # | +-********************************************************-+ | # | +| # | internal border | # | | #--------------------------------------------------------------------# | | # toolbar # | | ###################################################################### | @@ -79,14 +79,17 @@ +------------------------------------------------------------------------+ # = boundary of client area; * = window boundaries, boundary of paned area - = = boundary of inner text area; . = inside margin area + = = boundary of inner text area; . = inside margin area; @ = dead boxes Note in particular what happens at the corners, where a "corner box" occurs. Top and bottom toolbars take precedence over left and right toolbars, extending out horizontally into the corner boxes. Gutters work the same way. The corner box where the scrollbars meet, however, is assigned to neither scrollbar, and is known as the "dead box"; it is - an area that must be cleared specially. + an area that must be cleared specially. There are similar dead boxes at + the bottom-right and bottom-left corners where the minibuffer and + left/right gutters meet, but there is currently a bug in that these dead + boxes are not explicitly cleared and may contain junk. THE FRAME --------- @@ -184,13 +187,18 @@ THE PANED AREA -------------- - The area occupied by the "windows" is called the paned area. Note that - this includes the minibuffer, which is just another window but is - special-cased in XEmacs. Each window can include a horizontal and/or - vertical scrollbar, a modeline and a vertical divider to its right, as - well as the text area. Only non-rightmost windows can include a - vertical divider. (The minibuffer normally does not include either - modeline or scrollbars.) + The area occupied by the "windows" is called the paned area. Unfortunately, + because of the presence of the gutter *between* the minibuffer and other + windows, the bottom of the paned area is not well-defined -- does it + include the minibuffer (in which case it also includes the bottom gutter, + but none others) or does it not include the minibuffer? (In which case + not all windows are included.) #### GEOM! It would be cleaner to put the + bottom gutter *below* the minibuffer instead of above it. + + Each window can include a horizontal and/or vertical scrollbar, a + modeline and a vertical divider to its right, as well as the text area. + Only non-rightmost windows can include a vertical divider. (The + minibuffer normally does not include either modeline or scrollbars.) Note that, because the toolbars and gutters are controlled by specifiers, and specifiers can have window-specific and buffer-specific @@ -252,18 +260,23 @@ specified default character because many X fonts have a default character with a zero or otherwise non-representative width.]) - The displayable area is essentially the "theoretical" paned area of the - frame excluding the rightmost and bottom-most scrollbars. In this - context, "theoretical" means that all calculations on based on - frame-level values for toolbar, gutter and scrollbar thicknesses. - Because these thicknesses are controlled by specifiers, and specifiers - can have window-specific and buffer-specific values, these calculations - may or may not reflect the actual size of the paned area or of the - scrollbars when any particular window is selected. Note also that the - "displayable area" may not even be contiguous! In particular, if the - frame-level value of the horizontal scrollbar height is non-zero, then - the displayable area includes the paned area above and below the bottom - horizontal scrollbar but not the scrollbar itself. + The displayable area is essentially the "theoretical" gutter area of the + frame, excluding the rightmost and bottom-most scrollbars. That is, it + starts from the client (or "total") area and then excludes the + "theoretical" toolbars and bottom-most/rightmost scrollbars, and the + internal border width. In this context, "theoretical" means that all + calculations on based on frame-level values for toolbar and scrollbar + thicknesses. Because these thicknesses are controlled by specifiers, + and specifiers can have window-specific and buffer-specific values, + these calculations may or may not reflect the actual size of the paned + area or of the scrollbars when any particular window is selected. Note + also that the "displayable area" may not even be contiguous! In + particular, the gutters are included, but the bottom-most and rightmost + scrollbars are excluded even though they are inside of the gutters. + Furthermore, if the frame-level value of the horizontal scrollbar height + is non-zero, then the displayable area includes the paned area above and + below the bottom horizontal scrollbar (i.e. the modeline and minibuffer) + but not the scrollbar itself. As a further twist, the character-dimension calculations are adjusted so that the truncation and continuation glyphs (see `truncation-glyph' and @@ -308,6 +321,49 @@ */ +/* + About different types of units: + + (1) "Total pixels" measure the pixel size of the client area of the + frame (everything except the menubars and window-manager decorations; + see comment at top of file). + + (2) "Displayable pixels" measure the pixel size of the "displayable area" + of the frame, a convenient fiction that specifies which portion of + the frame "counts" for the purposes of determining the size of the + frame in character cells. Approximately speaking, the difference + between the client area and displayable area is that toolbars, + gutters, internal border width and bottom-most/right-most scrollbars + are inside the client area but outside the displayable area. See + comment at top of file for more discussion. + + (3) "Character-cell units" measure the frame size in "character cells", + which are fixed rectangles of a size meant to correspond with the + height and (average) width of the bounding box of a single character + in the default font. The size of a frame in character cells is + determined by computing the size in "displayable pixels" and dividing + by the pixel size of the default font as instantiated in the frame. + See comment at top of file under "displayable area" for more info. + + (4) In window-system "frame units" -- pixels on MS Windows, character + cells on X and GTK (on TTY's, pixels and character cells are the + same). Note that on MS Windows the pixels measure the size of the + displayable area, not the entire client area. + + This bogosity exists because MS Windows always reports frame sizes + in pixels, whereas X-Windows has a scheme whereby character-cell + sizes and extra sizes (e.g. for toolbars, menubars, etc.) can be + reported to the window manager, and the window manager displays + character-cell units when resizing, only allows resizing to integral + character-cell sizes, and reports back the size in character cells. + As a result, someone thought it was a good idea to make the + fundamental units for measuring frame size correspond to what the + window system "reports" and hence vary between pixels and character + cells, as described above. + + --ben +*/ + #include <config.h> #include "lisp.h" @@ -430,8 +486,12 @@ int *dest_width, int *dest_height); static void get_frame_char_size (struct frame *f, int *out_width, int *out_height); -static void get_frame_displayable_pixel_size (struct frame *f, int *out_width, - int *out_height); +static void get_frame_new_displayable_pixel_size (struct frame *f, + int *out_width, + int *out_height); +static void get_frame_new_total_pixel_size (struct frame *f, + int *out_width, + int *out_height); static struct display_line title_string_display_line; /* Used by generate_title_string. Global because they get used so much that @@ -439,6 +499,11 @@ static Ichar_dynarr *title_string_ichar_dynarr; +/**************************************************************************/ +/* */ +/* frame object */ +/* */ +/**************************************************************************/ #ifndef NEW_GC extern const struct sized_memory_description gtk_frame_data_description; @@ -481,12 +546,9 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("expose-ignore", - expose_ignore, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - expose_ignore_description_1, - struct expose_ignore); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("expose-ignore", expose_ignore, + 0, expose_ignore_description_1, + struct expose_ignore); #else /* not NEW_GC */ extern const struct sized_memory_description expose_ignore_description; @@ -575,24 +637,29 @@ struct frame *frm = XFRAME (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (frm->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (frm->name)); write_fmt_string (printcharfun, "#<%s-frame ", !FRAME_LIVE_P (frm) ? "dead" : FRAME_TYPE_NAME (frm)); print_internal (frm->name, printcharfun, 1); - write_fmt_string (printcharfun, " 0x%x>", frm->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } -DEFINE_LRECORD_IMPLEMENTATION ("frame", frame, - 0, /*dumpable-flag*/ - mark_frame, print_frame, 0, 0, 0, - frame_description, - struct frame); +DEFINE_NODUMP_LISP_OBJECT ("frame", frame, + mark_frame, print_frame, 0, 0, 0, + frame_description, + struct frame); +/**************************************************************************/ +/* */ +/* frame creation */ +/* */ +/**************************************************************************/ + static void nuke_all_frame_slots (struct frame *f) { - ZERO_LCRECORD (f); + zero_nonsized_lisp_object (wrap_frame (f)); #define MARKED_SLOT(x) f->x = Qnil; #include "frameslots.h" @@ -606,12 +673,11 @@ allocate_frame_core (Lisp_Object device) { /* This function can GC */ - Lisp_Object frame; Lisp_Object root_window; - struct frame *f = ALLOC_LCRECORD_TYPE (struct frame, &lrecord_frame); + Lisp_Object frame = ALLOC_NORMAL_LISP_OBJECT (frame); + struct frame *f = XFRAME (frame); nuke_all_frame_slots (f); - frame = wrap_frame (f); f->device = device; f->framemeths = XDEVICE (device)->devmeths; @@ -1026,6 +1092,12 @@ } +/**************************************************************************/ +/* */ +/* validating a frame argument */ +/* */ +/**************************************************************************/ + /* this function should be used in most cases when a Lisp function is passed a FRAME argument. Use this unless you don't accept nil == current frame (in which case, do a CHECK_LIVE_FRAME() and then an XFRAME()) or you @@ -1058,93 +1130,12 @@ return decode_frame (cdf); } -Lisp_Object -frame_device (struct frame *f) -{ - return FRAME_DEVICE (f); -} - int frame_live_p (struct frame *f) { return FRAME_LIVE_P (f); } - -void -invalidate_vertical_divider_cache_in_frame (struct frame *f) -{ - /* Invalidate cached value of needs_vertical_divider_p in - every and all windows */ - map_windows (f, invalidate_vertical_divider_cache_in_window, 0); -} - -/* - * Frame size may change due to changes in scrollbars, toolbars, - * default font etc. These changes are applied early in redisplay - * frame. - */ -void -adjust_frame_size (struct frame *f) -{ - /* This can call Lisp. */ - int keep_char_size = 0; - Lisp_Object frame = wrap_frame (f); - - if (!f->size_slipped) - return; - - /* Don't adjust tty frames. #### May break when TTY have menubars. - Then, write an Vadjust_frame_function which will return t for TTY - frames. Another solution is frame_size_fixed_p method for TTYs, - which always returned yes it's fixed. - */ - if (!FRAME_WIN_P (f)) - { - CLEAR_FRAME_SIZE_SLIPPED (f); - return; - } - - /* frame_size_fixed_p tells that frame size cannot currently - be changed change due to external conditions */ - if (!FRAMEMETH_OR_GIVEN (f, frame_size_fixed_p, (f), 0)) - { - if (NILP (Vadjust_frame_function)) - keep_char_size = 1; - else if (EQ (Vadjust_frame_function, Qt)) - keep_char_size = 0; - else - keep_char_size = - NILP (call1_trapping_problems ("Error in adjust-frame-function", - Vadjust_frame_function, frame, - 0)); - - if (keep_char_size) - Fset_frame_size (frame, make_int (FRAME_CHARWIDTH(f)), - make_int (FRAME_CHARHEIGHT(f)), Qnil); - } - - if (!keep_char_size) - { - int height, width; - pixel_to_frame_unit_size (f, FRAME_PIXWIDTH(f), FRAME_PIXHEIGHT(f), - &width, &height); - change_frame_size (f, width, height, 0); - CLEAR_FRAME_SIZE_SLIPPED (f); - } -} - -/* - * This is a "specifier changed in frame" handler for various specifiers - * changing which causes frame size adjustment - */ -void -frame_size_slipped (Lisp_Object UNUSED (specifier), struct frame *f, - Lisp_Object UNUSED (oldval)) -{ - MARK_FRAME_SIZE_SLIPPED(f); -} - DEFUN ("framep", Fframep, 1, 1, 0, /* Return non-nil if OBJECT is a frame. Also see `frame-live-p'. @@ -1165,6 +1156,27 @@ } +/**************************************************************************/ +/* */ +/* frame focus/selection */ +/* */ +/**************************************************************************/ + +Lisp_Object +frame_device (struct frame *f) +{ + return FRAME_DEVICE (f); +} + +DEFUN ("frame-device", Fframe_device, 0, 1, 0, /* +Return the device that FRAME is on. +If omitted, FRAME defaults to the currently selected frame. +*/ + (frame)) +{ + return FRAME_DEVICE (decode_frame (frame)); +} + DEFUN ("focus-frame", Ffocus_frame, 1, 1, 0, /* Select FRAME and give it the window system focus. This function is not affected by the value of `focus-follows-mouse'. @@ -1264,6 +1276,9 @@ #if 0 /* FSFmacs */ +/* Ben thinks there is no need for `redirect-frame-focus' or `frame-focus', + crockish FSFmacs functions. See summary on focus in event-stream.c. */ + DEFUN ("handle-switch-frame", Fhandle_switch_frame, 1, 2, "e", /* Handle a switch-frame event EVENT. Switch-frame events are usually bound to this function. @@ -1415,16 +1430,39 @@ return window; } - -DEFUN ("frame-device", Fframe_device, 0, 1, 0, /* -Return the device that FRAME is on. -If omitted, FRAME defaults to the currently selected frame. +DEFUN ("disable-frame", Fdisable_frame, 1, 1, 0, /* +Disable frame FRAME, so that it cannot have the focus or receive user input. +This is normally used during modal dialog boxes. +WARNING: Be very careful not to wedge XEmacs! +Use an `unwind-protect' that re-enables the frame to avoid this. */ (frame)) { - return FRAME_DEVICE (decode_frame (frame)); + struct frame *f = decode_frame (frame); + + f->disabled = 1; + MAYBE_FRAMEMETH (f, disable_frame, (f)); + return Qnil; } +DEFUN ("enable-frame", Fenable_frame, 1, 1, 0, /* +Enable frame FRAME, so that it can have the focus and receive user input. +Frames are normally enabled, unless explicitly disabled using `disable-frame'. +*/ + (frame)) +{ + struct frame *f = decode_frame (frame); + f->disabled = 0; + MAYBE_FRAMEMETH (f, enable_frame, (f)); + return Qnil; +} + +/**************************************************************************/ +/* */ +/* traversing the list of frames */ +/* */ +/**************************************************************************/ + int is_surrogate_for_selected_frame (struct frame *f) { @@ -1717,6 +1755,11 @@ } +/**************************************************************************/ +/* */ +/* frame deletion */ +/* */ +/**************************************************************************/ /* extern void free_line_insertion_deletion_costs (struct frame *f); */ @@ -2169,6 +2212,12 @@ } +/**************************************************************************/ +/* */ +/* mouse position in frame */ +/* */ +/**************************************************************************/ + /* Return mouse position in character cell units. */ static int @@ -2356,6 +2405,12 @@ return Qnil; } +/**************************************************************************/ +/* */ +/* frame visibility */ +/* */ +/**************************************************************************/ + DEFUN ("make-frame-visible", Fmake_frame_visible, 0, 1, 0, /* Make the frame FRAME visible (assuming it is an X-window). If omitted, FRAME defaults to the currently selected frame. @@ -2518,7 +2573,6 @@ return value; } - DEFUN ("raise-frame", Fraise_frame, 0, 1, "", /* Bring FRAME to the front, so it occludes any frames it overlaps. If omitted, FRAME defaults to the currently selected frame. @@ -2551,36 +2605,12 @@ } -DEFUN ("disable-frame", Fdisable_frame, 1, 1, 0, /* -Disable frame FRAME, so that it cannot have the focus or receive user input. -This is normally used during modal dialog boxes. -WARNING: Be very careful not to wedge XEmacs! -Use an `unwind-protect' that re-enables the frame to avoid this. -*/ - (frame)) -{ - struct frame *f = decode_frame (frame); - - f->disabled = 1; - MAYBE_FRAMEMETH (f, disable_frame, (f)); - return Qnil; -} - -DEFUN ("enable-frame", Fenable_frame, 1, 1, 0, /* -Enable frame FRAME, so that it can have the focus and receive user input. -Frames are normally enabled, unless explicitly disabled using `disable-frame'. -*/ - (frame)) -{ - struct frame *f = decode_frame (frame); - f->disabled = 0; - MAYBE_FRAMEMETH (f, enable_frame, (f)); - return Qnil; -} - -/* Ben thinks there is no need for `redirect-frame-focus' or `frame-focus', - crockish FSFmacs functions. See summary on focus in event-stream.c. */ - +/***************************************************************************/ +/* */ +/* print-related functions */ +/* */ +/***************************************************************************/ + DEFUN ("print-job-page-number", Fprint_job_page_number, 1, 1, 0, /* Return current page number for the print job FRAME. */ @@ -2608,9 +2638,34 @@ /***************************************************************************/ +/* */ /* frame properties */ +/* */ /***************************************************************************/ +DEFUN ("frame-name", Fframe_name, 0, 1, 0, /* +Return the name of FRAME (defaulting to the selected frame). +This is not the same as the `title' of the frame. +*/ + (frame)) +{ + return decode_frame (frame)->name; +} + +DEFUN ("frame-modified-tick", Fframe_modified_tick, 0, 1, 0, /* +Return FRAME's tick counter, incremented for each change to the frame. +Each frame has a tick counter which is incremented each time the frame +is resized, a window is resized, added, or deleted, a face is changed, +`set-window-buffer' or `select-window' is called on a window in the +frame, the window-start of a window in the frame has changed, or +anything else interesting has happened. It wraps around occasionally. +No argument or nil as argument means use selected frame as FRAME. +*/ + (frame)) +{ + return make_int (decode_frame (frame)->modiff); +} + static void store_minibuf_frame_prop (struct frame *f, Lisp_Object val) { @@ -3011,12 +3066,22 @@ } +/**************************************************************************/ +/* */ +/* frame sizing (user functions) */ +/* */ +/**************************************************************************/ + DEFUN ("frame-pixel-height", Fframe_pixel_height, 0, 1, 0, /* Return the total height in pixels of FRAME. */ (frame)) { - return make_int (decode_frame (frame)->pixheight); + struct frame *f = decode_frame (frame); + int width, height; + + get_frame_new_total_pixel_size (f, &width, &height); + return make_int (height); } DEFUN ("frame-displayable-pixel-height", Fframe_displayable_pixel_height, 0, 1, 0, /* @@ -3027,7 +3092,7 @@ struct frame *f = decode_frame (frame); int width, height; - get_frame_displayable_pixel_size (f, &width, &height); + get_frame_new_displayable_pixel_size (f, &width, &height); return make_int (height); } @@ -3036,7 +3101,11 @@ */ (frame)) { - return make_int (decode_frame (frame)->pixwidth); + struct frame *f = decode_frame (frame); + int width, height; + + get_frame_new_total_pixel_size (f, &width, &height); + return make_int (width); } DEFUN ("frame-displayable-pixel-width", Fframe_displayable_pixel_width, 0, 1, 0, /* @@ -3047,46 +3116,10 @@ struct frame *f = decode_frame (frame); int width, height; - get_frame_displayable_pixel_size (f, &width, &height); + get_frame_new_displayable_pixel_size (f, &width, &height); return make_int (width); } -DEFUN ("frame-name", Fframe_name, 0, 1, 0, /* -Return the name of FRAME (defaulting to the selected frame). -This is not the same as the `title' of the frame. -*/ - (frame)) -{ - return decode_frame (frame)->name; -} - -DEFUN ("frame-modified-tick", Fframe_modified_tick, 0, 1, 0, /* -Return FRAME's tick counter, incremented for each change to the frame. -Each frame has a tick counter which is incremented each time the frame -is resized, a window is resized, added, or deleted, a face is changed, -`set-window-buffer' or `select-window' is called on a window in the -frame, the window-start of a window in the frame has changed, or -anything else interesting has happened. It wraps around occasionally. -No argument or nil as argument means use selected frame as FRAME. -*/ - (frame)) -{ - return make_int (decode_frame (frame)->modiff); -} - -void -internal_set_frame_size (struct frame *f, int cols, int rows, int pretend) -{ - /* This can call Lisp. See mswindows_set_frame_size(). */ - /* An explicit size change cancels any pending frame size adjustment */ - CLEAR_FRAME_SIZE_SLIPPED (f); - - if (pretend || !HAS_FRAMEMETH_P (f, set_frame_size)) - change_frame_size (f, cols, rows, 0); - else - FRAMEMETH (f, set_frame_size, (f, cols, rows)); -} - DEFUN ("set-frame-height", Fset_frame_height, 2, 3, 0, /* Specify that the frame FRAME has LINES lines. Optional third arg non-nil means that redisplay should use LINES lines @@ -3121,8 +3154,8 @@ int guwidth, guheight; CHECK_INT (height); + get_frame_new_total_pixel_size (f, &pwidth, &pheight); pheight = XINT (height); - pwidth = FRAME_PIXWIDTH (f); frame_conversion_internal (f, SIZE_TOTAL_PIXEL, pwidth, pheight, SIZE_FRAME_UNIT, &guwidth, &guheight); internal_set_frame_size (f, guwidth, guheight, !NILP (pretend)); @@ -3142,7 +3175,7 @@ int guwidth, guheight; CHECK_INT (height); - get_frame_displayable_pixel_size (f, &pwidth, &pheight); + get_frame_new_displayable_pixel_size (f, &pwidth, &pheight); pheight = XINT (height); frame_conversion_internal (f, SIZE_DISPLAYABLE_PIXEL, pwidth, pheight, SIZE_FRAME_UNIT, &guwidth, &guheight); @@ -3185,8 +3218,8 @@ int guwidth, guheight; CHECK_INT (width); + get_frame_new_total_pixel_size (f, &pwidth, &pheight); pwidth = XINT (width); - pheight = FRAME_PIXHEIGHT (f); frame_conversion_internal (f, SIZE_TOTAL_PIXEL, pwidth, pheight, SIZE_FRAME_UNIT, &guwidth, &guheight); internal_set_frame_size (f, guwidth, guheight, !NILP (pretend)); @@ -3206,7 +3239,7 @@ int guwidth, guheight; CHECK_INT (width); - get_frame_displayable_pixel_size (f, &pwidth, &pheight); + get_frame_new_displayable_pixel_size (f, &pwidth, &pheight); pwidth = XINT (width); frame_conversion_internal (f, SIZE_DISPLAYABLE_PIXEL, pwidth, pheight, SIZE_FRAME_UNIT, &guwidth, &guheight); @@ -3290,6 +3323,11 @@ } +/**************************************************************************/ +/* */ +/* various ways of measuring the frame size */ +/* */ +/**************************************************************************/ /* Frame size conversion functions moved here from EmacsFrame.c because they're generic and really don't belong in that file. @@ -3297,9 +3335,13 @@ exactly the same as default_face_width_and_height(). Convert between total pixel size, displayable pixel size and - character-cell size. Variables are either "in" or "out" - depending on the value of PIXEL_TO_CHAR. -*/ + character-cell size. Variables are either "in", "out" or unused, + depending on the value of PIXEL_TO_CHAR, which indicates which units the + source and destination values are measured in. + + See frame_conversion_internal() for a discussion of the different + types of units. */ + static void frame_conversion_internal_1 (struct frame *f, pixel_to_char_mode_t pixel_to_char, @@ -3404,7 +3446,10 @@ /* Basic frame conversion function. Convert source size to destination size, where either of them can be in total pixels, displayable pixels, - frame units or character-cell units. */ + frame units or character-cell units. + + See comment at top of file for discussion about different types of + units. */ static void frame_conversion_internal (struct frame *f, @@ -3526,41 +3571,49 @@ char_to_pixel_size (f, char_width, char_height, out_width, out_height); } -/* Get the frame size in character cells, recalculating on the fly. - #### The logic of this function follows former logic elsewhere, - which used FRAME_PIXWIDTH() on pixelated-geometry systems but - FRAME_WIDTH() on non-pixelated-geometry systems. Not clear why not - always just use one or the other. - - Why don't we just use FRAME_CHARWIDTH() etc. in get_frame_char_size()? - That wouldn't work because change_frame_size_1() depends on the - following function to *set* the values of FRAME_CHARWIDTH() etc. - - But elsewhere I suppose we could use it. -*/ - static void get_frame_char_size (struct frame *f, int *out_width, int *out_height) { - if (window_system_pixelated_geometry (wrap_frame (f))) - pixel_to_char_size (f, FRAME_PIXWIDTH (f), FRAME_PIXHEIGHT (f), - out_width, out_height); - else - { - *out_width = FRAME_WIDTH (f); - *out_height = FRAME_HEIGHT (f); - } + *out_width = FRAME_CHARWIDTH (f); + *out_height = FRAME_CHARHEIGHT (f); } +/* Return the "new" frame size in displayable pixels, which will be + accurate as of next redisplay. If we have changed the default font or + toolbar or scrollbar specifiers, the frame pixel size will change as of + next redisplay, but the frame character-cell size will remain the same. + So use those dimensions to compute the displayable-pixel size. */ + static void -get_frame_displayable_pixel_size (struct frame *f, int *out_width, - int *out_height) +get_frame_new_displayable_pixel_size (struct frame *f, int *out_width, + int *out_height) { - frame_conversion_internal (f, SIZE_FRAME_UNIT, FRAME_WIDTH (f), - FRAME_HEIGHT (f), SIZE_DISPLAYABLE_PIXEL, + frame_conversion_internal (f, SIZE_CHAR_CELL, FRAME_CHARWIDTH (f), + FRAME_CHARHEIGHT (f), SIZE_DISPLAYABLE_PIXEL, out_width, out_height); } +/* Return the "new" frame size in total pixels, which will be + accurate as of next redisplay. See get_frame_new_displayable_pixel_size(). +*/ + + +static void +get_frame_new_total_pixel_size (struct frame *f, int *out_width, + int *out_height) +{ + frame_conversion_internal (f, SIZE_CHAR_CELL, FRAME_CHARWIDTH (f), + FRAME_CHARHEIGHT (f), SIZE_TOTAL_PIXEL, + out_width, out_height); +} + + +/**************************************************************************/ +/* */ +/* frame resizing (implementation) */ +/* */ +/**************************************************************************/ + /* Change the frame height and/or width. Values passed in are in frame units (character cells on X/GTK, displayable-area pixels on MS Windows or generally on pixelated-geometry window systems). */ @@ -3568,6 +3621,7 @@ change_frame_size_1 (struct frame *f, int newwidth, int newheight) { int new_pixheight, new_pixwidth; + int paned_pixheight, paned_pixwidth; int real_font_height, real_font_width; /* #### Chuck -- shouldn't we be checking to see if the frame @@ -3595,22 +3649,13 @@ /* We need to remove the boundaries of the paned area (see top of file) from the total-area pixel size, which is what we have now. - - #### We should also be subtracting the internal borders. */ - new_pixheight -= - (FRAME_REAL_TOP_TOOLBAR_BOUNDS (f) - + FRAME_REAL_BOTTOM_TOOLBAR_BOUNDS (f) - + FRAME_TOP_GUTTER_BOUNDS (f) - + FRAME_BOTTOM_GUTTER_BOUNDS (f)); - - new_pixwidth -= - (FRAME_REAL_LEFT_TOOLBAR_BOUNDS (f) - + FRAME_REAL_RIGHT_TOOLBAR_BOUNDS (f) - + FRAME_LEFT_GUTTER_BOUNDS (f) - + FRAME_RIGHT_GUTTER_BOUNDS (f)); - - XWINDOW (FRAME_ROOT_WINDOW (f))->pixel_top - = FRAME_TOP_BORDER_END (f) + FRAME_TOP_GUTTER_BOUNDS (f); + */ + paned_pixheight = new_pixheight - + (FRAME_NONPANED_SIZE (f, TOP_EDGE) + FRAME_NONPANED_SIZE (f, BOTTOM_EDGE)); + paned_pixwidth = new_pixwidth - + (FRAME_NONPANED_SIZE (f, LEFT_EDGE) + FRAME_NONPANED_SIZE (f, RIGHT_EDGE)); + + XWINDOW (FRAME_ROOT_WINDOW (f))->pixel_top = FRAME_PANED_TOP_EDGE (f); if (FRAME_HAS_MINIBUF_P (f) && ! FRAME_MINIBUF_ONLY_P (f)) @@ -3626,53 +3671,69 @@ * other frame size changes, which seems reasonable. */ int old_minibuf_height = - XWINDOW(FRAME_MINIBUF_WINDOW(f))->pixel_height; + XWINDOW (FRAME_MINIBUF_WINDOW (f))->pixel_height; int minibuf_height = f->init_finished && (old_minibuf_height % real_font_height) == 0 ? - max(old_minibuf_height, real_font_height) : + max (old_minibuf_height, real_font_height) : real_font_height; set_window_pixheight (FRAME_ROOT_WINDOW (f), /* - font_height for minibuffer */ - new_pixheight - minibuf_height, 0); + paned_pixheight - minibuf_height, 0); XWINDOW (FRAME_MINIBUF_WINDOW (f))->pixel_top = - FRAME_TOP_BORDER_END (f) + - FRAME_TOP_GUTTER_BOUNDS (f) + + FRAME_PANED_TOP_EDGE (f) + FRAME_BOTTOM_GUTTER_BOUNDS (f) + - new_pixheight - minibuf_height; + paned_pixheight - minibuf_height; set_window_pixheight (FRAME_MINIBUF_WINDOW (f), minibuf_height, 0); } else /* Frame has just one top-level window. */ - set_window_pixheight (FRAME_ROOT_WINDOW (f), new_pixheight, 0); + set_window_pixheight (FRAME_ROOT_WINDOW (f), paned_pixheight, 0); + + /* Set the value of FRAME_WIDTH/FRAME_HEIGHT and + FRAME_CHARWIDTH/FRAME_CHARHEIGHT. + + Question: Where is FRAME_PIXWIDTH/FRAME_PIXHEIGHT set? + Answer: In the device-specific code, as a result of a callback from + the window system indicating that the frame has changed size. + This happens: + + (1) in the WM_SIZE processing in event-msw.c + (2) in update_various_frame_slots() called from EmacsFrameResize() + (called from Xt when the frame is resized) in EmacsFrame.c for X + (3) in resize_event_cb() in frame-gtk.c + (4) For TTY's, there is no such callback, so we have to set it + ourselves. + */ FRAME_HEIGHT (f) = newheight; if (FRAME_TTY_P (f)) f->pixheight = newheight; - XWINDOW (FRAME_ROOT_WINDOW (f))->pixel_left = - FRAME_LEFT_BORDER_END (f) + FRAME_LEFT_GUTTER_BOUNDS (f); - set_window_pixwidth (FRAME_ROOT_WINDOW (f), new_pixwidth, 0); + XWINDOW (FRAME_ROOT_WINDOW (f))->pixel_left = FRAME_PANED_LEFT_EDGE (f); + set_window_pixwidth (FRAME_ROOT_WINDOW (f), paned_pixwidth, 0); if (FRAME_HAS_MINIBUF_P (f)) { XWINDOW (FRAME_MINIBUF_WINDOW (f))->pixel_left = - FRAME_LEFT_BORDER_END (f) + FRAME_LEFT_GUTTER_BOUNDS (f); - set_window_pixwidth (FRAME_MINIBUF_WINDOW (f), new_pixwidth, 0); + FRAME_PANED_LEFT_EDGE (f); + set_window_pixwidth (FRAME_MINIBUF_WINDOW (f), paned_pixwidth, 0); } FRAME_WIDTH (f) = newwidth; if (FRAME_TTY_P (f)) f->pixwidth = newwidth; - /* #### On MS Windows, this references FRAME_PIXWIDTH() and FRAME_PIXHEIGHT(). - I'm not sure we can count on those values being set. Instead we should - use the total pixel size we got near the top by calling - frame_conversion_internal(). We should inline the logic in - get_frame_char_size() here and change that function so it just looks - at FRAME_CHARWIDTH() and FRAME_CHARHEIGHT(). */ - get_frame_char_size (f, &FRAME_CHARWIDTH (f), &FRAME_CHARHEIGHT (f)); + /* Set the frame character-cell width appropriately. */ + if (window_system_pixelated_geometry (wrap_frame (f))) + pixel_to_char_size (f, new_pixwidth, new_pixheight, + &FRAME_CHARWIDTH (f), &FRAME_CHARHEIGHT (f)); + else + { + FRAME_CHARWIDTH (f) = FRAME_WIDTH (f); + FRAME_CHARHEIGHT (f) = FRAME_HEIGHT (f); + } MARK_FRAME_TOOLBARS_CHANGED (f); MARK_FRAME_GUTTERS_CHANGED (f); @@ -3680,6 +3741,23 @@ f->echo_area_garbaged = 1; } +/* This function is called to change the redisplay structures of a frame + to correspond to a new width and height. IT DOES NOT CHANGE THE ACTUAL + SIZE OF A FRAME. It is meant to be called after the frame has been + resized, either as a result of user action or a call to a function + such as `set-frame-size'. For example, under MS-Windows it is called + from mswindows_wnd_proc() when a WM_SIZE message is received, indicating + that the user resized the frame, and from mswindows_set_frame_size(), + which is the device method that is called (from internal_set_frame_size()) + when `set-frame-size' or similar function is called. + + Values passed in are in frame units (character cells on X/GTK, + displayable-area pixels on MS Windows or generally on pixelated-geometry + window systems). See discussion at top of file. + + See also internal_set_frame_size() and adjust_frame_size(). +*/ + void change_frame_size (struct frame *f, int newwidth, int newheight, int delay) { @@ -3719,7 +3797,147 @@ change_frame_size_1 (f, newwidth, newheight); } + +/* This function is called from `set-frame-size' or the like, to explicitly + change the size of a frame. It calls the `set_frame_size' device + method, which makes the necessary window-system-specific call to change + the size of the frame and then calls change_frame_size() to change + the redisplay structures appropriately. + + Values passed in are in frame units (character cells on X/GTK, + displayable-area pixels on MS Windows or generally on pixelated-geometry + window systems). See discussion at top of file. + */ + +void +internal_set_frame_size (struct frame *f, int cols, int rows, int pretend) +{ + /* This can call Lisp. See mswindows_set_frame_size(). */ + /* An explicit size change cancels any pending frame size adjustment */ + CLEAR_FRAME_SIZE_SLIPPED (f); + + if (pretend || !HAS_FRAMEMETH_P (f, set_frame_size)) + change_frame_size (f, cols, rows, 0); + else + FRAMEMETH (f, set_frame_size, (f, cols, rows)); +} + +/* This function is called from redisplay_frame() as a result of the + "frame_slipped" flag being set. This flag is set when the default font + changes or when a change to scrollbar or toolbar visibility or size + is made (e.g. when a specifier such as `scrollbar-width' is changed). + Its purpose is to resize the frame so that its size in character-cell + units stays the same. + + #### It should also be triggered by a change the gutter visibility or + size. + + When a scrollbar or toolbar specifier is changed, the + frame_size_slipped() function is called (this happens because the + specifier's value_changed_in_frame() hook has been set to + frame_size_slipped() by a call to set_specifier_caching()). + All this does is call MARK_FRAME_SIZE_SLIPPED(), which sets the + frame_slipped flag, which gets noticed by redisplay_frame(), as just + discussed. + + The way things get triggered when a change is made to the default font + is as follows: + + (1) The specifier for the default font, which is attached to the + face named `default', has its "face" property set to the `default' + face. + + (2) font_after_change() (the font specifier's after_changed() method) + is called for the font specifier. + + + (3) It in turn calls face_property_was_changed(), passing in the + default face. + + (4) face_property_was_changed() notices that the default face is having + a property set and calls update_EmacsFrame(). + + (5) This in turn notices that the default face's font is being changed + and calls MARK_FRAME_SIZE_SLIPPED() -- see above. + */ + +void +adjust_frame_size (struct frame *f) +{ + /* This can call Lisp. */ + int keep_char_size = 0; + Lisp_Object frame = wrap_frame (f); + + if (!f->size_slipped) + return; + + /* Don't adjust tty frames. #### May break when TTY have menubars. + Then, write an Vadjust_frame_function which will return t for TTY + frames. Another solution is frame_size_fixed_p method for TTYs, + which always returned yes it's fixed. + */ + if (!FRAME_WIN_P (f)) + { + CLEAR_FRAME_SIZE_SLIPPED (f); + return; + } + + /* frame_size_fixed_p tells that frame size cannot currently + be changed change due to external conditions */ + if (!FRAMEMETH_OR_GIVEN (f, frame_size_fixed_p, (f), 0)) + { + if (NILP (Vadjust_frame_function)) + keep_char_size = 1; + else if (EQ (Vadjust_frame_function, Qt)) + keep_char_size = 0; + else + keep_char_size = + NILP (call1_trapping_problems ("Error in adjust-frame-function", + Vadjust_frame_function, frame, + 0)); + + if (keep_char_size) + Fset_frame_size (frame, make_int (FRAME_CHARWIDTH(f)), + make_int (FRAME_CHARHEIGHT(f)), Qnil); + } + + if (!keep_char_size) + { + int height, width; + pixel_to_frame_unit_size (f, FRAME_PIXWIDTH(f), FRAME_PIXHEIGHT(f), + &width, &height); + change_frame_size (f, width, height, 0); + CLEAR_FRAME_SIZE_SLIPPED (f); + } +} + +/* This is a "specifier changed in frame" handler for various specifiers + changing which causes frame size adjustment. See the discussion in + adjust_frame_size(). + */ + +void +frame_size_slipped (Lisp_Object UNUSED (specifier), struct frame *f, + Lisp_Object UNUSED (oldval)) +{ + MARK_FRAME_SIZE_SLIPPED (f); +} + +void +invalidate_vertical_divider_cache_in_frame (struct frame *f) +{ + /* Invalidate cached value of needs_vertical_divider_p in + every and all windows */ + map_windows (f, invalidate_vertical_divider_cache_in_window, 0); +} + +/**************************************************************************/ +/* */ +/* frame title, icon, pointer */ +/* */ +/**************************************************************************/ + /* The caller is responsible for freeing the returned string. */ static Ibyte * generate_title_string (struct window *w, Lisp_Object format_str, @@ -3846,6 +4064,53 @@ } +#ifdef MEMORY_USAGE_STATS + +struct frame_stats +{ + struct usage_stats u; + Bytecount gutter; + Bytecount expose_ignore; + Bytecount other; +}; + +static void +compute_frame_usage (struct frame *f, struct frame_stats *stats, + struct usage_stats *ustats) +{ + enum edge_pos edge; + EDGE_POS_LOOP (edge) + { + stats->gutter += + compute_display_line_dynarr_usage (f->current_display_lines[edge], + ustats); + stats->gutter += + compute_display_line_dynarr_usage (f->desired_display_lines[edge], + ustats); + } + { + struct expose_ignore *e; + + for (e = f->subwindow_exposures; e; e = e->next) + stats->expose_ignore += malloced_storage_size (e, sizeof (*e), ustats); + } + +#if 0 + stats->other += FRAMEMETH (f, frame_memory_usage, (f, ustats)); +#endif +} + +static void +frame_memory_usage (Lisp_Object frame, struct generic_usage_stats *gustats) +{ + struct frame_stats *stats = (struct frame_stats *) gustats; + + compute_frame_usage (XFRAME (frame), stats, &stats->u); +} + +#endif /* MEMORY_USAGE_STATS */ + + /***************************************************************************/ /* */ /* initialization */ @@ -3853,6 +4118,14 @@ /***************************************************************************/ void +frame_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (frame, memory_usage); +#endif +} + +void init_frame (void) { #ifndef PDUMP @@ -3867,9 +4140,9 @@ void syms_of_frame (void) { - INIT_LRECORD_IMPLEMENTATION (frame); + INIT_LISP_OBJECT (frame); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (expose_ignore); + INIT_LISP_OBJECT (expose_ignore); #endif /* NEW_GC */ DEFSYMBOL (Qdelete_frame_hook); @@ -3998,6 +4271,12 @@ void vars_of_frame (void) { +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY + (frame, memusage_stats_list, list3 (Qgutter, intern ("expose-ignore"), + Qother)); +#endif /* MEMORY_USAGE_STATS */ + /* */ Vframe_being_created = Qnil; staticpro (&Vframe_being_created);
--- a/src/frame.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/frame.h Mon Mar 29 21:28:13 2010 -0500 @@ -60,7 +60,7 @@ extern Lisp_Object Vframe_icon_title_format, Vframe_title_format; extern Lisp_Object Vmouse_motion_handler; -DECLARE_LRECORD (frame, struct frame); +DECLARE_LISP_OBJECT (frame, struct frame); #define XFRAME(x) XRECORD (x, frame, struct frame) #define wrap_frame(p) wrap_record (p, frame) #define FRAMEP(x) RECORDP (x, frame) @@ -161,4 +161,18 @@ void init_frame (void); +enum edge_pos +{ + TOP_EDGE, + BOTTOM_EDGE, + LEFT_EDGE, + RIGHT_EDGE, + NUM_EDGES +}; + +/* Iterate over all possible edge positions */ +#define EDGE_POS_LOOP(var) \ + for (var = (enum edge_pos) 0; var < NUM_EDGES; \ + var = (enum edge_pos) (var + 1)) + #endif /* INCLUDED_frame_h_ */
--- a/src/free-hook.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/free-hook.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,4 +1,5 @@ -/* This file is part of XEmacs. +/* Copyright (C) 2010 Ben Wing. +This file is part of XEmacs. XEmacs is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the @@ -26,7 +27,7 @@ * Trying to free a pointer not returned by malloc. * Trying to realloc a pointer not returned by malloc. - In addition, every word of every block freed is set to 0xdeadbeef + In addition, every word of every block freed is set to 0xDEADBEEF (-559038737). This causes many uses of freed storage to be trapped or recognized. @@ -43,10 +44,10 @@ return addresses. If UNMAPPED_FREE is defined, instead of setting every word of freed - storage to 0xdeadbeef, every call to malloc goes on its own page(s). + storage to 0xDEADBEEF, every call to malloc goes on its own page(s). When free() is called, the block is read and write protected. This is very useful when debugging, since it usually generates a bus error - when the deadbeef hack might only cause some garbage to be printed. + when the DEADBEEF hack might only cause some garbage to be printed. However, this is too slow for everyday use, since it takes an enormous number of pages. @@ -170,7 +171,7 @@ if (strict_free_check) mprotect (ptr, rounded_up_size, PROT_NONE); #else - /* Set every word in the block to 0xdeadbeef */ + /* Set every word in the block to 0xDEADBEEF */ if (strict_free_check) { unsigned long long_length = (size + (sizeof (long) - 1)) @@ -180,7 +181,7 @@ /* Not using the DEADBEEF_CONSTANT #define, since we don't know * that allocation sizes will be multiples of eight. */ for (i = 0; i < long_length; i++) - ((unsigned long *) ptr)[i] = 0xdeadbeef; + ((unsigned long *) ptr)[i] = 0xDEADBEEF; } #endif free_queue[current_free].address = ptr;
--- a/src/gc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gc.c Mon Mar 29 21:28:13 2010 -0500 @@ -381,9 +381,9 @@ default: stderr_out ("Unsupported count type : %d (line = %d, code = %ld)\n", idesc[line].type, line, (long) code); -#if defined(USE_KKCC) && defined(DEBUG_XEMACS) +#if defined (USE_KKCC) && defined (DEBUG_XEMACS) if (gc_in_progress) - kkcc_backtrace (); + kkcc_detailed_backtrace (); #endif #ifdef PDUMP if (in_pdump) @@ -436,7 +436,7 @@ case XD_OPAQUE_PTR: return sizeof (void *); #ifdef NEW_GC - case XD_LISP_OBJECT_BLOCK_PTR: + case XD_INLINE_LISP_OBJECT_BLOCK_PTR: #endif /* NEW_GC */ case XD_BLOCK_PTR: { @@ -557,8 +557,13 @@ EMACS_INT offset = lispdesc_indirect_count (desc[pos].offset, desc, obj); if (offset == max_offset) { +#if 0 + /* This can legitimately happen with gap arrays -- if there are + no elements in the array, and the gap size is 0, then both + parts of the array will be of size 0 and in the same place. */ stderr_out ("Two relocatable elements at same offset?\n"); ABORT (); +#endif } else if (offset > max_offset) { @@ -589,8 +594,8 @@ #else /* not NEW_GC */ #define GC_CHECK_NOT_FREE(lheader) \ gc_checking_assert (! LRECORD_FREE_P (lheader)); \ - gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->basic_p || \ - ! ((struct old_lcrecord_header *) lheader)->free) + gc_checking_assert (LHEADER_IMPLEMENTATION (lheader)->frob_block_p || \ + ! (lheader)->free) #endif /* not NEW_GC */ #ifdef USE_KKCC @@ -611,6 +616,7 @@ void *obj; const struct memory_description *desc; int pos; + int is_lisp; } kkcc_bt_stack_entry; static kkcc_bt_stack_entry *kkcc_bt; @@ -632,25 +638,33 @@ } } +/* Workhorse backtrace function. Not static because may potentially be + called from a debugger. */ + +void kkcc_backtrace_1 (int size, int detailed); void -kkcc_backtrace (void) +kkcc_backtrace_1 (int size, int detailed) { int i; stderr_out ("KKCC mark stack backtrace :\n"); - for (i = kkcc_bt_depth - 1; i >= 0; i--) + for (i = kkcc_bt_depth - 1; i >= kkcc_bt_depth - size && i >= 0; i--) { Lisp_Object obj = wrap_pointer_1 (kkcc_bt[i].obj); - stderr_out (" [%d]", i); - if ((XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type) - || (!LRECORDP (obj)) - || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) + stderr_out (" [%d] ", i); + if (!kkcc_bt[i].is_lisp) + stderr_out ("non Lisp Object"); + else if (!LRECORDP (obj)) + stderr_out ("Lisp Object, non-record"); + else if (XRECORD_LHEADER (obj)->type >= lrecord_type_last_built_in_type + || (!XRECORD_LHEADER_IMPLEMENTATION (obj))) + stderr_out ("WARNING! Bad Lisp Object type %d", + XRECORD_LHEADER (obj)->type); + else + stderr_out ("%s", XRECORD_LHEADER_IMPLEMENTATION (obj)->name); + if (detailed && kkcc_bt[i].is_lisp) { - stderr_out (" non Lisp Object"); - } - else - { - stderr_out (" %s", - XRECORD_LHEADER_IMPLEMENTATION (obj)->name); + stderr_out (" "); + debug_print (obj); } stderr_out (" (addr: %p, desc: %p, ", (void *) kkcc_bt[i].obj, @@ -665,6 +679,76 @@ } } +/* Various front ends onto kkcc_backtrace_1(), meant to be called from + a debugger. + + The variants are: + + normal vs _full(): Normal displays up to the topmost 100 items on the + stack, whereas full displays all items (even if there are thousands) + + _detailed_() vs _short_(): Detailed here means print out the actual + Lisp objects on the stack using debug_print() in addition to their type, + whereas short means only show the type +*/ + +void +kkcc_detailed_backtrace (void) +{ + kkcc_backtrace_1 (100, 1); +} + +void kkcc_short_backtrace (void); +void +kkcc_short_backtrace (void) +{ + kkcc_backtrace_1 (100, 0); +} + +void kkcc_detailed_backtrace_full (void); +void +kkcc_detailed_backtrace_full (void) +{ + kkcc_backtrace_1 (kkcc_bt_depth, 1); +} + +void kkcc_short_backtrace_full (void); +void +kkcc_short_backtrace_full (void) +{ + kkcc_backtrace_1 (kkcc_bt_depth, 0); +} + +/* Short versions for ease in calling from a debugger */ + +void kbt (void); +void +kbt (void) +{ + kkcc_detailed_backtrace (); +} + +void kbts (void); +void +kbts (void) +{ + kkcc_short_backtrace (); +} + +void kbtf (void); +void +kbtf (void) +{ + kkcc_detailed_backtrace_full (); +} + +void kbtsf (void); +void +kbtsf (void) +{ + kkcc_short_backtrace_full (); +} + static void kkcc_bt_stack_realloc (void) { @@ -688,13 +772,14 @@ } static void -kkcc_bt_push (void *obj, const struct memory_description *desc, - int level, int pos) +kkcc_bt_push (void *obj, const struct memory_description *desc, + int is_lisp DECLARE_KKCC_DEBUG_ARGS) { kkcc_bt_depth = level; kkcc_bt[kkcc_bt_depth].obj = obj; kkcc_bt[kkcc_bt_depth].desc = desc; kkcc_bt[kkcc_bt_depth].pos = pos; + kkcc_bt[kkcc_bt_depth].is_lisp = is_lisp; kkcc_bt_depth++; if (kkcc_bt_depth >= kkcc_bt_stack_size) kkcc_bt_stack_realloc (); @@ -702,7 +787,7 @@ #else /* not DEBUG_XEMACS */ #define kkcc_bt_init() -#define kkcc_bt_push(obj, desc, level, pos) +#define kkcc_bt_push(obj, desc) #endif /* not DEBUG_XEMACS */ /* Object memory descriptions are in the lrecord_implementation structure. @@ -719,6 +804,7 @@ #ifdef DEBUG_XEMACS int level; int pos; + int is_lisp; #endif } kkcc_gc_stack_entry; @@ -794,12 +880,8 @@ } static void -#ifdef DEBUG_XEMACS -kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc, - int level, int pos) -#else -kkcc_gc_stack_push_1 (void *data, const struct memory_description *desc) -#endif +kkcc_gc_stack_push (void *data, const struct memory_description *desc + DECLARE_KKCC_DEBUG_ARGS) { #ifdef NEW_GC GC_STAT_ENQUEUED; @@ -816,12 +898,44 @@ } #ifdef DEBUG_XEMACS -#define kkcc_gc_stack_push(data, desc, level, pos) \ - kkcc_gc_stack_push_1 (data, desc, level, pos) -#else -#define kkcc_gc_stack_push(data, desc, level, pos) \ - kkcc_gc_stack_push_1 (data, desc) -#endif + +static inline void +kkcc_gc_stack_push_0 (void *data, const struct memory_description *desc, + int is_lisp DECLARE_KKCC_DEBUG_ARGS) +{ + kkcc_gc_stack_push (data, desc KKCC_DEBUG_ARGS); + kkcc_gc_stack_ptr[kkcc_gc_stack_rear].is_lisp = is_lisp; +} + +static inline void +kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc + DECLARE_KKCC_DEBUG_ARGS) +{ + kkcc_gc_stack_push_0 (data, desc, 1 KKCC_DEBUG_ARGS); +} + +static inline void +kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc + DECLARE_KKCC_DEBUG_ARGS) +{ + kkcc_gc_stack_push_0 (data, desc, 0 KKCC_DEBUG_ARGS); +} + +#else /* not DEBUG_XEMACS */ + +static inline void +kkcc_gc_stack_push_lisp (void *data, const struct memory_description *desc) +{ + kkcc_gc_stack_push (data, desc); +} + +static inline void +kkcc_gc_stack_push_nonlisp (void *data, const struct memory_description *desc) +{ + kkcc_gc_stack_push (data, desc); +} + +#endif /* (not) DEBUG_XEMACS */ static kkcc_gc_stack_entry * kkcc_gc_stack_pop (void) @@ -845,11 +959,7 @@ } void -#ifdef DEBUG_XEMACS -kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos) -#else -kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj) -#endif +kkcc_gc_stack_push_lisp_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS) { if (XTYPE (obj) == Lisp_Type_Record) { @@ -864,26 +974,15 @@ #else /* not NEW_GC */ MARK_RECORD_HEADER (lheader); #endif /* not NEW_GC */ - kkcc_gc_stack_push ((void *) lheader, desc, level, pos); + kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS); } } } #ifdef NEW_GC -#ifdef DEBUG_XEMACS -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) -#else -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj) -#endif void -#ifdef DEBUG_XEMACS -kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj, int level, int pos) -#else -kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj) -#endif +kkcc_gc_stack_repush_dirty_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS) { if (XTYPE (obj) == Lisp_Type_Record) { @@ -893,7 +992,7 @@ GC_CHECK_LHEADER_INVARIANTS (lheader); desc = RECORD_DESCRIPTION (lheader); MARK_GREY (lheader); - kkcc_gc_stack_push ((void*) lheader, desc, level, pos); + kkcc_gc_stack_push_lisp ((void*) lheader, desc KKCC_DEBUG_ARGS); } } #endif /* NEW_GC */ @@ -909,48 +1008,23 @@ } \ } while (0) #else -#define KKCC_DO_CHECK_FREE(obj, allow_free) +#define KKCC_DO_CHECK_FREE(obj, allow_free) DO_NOTHING #endif -#ifdef ERROR_CHECK_GC -#ifdef DEBUG_XEMACS -static void -mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free, - int level, int pos) -#else -static void -mark_object_maybe_checking_free_1 (Lisp_Object obj, int allow_free) -#endif +static inline void +mark_object_maybe_checking_free (Lisp_Object obj, int allow_free + DECLARE_KKCC_DEBUG_ARGS) { KKCC_DO_CHECK_FREE (obj, allow_free); - kkcc_gc_stack_push_lisp_object (obj, level, pos); + kkcc_gc_stack_push_lisp_object (obj KKCC_DEBUG_ARGS); } -#ifdef DEBUG_XEMACS -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - mark_object_maybe_checking_free_1 (obj, allow_free, level, pos) -#else -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - mark_object_maybe_checking_free_1 (obj, allow_free) -#endif -#else /* not ERROR_CHECK_GC */ -#define mark_object_maybe_checking_free(obj, allow_free, level, pos) \ - kkcc_gc_stack_push_lisp_object (obj, level, pos) -#endif /* not ERROR_CHECK_GC */ - - /* This function loops all elements of a struct pointer and calls mark_with_description with each element. */ static void -#ifdef DEBUG_XEMACS -mark_struct_contents_1 (const void *data, +mark_struct_contents (const void *data, const struct sized_memory_description *sdesc, - int count, int level, int pos) -#else -mark_struct_contents_1 (const void *data, - const struct sized_memory_description *sdesc, - int count) -#endif + int count DECLARE_KKCC_DEBUG_ARGS) { int i; Bytecount elsize; @@ -958,33 +1032,19 @@ for (i = 0; i < count; i++) { - kkcc_gc_stack_push (((char *) data) + elsize * i, sdesc->description, - level, pos); + kkcc_gc_stack_push_nonlisp (((char *) data) + elsize * i, + sdesc->description + KKCC_DEBUG_ARGS); } } -#ifdef DEBUG_XEMACS -#define mark_struct_contents(data, sdesc, count, level, pos) \ - mark_struct_contents_1 (data, sdesc, count, level, pos) -#else -#define mark_struct_contents(data, sdesc, count, level, pos) \ - mark_struct_contents_1 (data, sdesc, count) -#endif - - #ifdef NEW_GC /* This function loops all elements of a struct pointer and calls mark_with_description with each element. */ static void -#ifdef DEBUG_XEMACS -mark_lisp_object_block_contents_1 (const void *data, - const struct sized_memory_description *sdesc, - int count, int level, int pos) -#else -mark_lisp_object_block_contents_1 (const void *data, - const struct sized_memory_description *sdesc, - int count) -#endif +mark_lisp_object_block_contents (const void *data, + const struct sized_memory_description *sdesc, + int count DECLARE_KKCC_DEBUG_ARGS) { int i; Bytecount elsize; @@ -1002,19 +1062,12 @@ if (! MARKED_RECORD_HEADER_P (lheader)) { MARK_GREY (lheader); - kkcc_gc_stack_push ((void *) lheader, desc, level, pos); + kkcc_gc_stack_push_lisp ((void *) lheader, desc KKCC_DEBUG_ARGS); } } } } -#ifdef DEBUG_XEMACS -#define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \ - mark_lisp_object_block_contents_1 (data, sdesc, count, level, pos) -#else -#define mark_lisp_object_block_contents(data, sdesc, count, level, pos) \ - mark_lisp_object_block_contents_1 (data, sdesc, count) -#endif #endif /* not NEW_GC */ /* This function implements the KKCC mark algorithm. @@ -1041,8 +1094,11 @@ desc = stack_entry->desc; #ifdef DEBUG_XEMACS level = stack_entry->level + 1; + kkcc_bt_push (data, desc, stack_entry->is_lisp, stack_entry->level, + stack_entry->pos); +#else + kkcc_bt_push (data, desc); #endif - kkcc_bt_push (data, desc, stack_entry->level, stack_entry->pos); #ifdef NEW_GC /* Mark black if object is currently grey. This first checks, @@ -1093,11 +1149,12 @@ if (EQ (*stored_obj, Qnull_pointer)) break; #ifdef NEW_GC - mark_object_maybe_checking_free (*stored_obj, 0, level, pos); + mark_object_maybe_checking_free (*stored_obj, 0 + KKCC_DEBUG_ARGS); #else /* not NEW_GC */ mark_object_maybe_checking_free - (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, - level, pos); + (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT + KKCC_DEBUG_ARGS); #endif /* not NEW_GC */ break; } @@ -1116,17 +1173,17 @@ break; #ifdef NEW_GC mark_object_maybe_checking_free - (*stored_obj, 0, level, pos); + (*stored_obj, 0 KKCC_DEBUG_ARGS); #else /* not NEW_GC */ mark_object_maybe_checking_free - (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT, - level, pos); + (*stored_obj, (desc1->flags) & XD_FLAG_FREE_LISP_OBJECT + KKCC_DEBUG_ARGS); #endif /* not NEW_GC */ } break; } #ifdef NEW_GC - case XD_LISP_OBJECT_BLOCK_PTR: + case XD_INLINE_LISP_OBJECT_BLOCK_PTR: { EMACS_INT count = lispdesc_indirect_count (desc1->data1, desc, data); @@ -1135,7 +1192,7 @@ const char *dobj = * (const char **) rdata; if (dobj) mark_lisp_object_block_contents - (dobj, sdesc, count, level, pos); + (dobj, sdesc, count KKCC_DEBUG_ARGS); break; } #endif /* NEW_GC */ @@ -1147,7 +1204,7 @@ lispdesc_indirect_description (data, desc1->data2.descr); const char *dobj = * (const char **) rdata; if (dobj) - mark_struct_contents (dobj, sdesc, count, level, pos); + mark_struct_contents (dobj, sdesc, count KKCC_DEBUG_ARGS); break; } case XD_BLOCK_ARRAY: @@ -1157,7 +1214,7 @@ const struct sized_memory_description *sdesc = lispdesc_indirect_description (data, desc1->data2.descr); - mark_struct_contents (rdata, sdesc, count, level, pos); + mark_struct_contents (rdata, sdesc, count KKCC_DEBUG_ARGS); break; } case XD_UNION: @@ -1169,7 +1226,7 @@ default: stderr_out ("Unsupported description type : %d\n", desc1->type); - kkcc_backtrace (); + kkcc_detailed_backtrace (); ABORT (); } } @@ -1392,7 +1449,7 @@ } /* Keep objects alive that need to be finalized by marking Vfinalizers_to_run transitively. */ - kkcc_gc_stack_push_lisp_object (Vfinalizers_to_run, 0, -1); + kkcc_gc_stack_push_lisp_object_0 (Vfinalizers_to_run); kkcc_marking (0); } @@ -1614,7 +1671,7 @@ /* Mark all the special slots that serve as the roots of accessibility. */ #ifdef USE_KKCC -# define mark_object(obj) kkcc_gc_stack_push_lisp_object (obj, 0, -1) +# define mark_object(obj) kkcc_gc_stack_push_lisp_object_0 (obj) #endif /* USE_KKCC */ { /* staticpro() */ @@ -1774,6 +1831,7 @@ #ifdef NEW_GC GC_SET_PHASE (FINISH_GC); #endif /* NEW_GC */ + finish_object_memory_usage_stats (); consing_since_gc = 0; #ifndef DEBUG_XEMACS /* Allow you to set it really fucking low if you really want ... */
--- a/src/gc.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gc.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* New incremental garbage collector for XEmacs. Copyright (C) 2005 Marcus Crestani. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -106,31 +107,42 @@ void recompute_need_to_garbage_collect (void); +#ifdef DEBUG_XEMACS +#define KKCC_DEBUG_ARGS , level, pos +#define DECLARE_KKCC_DEBUG_ARGS , int level, int pos +#else +#define KKCC_DEBUG_ARGS +#define DECLARE_KKCC_DEBUG_ARGS +#endif + /* KKCC mark algorithm. */ +void kkcc_gc_stack_push_lisp_object (Lisp_Object obj DECLARE_KKCC_DEBUG_ARGS); +void kkcc_gc_stack_repush_dirty_object (Lisp_Object obj + DECLARE_KKCC_DEBUG_ARGS); + #ifdef DEBUG_XEMACS -void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos); -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) -void kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj, int level, int pos); -#define kkcc_gc_stack_repush_dirty_object(obj) \ - kkcc_gc_stack_repush_dirty_object_1 (obj, 0, -2) -void kkcc_backtrace (void); +#define kkcc_gc_stack_push_lisp_object_0(obj) \ + kkcc_gc_stack_push_lisp_object (obj, 0, -1) +void kkcc_backtrace_1 (int size, int detailed); +void kkcc_short_backtrace (void); +void kkcc_detailed_backtrace (void); +void kkcc_short_backtrace_full (void); +void kkcc_detailed_backtrace_full (void); #else -void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj); -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj) -void kkcc_gc_stack_repush_dirty_object_1 (Lisp_Object obj); -#define kkcc_gc_stack_repush_dirty_object(obj) \ - kkcc_gc_stack_repush_dirty_object_1 (obj) -#define kkcc_backtrace() +#define kkcc_gc_stack_push_lisp_object_0(obj) \ + kkcc_gc_stack_push_lisp_object (obj) +#define kkcc_detailed_backtrace() #endif #ifdef NEW_GC /* Repush objects that are caught by the write barrier. */ -#define gc_write_barrier(obj) kkcc_gc_stack_repush_dirty_object (obj); - +#ifdef DEBUG_XEMACS +#define gc_write_barrier(obj) kkcc_gc_stack_repush_dirty_object (obj, 0, -2) +#else +#define gc_write_barrier(obj) kkcc_gc_stack_repush_dirty_object (obj) +#endif /* GC functions: */
--- a/src/general-slots.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/general-slots.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Commonly-used symbols -- include file Copyright (C) 1995 Sun Microsystems. - Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing. + Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing. This file is part of XEmacs. @@ -46,9 +46,9 @@ SYMBOL (Qabort); SYMBOL_KEYWORD (Q_accelerator); SYMBOL_KEYWORD (Q_active); -SYMBOL (Qactually_requested); SYMBOL (Qafter); SYMBOL (Qall); +SYMBOL_KEYWORD (Q_allow_other_keys); SYMBOL (Qand); SYMBOL (Qappend); SYMBOL (Qascii); @@ -114,7 +114,6 @@ SYMBOL (Qdoc_string); SYMBOL (Qdocumentation); SYMBOL (Qduplex); -SYMBOL (Qdynarr_overhead); SYMBOL (Qemergency); SYMBOL (Qempty); SYMBOL (Qencode_as_utf_8); @@ -142,7 +141,6 @@ SYMBOL (Qfull_assoc); SYMBOL (Qfuncall); SYMBOL (Qfunction); -SYMBOL (Qgap_overhead); SYMBOL (Qgarbage_collection); SYMBOL (Qgeneric); SYMBOL (Qgeometry); @@ -192,7 +190,6 @@ SYMBOL (Qlocale); SYMBOL (Qlow); SYMBOL (Qmagic); -SYMBOL (Qmalloc_overhead); SYMBOL_KEYWORD (Q_margin_width); SYMBOL (Qmarkers); SYMBOL (Qmax);
--- a/src/glyphs-eimage.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/glyphs-eimage.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,7 +2,7 @@ Copyright (C) 1993, 1994, 1998 Free Software Foundation, Inc. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995 Tinker Systems - Copyright (C) 1995, 1996, 2001, 2002, 2004, 2005 Ben Wing + Copyright (C) 1995, 1996, 2001, 2002, 2004, 2005, 2010 Ben Wing Copyright (C) 1995 Sun Microsystems This file is part of XEmacs. @@ -177,10 +177,16 @@ jpeg_destroy_decompress (data->cinfo_ptr); if (data->instream) - retry_fclose (data->instream); + { + retry_fclose (data->instream); + data->instream = 0; + } if (data->eimage) - xfree (data->eimage); + { + xfree (data->eimage); + data->eimage = 0; + } return Qnil; } @@ -577,10 +583,14 @@ if (data->giffile) { DGifCloseFile (data->giffile); - FreeSavedImages(data->giffile); + FreeSavedImages (data->giffile); + data->giffile = 0; } if (data->eimage) - xfree (data->eimage); + { + xfree (data->eimage); + data->eimage = 0; + } return Qnil; } @@ -878,10 +888,16 @@ } if (data->instream) - retry_fclose (data->instream); + { + retry_fclose (data->instream); + data->instream = 0; + } if (data->eimage) - xfree (data->eimage); + { + xfree (data->eimage); + data->eimage = 0; + } return Qnil; } @@ -1134,10 +1150,14 @@ free_opaque_ptr (unwind_obj); if (data->tiff) { - TIFFClose(data->tiff); + TIFFClose (data->tiff); + data->tiff = 0; } if (data->eimage) - xfree (data->eimage); + { + xfree (data->eimage); + data->eimage = 0; + } return Qnil; }
--- a/src/glyphs.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/glyphs.c Mon Mar 29 21:28:13 2010 -0500 @@ -4,7 +4,7 @@ Copyright (C) 1995, 1996, 2000, 2001, 2002, 2004, 2005 Ben Wing Copyright (C) 1995 Sun Microsystems Copyright (C) 1998, 1999, 2000 Andy Piper - Copyright (C) 2007 Didier Verna + Copyright (C) 2007, 2010 Didier Verna This file is part of XEmacs. @@ -992,7 +992,7 @@ Lisp_Image_Instance *ii = XIMAGE_INSTANCE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<image-instance (%s) ", 1, Fimage_instance_type (obj)); if (!NILP (ii->name)) @@ -1108,20 +1108,19 @@ MAYBE_DEVMETH (DOMAIN_XDEVICE (ii->domain), print_image_instance, (ii, printcharfun, escapeflag)); - write_fmt_string (printcharfun, " 0x%x>", ii->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_image_instance (void *header, int for_disksave) -{ - Lisp_Image_Instance *i = (Lisp_Image_Instance *) header; +finalize_image_instance (Lisp_Object obj) +{ + Lisp_Image_Instance *i = XIMAGE_INSTANCE (obj); /* objects like this exist at dump time, so don't bomb out. */ if (IMAGE_INSTANCE_TYPE (i) == IMAGE_NOTHING || NILP (IMAGE_INSTANCE_DEVICE (i))) return; - if (for_disksave) finalose (i); /* We can't use the domain here, because it might have disappeared. */ @@ -1314,21 +1313,19 @@ 0)); } -DEFINE_LRECORD_IMPLEMENTATION ("image-instance", image_instance, - 0, /*dumpable-flag*/ - mark_image_instance, print_image_instance, - finalize_image_instance, image_instance_equal, - image_instance_hash, - image_instance_description, - Lisp_Image_Instance); +DEFINE_NODUMP_LISP_OBJECT ("image-instance", image_instance, + mark_image_instance, print_image_instance, + finalize_image_instance, image_instance_equal, + image_instance_hash, + image_instance_description, + Lisp_Image_Instance); static Lisp_Object allocate_image_instance (Lisp_Object governing_domain, Lisp_Object parent, Lisp_Object instantiator) { - Lisp_Image_Instance *lp = - ALLOC_LCRECORD_TYPE (Lisp_Image_Instance, &lrecord_image_instance); - Lisp_Object val; + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (image_instance); + Lisp_Image_Instance *lp = XIMAGE_INSTANCE (obj); /* It's not possible to simply keep a record of the domain in which the instance was instantiated. This is because caching may mean @@ -1351,10 +1348,9 @@ /* So that layouts get done. */ lp->layout_changed = 1; - val = wrap_image_instance (lp); MARK_GLYPHS_CHANGED; - return val; + return obj; } static enum image_instance_type @@ -1994,7 +1990,7 @@ device-specific method to copy the window-system subobject. */ new_ = allocate_image_instance (XIMAGE_INSTANCE_DOMAIN (image_instance), Qnil, Qnil); - COPY_LCRECORD (XIMAGE_INSTANCE (new_), XIMAGE_INSTANCE (image_instance)); + copy_lisp_object (new_, image_instance); /* note that if this method returns non-zero, this method MUST copy any window-system resources, so that when one image instance is freed, the other one is not hosed. */ @@ -2521,15 +2517,16 @@ /* pixmap file functions */ /************************************************************************/ -/* If INSTANTIATOR refers to inline data, return Qt. - If INSTANTIATOR refers to data in a file, return the full filename - if it exists, Qnil if there's no console method for locating the file, or - (filename) if there was an error locating the file. +/* - If INSTANTIATOR refers to inline data, or there is no file keyword, we + have nothing to do, so return Qt. + - If INSTANTIATOR refers to data in a file, return the full filename + if it exists; otherwise, return '(filename), meaning "file not found". + - If there is no locate_pixmap_file method for this console, return Qnil. FILE_KEYWORD and DATA_KEYWORD are symbols specifying the keywords used to look up the file and inline data, - respectively, in the instantiator. Normally these would - be Q_file and Q_data, but might be different for mask data. */ + respectively, in the instantiator. These would be Q_file and Q_data, + Q_mask_file or Q_mask_data. */ Lisp_Object potential_pixmap_file_instantiator (Lisp_Object instantiator, @@ -2736,18 +2733,20 @@ return Qnil; /* not reached */ } +/* This function attempts to find implicit mask files by appending "Mask" or + "msk" to the original bitmap file name. This is more or less standard: a + number of bitmaps in /usr/include/X11/bitmaps use it. */ Lisp_Object xbm_mask_file_munging (Lisp_Object alist, Lisp_Object file, Lisp_Object mask_file, Lisp_Object console_type) { - /* This is unclean but it's fairly standard -- a number of the - bitmaps in /usr/include/X11/bitmaps use it -- so we support - it. */ - if (EQ (mask_file, Qt) - /* don't override explicitly specified mask data. */ - && NILP (assq_no_quit (Q_mask_data, alist)) - && !EQ (file, Qt)) + /* Let's try to find an implicit mask file if we have neither an explicit + mask file name, nor inline mask data. Note that no errors are reported in + case of failure because the mask file we're looking for might not + exist. */ + if (EQ (mask_file, Qt) && NILP (assq_no_quit (Q_mask_data, alist))) { + assert (!EQ (file, Qt) && !EQ (file, Qnil)); mask_file = MAYBE_LISP_CONTYPE_METH (decode_console_type(console_type, ERROR_ME), locate_pixmap_file, (concat2 (file, build_ascstring ("Mask")))); @@ -2757,10 +2756,14 @@ locate_pixmap_file, (concat2 (file, build_ascstring ("msk")))); } + /* We got a mask file, either explicitely or from the search above. */ if (!NILP (mask_file)) { - Lisp_Object mask_data = - bitmap_to_lisp_data (mask_file, 0, 0, 0); + Lisp_Object mask_data; + + assert (!EQ (mask_file, Qt)); + + mask_data = bitmap_to_lisp_data (mask_file, 0, 0, 0); alist = remassq_no_quit (Q_mask_file, alist); /* there can't be a :mask-data at this point. */ alist = Fcons (Fcons (Q_mask_file, mask_file), @@ -2776,9 +2779,8 @@ xbm_normalize (Lisp_Object inst, Lisp_Object console_type, Lisp_Object UNUSED (dest_mask)) { - Lisp_Object file = Qnil, mask_file = Qnil; + Lisp_Object file = Qnil, mask_file = Qnil, alist = Qnil; struct gcpro gcpro1, gcpro2, gcpro3; - Lisp_Object alist = Qnil; GCPRO3 (file, mask_file, alist); @@ -2796,7 +2798,9 @@ mask_file = potential_pixmap_file_instantiator (inst, Q_mask_file, Q_mask_data, console_type); - if (NILP (file)) /* normalization impossible for the console type */ + /* No locate_pixmap_file method for this console type, so we can't get a + file (neither a mask file BTW). */ + if (NILP (file)) RETURN_UNGCPRO (Qnil); if (CONSP (file)) /* failure locating filename */ @@ -2804,6 +2808,11 @@ "no such file or directory", Fcar (file)); + if (CONSP (mask_file)) /* failure locating filename */ + signal_double_image_error ("Opening bitmap mask file", + "no such file or directory", + Fcar (mask_file)); + if (EQ (file, Qt) && EQ (mask_file, Qt)) /* no conversion necessary */ RETURN_UNGCPRO (inst); @@ -2863,10 +2872,8 @@ xface_normalize (Lisp_Object inst, Lisp_Object console_type, Lisp_Object UNUSED (dest_mask)) { - /* This function can call lisp */ - Lisp_Object file = Qnil, mask_file = Qnil; + Lisp_Object file = Qnil, mask_file = Qnil, alist = Qnil; struct gcpro gcpro1, gcpro2, gcpro3; - Lisp_Object alist = Qnil; GCPRO3 (file, mask_file, alist); @@ -2884,28 +2891,34 @@ mask_file = potential_pixmap_file_instantiator (inst, Q_mask_file, Q_mask_data, console_type); - if (NILP (file)) /* normalization impossible for the console type */ + /* No locate_pixmap_file method for this console type, so we can't get a + file (neither a mask file BTW). */ + if (NILP (file)) RETURN_UNGCPRO (Qnil); if (CONSP (file)) /* failure locating filename */ - signal_double_image_error ("Opening bitmap file", + signal_double_image_error ("Opening face file", "no such file or directory", Fcar (file)); + if (CONSP (mask_file)) /* failure locating filename */ + signal_double_image_error ("Opening face mask file", + "no such file or directory", + Fcar (mask_file)); + if (EQ (file, Qt) && EQ (mask_file, Qt)) /* no conversion necessary */ RETURN_UNGCPRO (inst); alist = tagged_vector_to_alist (inst); - { - /* #### FIXME: what if EQ (file, Qt) && !EQ (mask, Qt) ? Is that possible? - If so, we have a problem... -- dvl */ - Lisp_Object data = make_string_from_file (file); - alist = remassq_no_quit (Q_file, alist); - /* there can't be a :data at this point. */ - alist = Fcons (Fcons (Q_file, file), - Fcons (Fcons (Q_data, data), alist)); - } + if (!EQ (file, Qt)) + { + Lisp_Object data = make_string_from_file (file); + alist = remassq_no_quit (Q_file, alist); + /* there can't be a :data at this point. */ + alist = Fcons (Fcons (Q_file, file), + Fcons (Fcons (Q_data, data), alist)); + } alist = xbm_mask_file_munging (alist, file, mask_file, console_type); @@ -3694,11 +3707,11 @@ Lisp_Glyph *glyph = XGLYPH (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<glyph (%s", 1, Fglyph_type (obj)); write_fmt_string_lisp (printcharfun, ") %S", 1, glyph->image); - write_fmt_string (printcharfun, "0x%x>", glyph->header.uid); + write_fmt_string (printcharfun, "0x%x>", LISP_OBJECT_UID (obj)); } /* Glyphs are equal if all of their display attributes are equal. We @@ -3805,14 +3818,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("glyph", glyph, - 1, /*dumpable-flag*/ - mark_glyph, print_glyph, 0, - glyph_equal, glyph_hash, - glyph_description, - glyph_getprop, glyph_putprop, - glyph_remprop, glyph_plist, - Lisp_Glyph); +DEFINE_DUMPABLE_LISP_OBJECT ("glyph", glyph, + mark_glyph, print_glyph, 0, + glyph_equal, glyph_hash, + glyph_description, + Lisp_Glyph); Lisp_Object allocate_glyph (enum glyph_type type, @@ -3820,8 +3830,8 @@ Lisp_Object locale)) { /* This function can GC */ - Lisp_Object obj = Qnil; - Lisp_Glyph *g = ALLOC_LCRECORD_TYPE (Lisp_Glyph, &lrecord_glyph); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (glyph); + Lisp_Glyph *g = XGLYPH (obj); g->type = type; g->image = Fmake_specifier (Qimage); /* This function can GC */ @@ -3867,7 +3877,6 @@ g->face = Qnil; g->plist = Qnil; g->after_change = after_change; - obj = wrap_glyph (g); set_image_attached_to (g->image, obj, Qimage); UNGCPRO; @@ -4465,12 +4474,12 @@ int compute_glyph_cachel_usage (glyph_cachel_dynarr *glyph_cachels, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { int total = 0; if (glyph_cachels) - total += Dynarr_memory_usage (glyph_cachels, ovstats); + total += Dynarr_memory_usage (glyph_cachels, ustats); return total; } @@ -4537,7 +4546,7 @@ XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f)) = delq_no_quit (value, XWEAK_LIST_LIST (FRAME_SUBWINDOW_CACHE (f))); - finalize_image_instance (XIMAGE_INSTANCE (value), 0); + finalize_image_instance (value); } } return 0; @@ -4640,7 +4649,7 @@ struct expose_ignore *ei; #ifdef NEW_GC - ei = alloc_lrecord_type (struct expose_ignore, &lrecord_expose_ignore); + ei = XEXPOSE_IGNORE (ALLOC_NORMAL_LISP_OBJECT (expose_ignore)); #else /* not NEW_GC */ ei = Blocktype_alloc (the_expose_ignore_blocktype); #endif /* not NEW_GC */ @@ -5175,10 +5184,19 @@ *****************************************************************************/ void +glyph_objects_create (void) +{ + OBJECT_HAS_METHOD (glyph, getprop); + OBJECT_HAS_METHOD (glyph, putprop); + OBJECT_HAS_METHOD (glyph, remprop); + OBJECT_HAS_METHOD (glyph, plist); +} + +void syms_of_glyphs (void) { - INIT_LRECORD_IMPLEMENTATION (glyph); - INIT_LRECORD_IMPLEMENTATION (image_instance); + INIT_LISP_OBJECT (glyph); + INIT_LISP_OBJECT (image_instance); /* image instantiators */
--- a/src/glyphs.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/glyphs.h Mon Mar 29 21:28:13 2010 -0500 @@ -432,7 +432,7 @@ /* Image Instance Object */ /************************************************************************/ -DECLARE_LRECORD (image_instance, Lisp_Image_Instance); +DECLARE_LISP_OBJECT (image_instance, Lisp_Image_Instance); #define XIMAGE_INSTANCE(x) XRECORD (x, image_instance, Lisp_Image_Instance) #define wrap_image_instance(p) wrap_record (p, image_instance) #define IMAGE_INSTANCEP(x) RECORDP (x, image_instance) @@ -596,7 +596,7 @@ struct Lisp_Image_Instance { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object domain; /* The domain in which we were cached. */ Lisp_Object device; /* The device of the domain. Recorded since the domain may get deleted @@ -948,7 +948,7 @@ struct Lisp_Glyph { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; enum glyph_type type; @@ -968,7 +968,7 @@ }; typedef struct Lisp_Glyph Lisp_Glyph; -DECLARE_LRECORD (glyph, Lisp_Glyph); +DECLARE_LISP_OBJECT (glyph, Lisp_Glyph); #define XGLYPH(x) XRECORD (x, glyph, Lisp_Glyph) #define wrap_glyph(p) wrap_record (p, glyph) #define GLYPHP(x) RECORDP (x, glyph) @@ -1070,7 +1070,7 @@ struct glyph_cachel { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ Lisp_Object glyph; @@ -1090,7 +1090,7 @@ #ifdef NEW_GC typedef struct glyph_cachel Lisp_Glyph_Cachel; -DECLARE_LRECORD (glyph_cachel, Lisp_Glyph_Cachel); +DECLARE_LISP_OBJECT (glyph_cachel, Lisp_Glyph_Cachel); #define XGLYPH_CACHEL(x) \ XRECORD (x, glyph_cachel, Lisp_Glyph_Cachel) @@ -1165,7 +1165,7 @@ #ifdef MEMORY_USAGE_STATS int compute_glyph_cachel_usage (glyph_cachel_dynarr *glyph_cachels, - struct overhead_stats *ovstats); + struct usage_stats *ustats); #endif /* MEMORY_USAGE_STATS */ /************************************************************************/ @@ -1198,7 +1198,7 @@ struct expose_ignore { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ int x, y; int width, height; @@ -1206,7 +1206,7 @@ }; #ifdef NEW_GC -DECLARE_LRECORD (expose_ignore, struct expose_ignore); +DECLARE_LISP_OBJECT (expose_ignore, struct expose_ignore); #define XEXPOSE_IGNORE(x) XRECORD (x, expose_ignore, struct expose_ignore) #define wrap_expose_ignore(p) wrap_record (p, expose_ignore) #define EXPOSE_IGNOREP(x) RECORDP (x, expose_ignore)
--- a/src/gtk-glue.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gtk-glue.c Mon Mar 29 21:28:13 2010 -0500 @@ -208,17 +208,21 @@ static GdkGC * face_to_gc (Lisp_Object face) { - Lisp_Object device = Fselected_device (Qnil); + Lisp_Object frame = Fselected_frame (Qnil); - return (gtk_get_gc (XDEVICE (device), + return (gtk_get_gc (XFRAME (frame), Fspecifier_instance (Fget (face, Qfont, Qnil), - device, Qnil, Qnil), + frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qforeground, Qnil), - device, Qnil, Qnil), + frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qbackground, Qnil), - device, Qnil, Qnil), + frame, Qnil, Qnil), Fspecifier_instance (Fget (face, Qbackground_pixmap, - Qnil), device, Qnil, Qnil), + Qnil), + frame, Qnil, Qnil), + Fspecifier_instance (Fget (face, Qbackground_placement, + Qnil), + frame, Qnil, Qnil), Qnil)); }
--- a/src/gui.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gui.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Generic GUI code. (menubars, scrollbars, toolbars, dialogs) Copyright (C) 1995 Board of Trustees, University of Illinois. - Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003 Ben Wing. + Copyright (C) 1995, 1996, 2000, 2001, 2002, 2003, 2010 Ben Wing. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1998 Free Software Foundation, Inc. @@ -197,14 +197,10 @@ Lisp_Object allocate_gui_item (void) { - Lisp_Gui_Item *lp = ALLOC_LCRECORD_TYPE (Lisp_Gui_Item, &lrecord_gui_item); - Lisp_Object val; + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (gui_item); - val = wrap_gui_item (lp); - - gui_item_init (val); - - return val; + gui_item_init (obj); + return obj; } /* @@ -690,18 +686,6 @@ return 1; } -static void -print_gui_item (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED (escapeflag)) -{ - Lisp_Gui_Item *g = XGUI_ITEM (obj); - - if (print_readably) - printing_unreadable_lcrecord (obj, 0); - - write_fmt_string (printcharfun, "#<gui-item 0x%x>", g->header.uid); -} - Lisp_Object copy_gui_item (Lisp_Object gui_item) { @@ -807,13 +791,12 @@ RETURN_UNGCPRO (ret); } -DEFINE_LRECORD_IMPLEMENTATION ("gui-item", gui_item, - 0, /*dumpable-flag*/ - mark_gui_item, print_gui_item, - 0, gui_item_equal, - gui_item_hash, - gui_item_description, - Lisp_Gui_Item); +DEFINE_NODUMP_LISP_OBJECT ("gui-item", gui_item, + mark_gui_item, external_object_printer, + 0, gui_item_equal, + gui_item_hash, + gui_item_description, + Lisp_Gui_Item); DOESNT_RETURN gui_error (const Ascbyte *reason, Lisp_Object frob) @@ -830,7 +813,7 @@ void syms_of_gui (void) { - INIT_LRECORD_IMPLEMENTATION (gui_item); + INIT_LISP_OBJECT (gui_item); DEFSYMBOL (Qmenu_no_selection_hook);
--- a/src/gui.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gui.h Mon Mar 29 21:28:13 2010 -0500 @@ -44,7 +44,7 @@ menu item or submenu properties */ struct Lisp_Gui_Item { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object name; /* String */ Lisp_Object callback; /* Symbol or form */ Lisp_Object callback_ex; /* Form taking context arguments */ @@ -60,7 +60,7 @@ Lisp_Object value; /* Anything you like */ }; -DECLARE_LRECORD (gui_item, Lisp_Gui_Item); +DECLARE_LISP_OBJECT (gui_item, Lisp_Gui_Item); #define XGUI_ITEM(x) XRECORD (x, gui_item, Lisp_Gui_Item) #define wrap_gui_item(p) wrap_record (p, gui_item) #define GUI_ITEMP(x) RECORDP (x, gui_item)
--- a/src/gutter.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gutter.c Mon Mar 29 21:28:13 2010 -0500 @@ -36,10 +36,10 @@ #include "window.h" #include "gutter.h" -Lisp_Object Vgutter[4]; -Lisp_Object Vgutter_size[4]; -Lisp_Object Vgutter_visible_p[4]; -Lisp_Object Vgutter_border_width[4]; +Lisp_Object Vgutter[NUM_EDGES]; +Lisp_Object Vgutter_size[NUM_EDGES]; +Lisp_Object Vgutter_visible_p[NUM_EDGES]; +Lisp_Object Vgutter_border_width[NUM_EDGES]; Lisp_Object Vdefault_gutter, Vdefault_gutter_visible_p; Lisp_Object Vdefault_gutter_width, Vdefault_gutter_height; @@ -52,46 +52,7 @@ Lisp_Object Qdefault_gutter_position_changed_hook; static void -update_gutter_geometry (struct frame *f, enum gutter_pos pos); - -#define SET_GUTTER_WAS_VISIBLE_FLAG(frame, pos, flag) \ - do { \ - switch (pos) \ - { \ - case TOP_GUTTER: \ - (frame)->top_gutter_was_visible = flag; \ - break; \ - case BOTTOM_GUTTER: \ - (frame)->bottom_gutter_was_visible = flag; \ - break; \ - case LEFT_GUTTER: \ - (frame)->left_gutter_was_visible = flag; \ - break; \ - case RIGHT_GUTTER: \ - (frame)->right_gutter_was_visible = flag; \ - break; \ - default: \ - ABORT (); \ - } \ - } while (0) - -static int gutter_was_visible (struct frame* frame, enum gutter_pos pos) -{ - switch (pos) - { - case TOP_GUTTER: - return frame->top_gutter_was_visible; - case BOTTOM_GUTTER: - return frame->bottom_gutter_was_visible; - case LEFT_GUTTER: - return frame->left_gutter_was_visible; - case RIGHT_GUTTER: - return frame->right_gutter_was_visible; - default: - ABORT (); - return 0; /* To keep the compiler happy */ - } -} +update_gutter_geometry (struct frame *f, enum edge_pos pos); #if 0 static Lisp_Object @@ -172,46 +133,48 @@ if it is not the window nearest the gutter. Instead we predetermine the nearest window and then use that.*/ static void -get_gutter_coords (struct frame *f, enum gutter_pos pos, int *x, int *y, +get_gutter_coords (struct frame *f, enum edge_pos pos, int *x, int *y, int *width, int *height) { - struct window - * bot = XWINDOW (frame_bottommost_window (f)); + /* We use the bottommost window (not the minibuffer, but the bottommost + non-minibuffer window) rather than any FRAME_BOTTOM_GUTTER_START + because the gutter goes *above* the minibuffer -- for this same reason, + FRAME_BOTTOM_GUTTER_START isn't currently defined. */ + struct window *bot = XWINDOW (frame_bottommost_window (f)); /* The top and bottom gutters take precedence over the left and right. */ switch (pos) { - case TOP_GUTTER: - *x = FRAME_LEFT_BORDER_END (f); - *y = FRAME_TOP_BORDER_END (f); - *width = FRAME_RIGHT_BORDER_START (f) - - FRAME_LEFT_BORDER_END (f); + case TOP_EDGE: + *x = FRAME_LEFT_GUTTER_START (f); + *y = FRAME_TOP_GUTTER_START (f); + *width = FRAME_RIGHT_GUTTER_END (f) - *x; *height = FRAME_TOP_GUTTER_BOUNDS (f); break; - case BOTTOM_GUTTER: - *x = FRAME_LEFT_BORDER_END (f); + case BOTTOM_EDGE: + *x = FRAME_LEFT_GUTTER_START (f); +#ifdef BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER + *y = FRAME_BOTTOM_GUTTER_START (f); +#else *y = WINDOW_BOTTOM (bot); - *width = FRAME_RIGHT_BORDER_START (f) - - FRAME_LEFT_BORDER_END (f); +#endif + *width = FRAME_RIGHT_GUTTER_END (f) - *x; *height = FRAME_BOTTOM_GUTTER_BOUNDS (f); break; - case LEFT_GUTTER: - *x = FRAME_LEFT_BORDER_END (f); - *y = FRAME_TOP_BORDER_END (f) + FRAME_TOP_GUTTER_BOUNDS (f); + case LEFT_EDGE: + *x = FRAME_LEFT_GUTTER_START (f); + *y = FRAME_TOP_GUTTER_END (f); *width = FRAME_LEFT_GUTTER_BOUNDS (f); - *height = WINDOW_BOTTOM (bot) - - (FRAME_TOP_BORDER_END (f) + FRAME_TOP_GUTTER_BOUNDS (f)); + *height = WINDOW_BOTTOM (bot) - *y; break; - case RIGHT_GUTTER: - *x = FRAME_RIGHT_BORDER_START (f) - - FRAME_RIGHT_GUTTER_BOUNDS (f); - *y = FRAME_TOP_BORDER_END (f) + FRAME_TOP_GUTTER_BOUNDS (f); + case RIGHT_EDGE: + *x = FRAME_RIGHT_GUTTER_START (f); + *y = FRAME_TOP_GUTTER_END (f); *width = FRAME_RIGHT_GUTTER_BOUNDS (f); - *height = WINDOW_BOTTOM (bot) - - (FRAME_TOP_BORDER_END (f) + FRAME_TOP_GUTTER_BOUNDS (f)); + *height = WINDOW_BOTTOM (bot) - *y; break; default: @@ -230,8 +193,8 @@ int display_boxes_in_gutter_p (struct frame *f, struct display_box* db, struct display_glyph_area* dga) { - enum gutter_pos pos; - GUTTER_POS_LOOP (pos) + enum edge_pos pos; + EDGE_POS_LOOP (pos) { if (FRAME_GUTTER_VISIBLE (f, pos)) { @@ -257,7 +220,7 @@ /* Convert the gutter specifier into something we can actually display. */ static Lisp_Object construct_window_gutter_spec (struct window* w, - enum gutter_pos pos) + enum edge_pos pos) { Lisp_Object rest, *args; int nargs = 0; @@ -289,14 +252,14 @@ what height will accommodate all lines. This is useless on left and right gutters as we always have a maximal number of lines. */ static int -calculate_gutter_size_from_display_lines (enum gutter_pos pos, +calculate_gutter_size_from_display_lines (enum edge_pos pos, display_line_dynarr* ddla) { int size = 0; struct display_line *dl; /* For top and bottom the calculation is easy. */ - if (pos == TOP_GUTTER || pos == BOTTOM_GUTTER) + if (pos == TOP_EDGE || pos == BOTTOM_EDGE) { /* grab coordinates of last line */ if (Dynarr_length (ddla)) @@ -333,7 +296,7 @@ } static Lisp_Object -calculate_gutter_size (struct window *w, enum gutter_pos pos) +calculate_gutter_size (struct window *w, enum edge_pos pos) { struct frame* f = XFRAME (WINDOW_FRAME (w)); display_line_dynarr *ddla; @@ -360,12 +323,20 @@ ddla = Dynarr_new (display_line); /* generate some display lines */ generate_displayable_area (w, WINDOW_GUTTER (w, pos), - FRAME_LEFT_BORDER_END (f), - FRAME_TOP_BORDER_END (f), - FRAME_RIGHT_BORDER_START (f) - - FRAME_LEFT_BORDER_END (f), - FRAME_BOTTOM_BORDER_START (f) - - FRAME_TOP_BORDER_END (f), + FRAME_LEFT_GUTTER_START (f), + FRAME_TOP_GUTTER_START (f), + FRAME_RIGHT_GUTTER_END (f) + - FRAME_LEFT_GUTTER_START (f), +#ifdef BOTTOM_GUTTER_IS_OUTSIDE_MINIBUFFER + FRAME_BOTTOM_GUTTER_END (f) +#else + /* #### GEOM! This is how it used to read, + and this includes both gutter and + minibuffer below it. Not clear whether + it was intended that way. --ben */ + FRAME_BOTTOM_INTERNAL_BORDER_START (f) +#endif + - FRAME_TOP_GUTTER_START (f), ddla, 0, DEFAULT_INDEX); /* Let GC happen again. */ @@ -379,7 +350,7 @@ } static void -output_gutter (struct frame *f, enum gutter_pos pos, int force) +output_gutter (struct frame *f, enum edge_pos pos, int force) { Lisp_Object window = FRAME_LAST_NONMINIBUF_WINDOW (f); struct device *d = XDEVICE (f->device); @@ -426,9 +397,9 @@ { #ifdef DEBUG_GUTTERS stderr_out ("gutter redisplay [%s %dx%d@%d+%d] triggered by %s,\n", - pos == TOP_GUTTER ? "TOP" : - pos == BOTTOM_GUTTER ? "BOTTOM" : - pos == LEFT_GUTTER ? "LEFT" : "RIGHT", + pos == TOP_EDGE ? "TOP" : + pos == BOTTOM_EDGE ? "BOTTOM" : + pos == LEFT_EDGE ? "LEFT" : "RIGHT", width, height, x, y, force ? "force" : f->faces_changed ? "f->faces_changed" : f->frame_changed ? "f->frame_changed" : @@ -512,7 +483,7 @@ } static void -clear_gutter (struct frame *f, enum gutter_pos pos) +clear_gutter (struct frame *f, enum edge_pos pos) { int x, y, width, height; Lisp_Object window = FRAME_LAST_NONMINIBUF_WINDOW (f); @@ -520,7 +491,7 @@ Vwidget_face); get_gutter_coords (f, pos, &x, &y, &width, &height); - SET_GUTTER_WAS_VISIBLE_FLAG (f, pos, 0); + f->gutter_was_visible[pos] = 0; redisplay_clear_region (window, findex, x, y, width, height); } @@ -537,8 +508,8 @@ void mark_gutters (struct frame *f) { - enum gutter_pos pos; - GUTTER_POS_LOOP (pos) + enum edge_pos pos; + EDGE_POS_LOOP (pos) { if (f->current_display_lines[pos]) mark_redisplay_structs (f->current_display_lines[pos]); @@ -564,11 +535,11 @@ FRAME_LOOP_NO_BREAK (frmcons, devcons, concons) { struct frame *f = XFRAME (XCAR (frmcons)); - enum gutter_pos pos; + enum edge_pos pos; Lisp_Object window = FRAME_LAST_NONMINIBUF_WINDOW (f); struct window* w = XWINDOW (window); - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { if (EQ (WINDOW_GUTTER (w, pos), obj)) { @@ -581,7 +552,7 @@ /* We have to change the gutter geometry separately to the gutter update since it needs to occur outside of redisplay proper. */ static void -update_gutter_geometry (struct frame *f, enum gutter_pos pos) +update_gutter_geometry (struct frame *f, enum edge_pos pos) { /* If the gutter geometry has changed then re-layout the frame. If we are in display there is almost no point in doing @@ -607,13 +578,13 @@ || f->frame_layout_changed || f->windows_structure_changed) { - enum gutter_pos pos; + enum edge_pos pos; /* If the gutter geometry has changed then re-layout the frame. If we are in display there is almost no point in doing anything else since the frame size changes will be delayed until we are out of redisplay proper. */ - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { update_gutter_geometry (f, pos); } @@ -629,7 +600,7 @@ f->windows_changed || f->windows_structure_changed || f->extents_changed || f->frame_layout_changed) { - enum gutter_pos pos; + enum edge_pos pos; /* We don't actually care about these when outputting the gutter so locally disable them. */ @@ -639,12 +610,12 @@ f->buffers_changed = 0; /* and output */ - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { if (FRAME_GUTTER_VISIBLE (f, pos)) output_gutter (f, pos, 0); - else if (gutter_was_visible (f, pos)) + else if (f->gutter_was_visible[pos]) clear_gutter (f, pos); } @@ -657,8 +628,8 @@ void reset_gutter_display_lines (struct frame* f) { - enum gutter_pos pos; - GUTTER_POS_LOOP (pos) + enum edge_pos pos; + EDGE_POS_LOOP (pos) { if (f->current_display_lines[pos]) Dynarr_reset (f->current_display_lines[pos]); @@ -666,7 +637,7 @@ } static void -redraw_exposed_gutter (struct frame *f, enum gutter_pos pos, int x, int y, +redraw_exposed_gutter (struct frame *f, enum edge_pos pos, int x, int y, int width, int height) { int g_x, g_y, g_width, g_height; @@ -697,10 +668,10 @@ redraw_exposed_gutters (struct frame *f, int x, int y, int width, int height) { - enum gutter_pos pos; + enum edge_pos pos; /* We are already inside the critical section -- our caller did that. */ - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { if (FRAME_GUTTER_VISIBLE (f, pos)) redraw_exposed_gutter (f, pos, x, y, width, height); @@ -710,8 +681,8 @@ void free_frame_gutters (struct frame *f) { - enum gutter_pos pos; - GUTTER_POS_LOOP (pos) + enum edge_pos pos; + EDGE_POS_LOOP (pos) { if (f->current_display_lines[pos]) { @@ -726,16 +697,16 @@ } } -static enum gutter_pos +static enum edge_pos decode_gutter_position (Lisp_Object position) { - if (EQ (position, Qtop)) return TOP_GUTTER; - if (EQ (position, Qbottom)) return BOTTOM_GUTTER; - if (EQ (position, Qleft)) return LEFT_GUTTER; - if (EQ (position, Qright)) return RIGHT_GUTTER; + if (EQ (position, Qtop)) return TOP_EDGE; + if (EQ (position, Qbottom)) return BOTTOM_EDGE; + if (EQ (position, Qleft)) return LEFT_EDGE; + if (EQ (position, Qright)) return RIGHT_EDGE; invalid_constant ("Invalid gutter position", position); - RETURN_NOT_REACHED (TOP_GUTTER); + RETURN_NOT_REACHED (TOP_EDGE); } DEFUN ("set-default-gutter-position", Fset_default_gutter_position, 1, 1, 0, /* @@ -745,8 +716,8 @@ */ (position)) { - enum gutter_pos cur = decode_gutter_position (Vdefault_gutter_position); - enum gutter_pos new_ = decode_gutter_position (position); + enum edge_pos cur = decode_gutter_position (Vdefault_gutter_position); + enum edge_pos new_ = decode_gutter_position (position); if (cur != new_) { @@ -760,7 +731,7 @@ set_specifier_fallback (Vgutter[new_], Vdefault_gutter); set_specifier_fallback (Vgutter_size[cur], list1 (Fcons (Qnil, Qzero))); set_specifier_fallback (Vgutter_size[new_], - new_ == TOP_GUTTER || new_ == BOTTOM_GUTTER + new_ == TOP_EDGE || new_ == BOTTOM_EDGE ? Vdefault_gutter_height : Vdefault_gutter_width); set_specifier_fallback (Vgutter_border_width[cur], @@ -797,7 +768,7 @@ (pos, locale)) { int x, y, width, height; - enum gutter_pos p = TOP_GUTTER; + enum edge_pos p = TOP_EDGE; struct frame *f = decode_frame (FW_FRAME (locale)); if (NILP (pos)) @@ -818,7 +789,7 @@ (pos, locale)) { int x, y, width, height; - enum gutter_pos p = TOP_GUTTER; + enum edge_pos p = TOP_EDGE; struct frame *f = decode_frame (FW_FRAME (locale)); if (NILP (pos)) @@ -880,26 +851,26 @@ specifier caching changes */ static void -recompute_overlaying_specifier (Lisp_Object real_one[4]) +recompute_overlaying_specifier (Lisp_Object real_one[NUM_EDGES]) { - enum gutter_pos pos = decode_gutter_position (Vdefault_gutter_position); + enum edge_pos pos = decode_gutter_position (Vdefault_gutter_position); Fset_specifier_dirty_flag (real_one[pos]); } static void gutter_specs_changed (Lisp_Object specifier, struct window *w, - Lisp_Object oldval, enum gutter_pos pos); + Lisp_Object oldval, enum edge_pos pos); static void gutter_specs_changed_1 (Lisp_Object arg) { gutter_specs_changed (X1ST (arg), XWINDOW (X2ND (arg)), - X3RD (arg), (enum gutter_pos) XINT (X4TH (arg))); + X3RD (arg), (enum edge_pos) XINT (X4TH (arg))); free_list (arg); } static void gutter_specs_changed (Lisp_Object specifier, struct window *w, - Lisp_Object oldval, enum gutter_pos pos) + Lisp_Object oldval, enum edge_pos pos) { if (in_display) register_post_redisplay_action (gutter_specs_changed_1, @@ -926,28 +897,28 @@ top_gutter_specs_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { - gutter_specs_changed (specifier, w, oldval, TOP_GUTTER); + gutter_specs_changed (specifier, w, oldval, TOP_EDGE); } static void bottom_gutter_specs_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { - gutter_specs_changed (specifier, w, oldval, BOTTOM_GUTTER); + gutter_specs_changed (specifier, w, oldval, BOTTOM_EDGE); } static void left_gutter_specs_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { - gutter_specs_changed (specifier, w, oldval, LEFT_GUTTER); + gutter_specs_changed (specifier, w, oldval, LEFT_EDGE); } static void right_gutter_specs_changed (Lisp_Object specifier, struct window *w, Lisp_Object oldval) { - gutter_specs_changed (specifier, w, oldval, RIGHT_GUTTER); + gutter_specs_changed (specifier, w, oldval, RIGHT_EDGE); } static void @@ -980,8 +951,8 @@ oldval)); else { - enum gutter_pos pos; - GUTTER_POS_LOOP (pos) + enum edge_pos pos; + EDGE_POS_LOOP (pos) { w->real_gutter_size[pos] = w->gutter_size[pos]; if (EQ (w->real_gutter_size[pos], Qautodetect) @@ -1152,12 +1123,12 @@ void init_frame_gutters (struct frame *f) { - enum gutter_pos pos; + enum edge_pos pos; struct window* w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); /* We are here as far in frame creation so cached specifiers are already recomputed, and possibly modified by resource initialization. We need to recalculate autodetected gutters. */ - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { w->real_gutter[pos] = construct_window_gutter_spec (w, pos); w->real_gutter_size[pos] = w->gutter_size[pos]; @@ -1171,7 +1142,7 @@ } /* Keep a record of the current sizes of things. */ - GUTTER_POS_LOOP (pos) + EDGE_POS_LOOP (pos) { f->current_gutter_bounds[pos] = FRAME_GUTTER_BOUNDS (f, pos); } @@ -1279,19 +1250,19 @@ 0, 0, 1); DEFVAR_SPECIFIER ("top-gutter", - &Vgutter[TOP_GUTTER] /* + &Vgutter[TOP_EDGE] /* Specifier for the gutter at the top of the frame. Use `set-specifier' to change this. See `default-gutter' for a description of a valid gutter instantiator. */ ); - Vgutter[TOP_GUTTER] = Fmake_specifier (Qgutter); - set_specifier_caching (Vgutter[TOP_GUTTER], - offsetof (struct window, gutter[TOP_GUTTER]), + Vgutter[TOP_EDGE] = Fmake_specifier (Qgutter); + set_specifier_caching (Vgutter[TOP_EDGE], + offsetof (struct window, gutter[TOP_EDGE]), top_gutter_specs_changed, 0, 0, 1); DEFVAR_SPECIFIER ("bottom-gutter", - &Vgutter[BOTTOM_GUTTER] /* + &Vgutter[BOTTOM_EDGE] /* Specifier for the gutter at the bottom of the frame. Use `set-specifier' to change this. See `default-gutter' for a description of a valid gutter instantiator. @@ -1301,14 +1272,14 @@ `bottom-gutter-height') is 0; thus, a bottom gutter will not be displayed even if you provide a value for `bottom-gutter'. */ ); - Vgutter[BOTTOM_GUTTER] = Fmake_specifier (Qgutter); - set_specifier_caching (Vgutter[BOTTOM_GUTTER], - offsetof (struct window, gutter[BOTTOM_GUTTER]), + Vgutter[BOTTOM_EDGE] = Fmake_specifier (Qgutter); + set_specifier_caching (Vgutter[BOTTOM_EDGE], + offsetof (struct window, gutter[BOTTOM_EDGE]), bottom_gutter_specs_changed, 0, 0, 1); DEFVAR_SPECIFIER ("left-gutter", - &Vgutter[LEFT_GUTTER] /* + &Vgutter[LEFT_EDGE] /* Specifier for the gutter at the left edge of the frame. Use `set-specifier' to change this. See `default-gutter' for a description of a valid gutter instantiator. @@ -1318,14 +1289,14 @@ `left-gutter-width') is 0; thus, a left gutter will not be displayed even if you provide a value for `left-gutter'. */ ); - Vgutter[LEFT_GUTTER] = Fmake_specifier (Qgutter); - set_specifier_caching (Vgutter[LEFT_GUTTER], - offsetof (struct window, gutter[LEFT_GUTTER]), + Vgutter[LEFT_EDGE] = Fmake_specifier (Qgutter); + set_specifier_caching (Vgutter[LEFT_EDGE], + offsetof (struct window, gutter[LEFT_EDGE]), left_gutter_specs_changed, 0, 0, 1); DEFVAR_SPECIFIER ("right-gutter", - &Vgutter[RIGHT_GUTTER] /* + &Vgutter[RIGHT_EDGE] /* Specifier for the gutter at the right edge of the frame. Use `set-specifier' to change this. See `default-gutter' for a description of a valid gutter instantiator. @@ -1335,9 +1306,9 @@ `right-gutter-width') is 0; thus, a right gutter will not be displayed even if you provide a value for `right-gutter'. */ ); - Vgutter[RIGHT_GUTTER] = Fmake_specifier (Qgutter); - set_specifier_caching (Vgutter[RIGHT_GUTTER], - offsetof (struct window, gutter[RIGHT_GUTTER]), + Vgutter[RIGHT_EDGE] = Fmake_specifier (Qgutter); + set_specifier_caching (Vgutter[RIGHT_EDGE], + offsetof (struct window, gutter[RIGHT_EDGE]), right_gutter_specs_changed, 0, 0, 1); @@ -1345,10 +1316,10 @@ changed with `set-default-gutter-position'. */ fb = list1 (Fcons (Qnil, Qnil)); set_specifier_fallback (Vdefault_gutter, fb); - set_specifier_fallback (Vgutter[TOP_GUTTER], Vdefault_gutter); - set_specifier_fallback (Vgutter[BOTTOM_GUTTER], fb); - set_specifier_fallback (Vgutter[LEFT_GUTTER], fb); - set_specifier_fallback (Vgutter[RIGHT_GUTTER], fb); + set_specifier_fallback (Vgutter[TOP_EDGE], Vdefault_gutter); + set_specifier_fallback (Vgutter[BOTTOM_EDGE], fb); + set_specifier_fallback (Vgutter[LEFT_EDGE], fb); + set_specifier_fallback (Vgutter[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-gutter-height", &Vdefault_gutter_height /* *Height of the default gutter, if it's oriented horizontally. @@ -1394,51 +1365,51 @@ 0, 0, 1); DEFVAR_SPECIFIER ("top-gutter-height", - &Vgutter_size[TOP_GUTTER] /* + &Vgutter_size[TOP_EDGE] /* *Height of the top gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_size[TOP_GUTTER] = Fmake_specifier (Qgutter_size); - set_specifier_caching (Vgutter_size[TOP_GUTTER], - offsetof (struct window, gutter_size[TOP_GUTTER]), + Vgutter_size[TOP_EDGE] = Fmake_specifier (Qgutter_size); + set_specifier_caching (Vgutter_size[TOP_EDGE], + offsetof (struct window, gutter_size[TOP_EDGE]), gutter_geometry_changed_in_window, 0, 0, 1); DEFVAR_SPECIFIER ("bottom-gutter-height", - &Vgutter_size[BOTTOM_GUTTER] /* + &Vgutter_size[BOTTOM_EDGE] /* *Height of the bottom gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_size[BOTTOM_GUTTER] = Fmake_specifier (Qgutter_size); - set_specifier_caching (Vgutter_size[BOTTOM_GUTTER], - offsetof (struct window, gutter_size[BOTTOM_GUTTER]), + Vgutter_size[BOTTOM_EDGE] = Fmake_specifier (Qgutter_size); + set_specifier_caching (Vgutter_size[BOTTOM_EDGE], + offsetof (struct window, gutter_size[BOTTOM_EDGE]), gutter_geometry_changed_in_window, 0, 0, 1); DEFVAR_SPECIFIER ("left-gutter-width", - &Vgutter_size[LEFT_GUTTER] /* + &Vgutter_size[LEFT_EDGE] /* *Width of left gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_size[LEFT_GUTTER] = Fmake_specifier (Qgutter_size); - set_specifier_caching (Vgutter_size[LEFT_GUTTER], - offsetof (struct window, gutter_size[LEFT_GUTTER]), + Vgutter_size[LEFT_EDGE] = Fmake_specifier (Qgutter_size); + set_specifier_caching (Vgutter_size[LEFT_EDGE], + offsetof (struct window, gutter_size[LEFT_EDGE]), gutter_geometry_changed_in_window, 0, 0, 1); DEFVAR_SPECIFIER ("right-gutter-width", - &Vgutter_size[RIGHT_GUTTER] /* + &Vgutter_size[RIGHT_EDGE] /* *Width of right gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_size[RIGHT_GUTTER] = Fmake_specifier (Qgutter_size); - set_specifier_caching (Vgutter_size[RIGHT_GUTTER], - offsetof (struct window, gutter_size[RIGHT_GUTTER]), + Vgutter_size[RIGHT_EDGE] = Fmake_specifier (Qgutter_size); + set_specifier_caching (Vgutter_size[RIGHT_EDGE], + offsetof (struct window, gutter_size[RIGHT_EDGE]), gutter_geometry_changed_in_window, 0, 0, 1); fb = Qnil; @@ -1475,11 +1446,11 @@ if (!NILP (fb)) set_specifier_fallback (Vdefault_gutter_width, fb); - set_specifier_fallback (Vgutter_size[TOP_GUTTER], Vdefault_gutter_height); + set_specifier_fallback (Vgutter_size[TOP_EDGE], Vdefault_gutter_height); fb = list1 (Fcons (Qnil, Qzero)); - set_specifier_fallback (Vgutter_size[BOTTOM_GUTTER], fb); - set_specifier_fallback (Vgutter_size[LEFT_GUTTER], fb); - set_specifier_fallback (Vgutter_size[RIGHT_GUTTER], fb); + set_specifier_fallback (Vgutter_size[BOTTOM_EDGE], fb); + set_specifier_fallback (Vgutter_size[LEFT_EDGE], fb); + set_specifier_fallback (Vgutter_size[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-gutter-border-width", &Vdefault_gutter_border_width /* @@ -1502,55 +1473,55 @@ 0, 0, 0); DEFVAR_SPECIFIER ("top-gutter-border-width", - &Vgutter_border_width[TOP_GUTTER] /* + &Vgutter_border_width[TOP_EDGE] /* *Border width of the top gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_border_width[TOP_GUTTER] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vgutter_border_width[TOP_GUTTER], + Vgutter_border_width[TOP_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vgutter_border_width[TOP_EDGE], offsetof (struct window, - gutter_border_width[TOP_GUTTER]), + gutter_border_width[TOP_EDGE]), gutter_geometry_changed_in_window, 0, 0, 0); DEFVAR_SPECIFIER ("bottom-gutter-border-width", - &Vgutter_border_width[BOTTOM_GUTTER] /* + &Vgutter_border_width[BOTTOM_EDGE] /* *Border width of the bottom gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_border_width[BOTTOM_GUTTER] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vgutter_border_width[BOTTOM_GUTTER], + Vgutter_border_width[BOTTOM_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vgutter_border_width[BOTTOM_EDGE], offsetof (struct window, - gutter_border_width[BOTTOM_GUTTER]), + gutter_border_width[BOTTOM_EDGE]), gutter_geometry_changed_in_window, 0, 0, 0); DEFVAR_SPECIFIER ("left-gutter-border-width", - &Vgutter_border_width[LEFT_GUTTER] /* + &Vgutter_border_width[LEFT_EDGE] /* *Border width of left gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_border_width[LEFT_GUTTER] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vgutter_border_width[LEFT_GUTTER], + Vgutter_border_width[LEFT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vgutter_border_width[LEFT_EDGE], offsetof (struct window, - gutter_border_width[LEFT_GUTTER]), + gutter_border_width[LEFT_EDGE]), gutter_geometry_changed_in_window, 0, 0, 0); DEFVAR_SPECIFIER ("right-gutter-border-width", - &Vgutter_border_width[RIGHT_GUTTER] /* + &Vgutter_border_width[RIGHT_EDGE] /* *Border width of right gutter. This is a specifier; use `set-specifier' to change it. See `default-gutter-height' for more information. */ ); - Vgutter_border_width[RIGHT_GUTTER] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vgutter_border_width[RIGHT_GUTTER], + Vgutter_border_width[RIGHT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vgutter_border_width[RIGHT_EDGE], offsetof (struct window, - gutter_border_width[RIGHT_GUTTER]), + gutter_border_width[RIGHT_EDGE]), gutter_geometry_changed_in_window, 0, 0, 0); fb = Qnil; @@ -1567,11 +1538,11 @@ if (!NILP (fb)) set_specifier_fallback (Vdefault_gutter_border_width, fb); - set_specifier_fallback (Vgutter_border_width[TOP_GUTTER], Vdefault_gutter_border_width); + set_specifier_fallback (Vgutter_border_width[TOP_EDGE], Vdefault_gutter_border_width); fb = list1 (Fcons (Qnil, Qzero)); - set_specifier_fallback (Vgutter_border_width[BOTTOM_GUTTER], fb); - set_specifier_fallback (Vgutter_border_width[LEFT_GUTTER], fb); - set_specifier_fallback (Vgutter_border_width[RIGHT_GUTTER], fb); + set_specifier_fallback (Vgutter_border_width[BOTTOM_EDGE], fb); + set_specifier_fallback (Vgutter_border_width[LEFT_EDGE], fb); + set_specifier_fallback (Vgutter_border_width[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-gutter-visible-p", &Vdefault_gutter_visible_p /* *Whether the default gutter is visible. @@ -1596,64 +1567,64 @@ 0, 0, 0); DEFVAR_SPECIFIER ("top-gutter-visible-p", - &Vgutter_visible_p[TOP_GUTTER] /* + &Vgutter_visible_p[TOP_EDGE] /* *Whether the top gutter is visible. This is a specifier; use `set-specifier' to change it. See `default-gutter-visible-p' for more information. */ ); - Vgutter_visible_p[TOP_GUTTER] = Fmake_specifier (Qgutter_visible); - set_specifier_caching (Vgutter_visible_p[TOP_GUTTER], + Vgutter_visible_p[TOP_EDGE] = Fmake_specifier (Qgutter_visible); + set_specifier_caching (Vgutter_visible_p[TOP_EDGE], offsetof (struct window, - gutter_visible_p[TOP_GUTTER]), + gutter_visible_p[TOP_EDGE]), top_gutter_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("bottom-gutter-visible-p", - &Vgutter_visible_p[BOTTOM_GUTTER] /* + &Vgutter_visible_p[BOTTOM_EDGE] /* *Whether the bottom gutter is visible. This is a specifier; use `set-specifier' to change it. See `default-gutter-visible-p' for more information. */ ); - Vgutter_visible_p[BOTTOM_GUTTER] = Fmake_specifier (Qgutter_visible); - set_specifier_caching (Vgutter_visible_p[BOTTOM_GUTTER], + Vgutter_visible_p[BOTTOM_EDGE] = Fmake_specifier (Qgutter_visible); + set_specifier_caching (Vgutter_visible_p[BOTTOM_EDGE], offsetof (struct window, - gutter_visible_p[BOTTOM_GUTTER]), + gutter_visible_p[BOTTOM_EDGE]), bottom_gutter_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("left-gutter-visible-p", - &Vgutter_visible_p[LEFT_GUTTER] /* + &Vgutter_visible_p[LEFT_EDGE] /* *Whether the left gutter is visible. This is a specifier; use `set-specifier' to change it. See `default-gutter-visible-p' for more information. */ ); - Vgutter_visible_p[LEFT_GUTTER] = Fmake_specifier (Qgutter_visible); - set_specifier_caching (Vgutter_visible_p[LEFT_GUTTER], + Vgutter_visible_p[LEFT_EDGE] = Fmake_specifier (Qgutter_visible); + set_specifier_caching (Vgutter_visible_p[LEFT_EDGE], offsetof (struct window, - gutter_visible_p[LEFT_GUTTER]), + gutter_visible_p[LEFT_EDGE]), left_gutter_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("right-gutter-visible-p", - &Vgutter_visible_p[RIGHT_GUTTER] /* + &Vgutter_visible_p[RIGHT_EDGE] /* *Whether the right gutter is visible. This is a specifier; use `set-specifier' to change it. See `default-gutter-visible-p' for more information. */ ); - Vgutter_visible_p[RIGHT_GUTTER] = Fmake_specifier (Qgutter_visible); - set_specifier_caching (Vgutter_visible_p[RIGHT_GUTTER], + Vgutter_visible_p[RIGHT_EDGE] = Fmake_specifier (Qgutter_visible); + set_specifier_caching (Vgutter_visible_p[RIGHT_EDGE], offsetof (struct window, - gutter_visible_p[RIGHT_GUTTER]), + gutter_visible_p[RIGHT_EDGE]), right_gutter_specs_changed, 0, 0, 0); /* initially, top inherits from default; this can be changed with `set-default-gutter-position'. */ fb = list1 (Fcons (Qnil, Qt)); set_specifier_fallback (Vdefault_gutter_visible_p, fb); - set_specifier_fallback (Vgutter_visible_p[TOP_GUTTER], + set_specifier_fallback (Vgutter_visible_p[TOP_EDGE], Vdefault_gutter_visible_p); - set_specifier_fallback (Vgutter_visible_p[BOTTOM_GUTTER], fb); - set_specifier_fallback (Vgutter_visible_p[LEFT_GUTTER], fb); - set_specifier_fallback (Vgutter_visible_p[RIGHT_GUTTER], fb); + set_specifier_fallback (Vgutter_visible_p[BOTTOM_EDGE], fb); + set_specifier_fallback (Vgutter_visible_p[LEFT_EDGE], fb); + set_specifier_fallback (Vgutter_visible_p[RIGHT_EDGE], fb); }
--- a/src/gutter.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/gutter.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* Define general gutter support. Copyright (C) 1999 Andy Piper. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -36,18 +37,6 @@ #define DEFAULT_GUTTER_WIDTH 40 #define DEFAULT_GUTTER_BORDER_WIDTH 2 -enum gutter_pos -{ - TOP_GUTTER = 0, - BOTTOM_GUTTER = 1, - LEFT_GUTTER = 2, - RIGHT_GUTTER = 3 -}; - -/* Iterate over all possible gutter positions */ -#define GUTTER_POS_LOOP(var) \ - for (var = (enum gutter_pos) 0; var < 4; var = (enum gutter_pos) (var + 1)) - extern Lisp_Object Qgutter; extern Lisp_Object Vgutter_size[4]; @@ -97,13 +86,13 @@ /* these macros predicate size on position and type of window */ #define WINDOW_REAL_TOP_GUTTER_BOUNDS(w) \ - WINDOW_REAL_GUTTER_BOUNDS (w,TOP_GUTTER) + WINDOW_REAL_GUTTER_BOUNDS (w, TOP_EDGE) #define WINDOW_REAL_BOTTOM_GUTTER_BOUNDS(w) \ - WINDOW_REAL_GUTTER_BOUNDS (w,BOTTOM_GUTTER) + WINDOW_REAL_GUTTER_BOUNDS (w, BOTTOM_EDGE) #define WINDOW_REAL_LEFT_GUTTER_BOUNDS(w) \ - WINDOW_REAL_GUTTER_BOUNDS (w,LEFT_GUTTER) + WINDOW_REAL_GUTTER_BOUNDS (w, LEFT_EDGE) #define WINDOW_REAL_RIGHT_GUTTER_BOUNDS(w) \ - WINDOW_REAL_GUTTER_BOUNDS (w,RIGHT_GUTTER) + WINDOW_REAL_GUTTER_BOUNDS (w, RIGHT_EDGE) #define FRAME_GUTTER_VISIBLE(f, pos) \ WINDOW_REAL_GUTTER_VISIBLE (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), pos) @@ -118,13 +107,9 @@ WINDOW_GUTTER (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), pos) /* these macros predicate size on position and type of window */ -#define FRAME_TOP_GUTTER_BOUNDS(f) \ - WINDOW_REAL_GUTTER_BOUNDS (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), TOP_GUTTER) -#define FRAME_BOTTOM_GUTTER_BOUNDS(f) \ - WINDOW_REAL_GUTTER_BOUNDS (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), BOTTOM_GUTTER) -#define FRAME_LEFT_GUTTER_BOUNDS(f) \ - WINDOW_REAL_GUTTER_BOUNDS (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), LEFT_GUTTER) -#define FRAME_RIGHT_GUTTER_BOUNDS(f) \ - WINDOW_REAL_GUTTER_BOUNDS (XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)), RIGHT_GUTTER) +#define FRAME_TOP_GUTTER_BOUNDS(f) FRAME_GUTTER_BOUNDS (f, TOP_EDGE) +#define FRAME_BOTTOM_GUTTER_BOUNDS(f) FRAME_GUTTER_BOUNDS (f, BOTTOM_EDGE) +#define FRAME_LEFT_GUTTER_BOUNDS(f) FRAME_GUTTER_BOUNDS (f, LEFT_EDGE) +#define FRAME_RIGHT_GUTTER_BOUNDS(f) FRAME_GUTTER_BOUNDS (f, RIGHT_EDGE) #endif /* INCLUDED_gutter_h_ */
--- a/src/hash.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/hash.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Hash tables. Copyright (C) 1992, 1993, 1994 Free Software Foundation, Inc. - Copyright (C) 2003, 2004 Ben Wing. + Copyright (C) 2003, 2004, 2010 Ben Wing. This file is part of XEmacs. @@ -28,7 +28,7 @@ #include "lisp.h" #include "hash.h" -#define NULL_ENTRY ((void *) 0xdeadbeef) /* -559038737 base 10 */ +#define NULL_ENTRY ((void *) 0xDEADBEEF) /* -559038737 base 10 */ #define COMFORTABLE_SIZE(size) (21 * (size) / 16)
--- a/src/imgproc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/imgproc.c Mon Mar 29 21:28:13 2010 -0500 @@ -27,6 +27,7 @@ Copyright (c) 1988-1997 Sam Leffler Copyright (c) 1991-1997 Silicon Graphics, Inc. + Copyright (C) 2010 Ben Wing. Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided @@ -551,8 +552,12 @@ /* 5c: done with ColorCells */ for (i = 0; i < C_LEN*C_LEN*C_LEN; i++) if (qt->ColorCells[i]) - xfree (qt->ColorCells[i]); + { + xfree (qt->ColorCells[i]); + qt->ColorCells[i] = 0; + } xfree (qt->ColorCells); + qt->ColorCells = 0; if (res) {
--- a/src/inline.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/inline.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* Repository for inline functions Copyright (C) 1995 Sun Microsystems, Inc. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -35,8 +36,8 @@ */ /* Note to maintainers: This file contains a list of all header files - that use the INLINE macro, either directly, or by using DECLARE_LRECORD. - i.e. the output of ``grep -l -w 'DECLARE_LRECORD|INLINE_HEADER' *.h'' */ + that use the INLINE macro, either directly, or by using DECLARE_LISP_OBJECT. + i.e. the output of ``grep -l -w 'DECLARE_LISP_OBJECT|INLINE_HEADER' *.h'' */ #define DONT_EXTERN_INLINE_HEADER_FUNCTIONS @@ -99,19 +100,26 @@ #include "database.h" #endif +#include "console-stream-impl.h" + #ifdef HAVE_X_WINDOWS -#include "glyphs-x.h" +#include "console-x-impl.h" #ifdef HAVE_XFT #include "font-mgr.h" #endif #endif #ifdef HAVE_MS_WINDOWS -#include "console-msw.h" +#include "console-msw-impl.h" +#endif + +#ifdef HAVE_TTY +#include "console-tty-impl.h" +#include "fontcolor-tty-impl.h" #endif #ifdef HAVE_GTK -#include "console-gtk.h" +#include "console-gtk-impl.h" #include "ui-gtk.h" #endif
--- a/src/input-method-xlib.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/input-method-xlib.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Various functions for X11R5+ input methods, using the Xlib interface. Copyright (C) 1996 Sun Microsystems. - Copyright (C) 2002 Ben Wing. + Copyright (C) 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -411,10 +411,15 @@ if (needed->width == 0) /* Use XNArea instead of XNAreaNeeded */ XIC_Value (Get, xic, XNStatusAttributes, XNArea, &needed); + /* #### This will partially cover the gutter if there is a bottom + gutter. Perhaps what was intended was FRAME_PANED_RIGHT_EDGE() + and FRAME_PANED_BOTTOM_EDGE()? That will actually place itself + in the paned area (covering the right edge of the minibuffer) + in all circumstances. */ area.width = needed->width; area.height = needed->height; - area.x = FRAME_RIGHT_BORDER_START (f) - area.width; - area.y = FRAME_BOTTOM_BORDER_START (f) - area.height; + area.x = FRAME_RIGHT_INTERNAL_BORDER_START (f) - area.width; + area.y = FRAME_BOTTOM_INTERNAL_BORDER_START (f) - area.height; #ifdef DEBUG_XIM stderr_out ("Putting StatusArea in x=%d y=%d w=%d h=%d\n", @@ -430,10 +435,10 @@ /* We include the border because Preedit window might be larger than display line at edge. #### FIX: we should adjust to make sure that there is always room for the spot sub-window */ - area.x = FRAME_LEFT_BORDER_START (f); - area.y = FRAME_TOP_BORDER_START (f); - area.width = FRAME_RIGHT_BORDER_END (f) - area.x; - area.height = FRAME_BOTTOM_BORDER_END (f) - area.y; + area.x = FRAME_LEFT_INTERNAL_BORDER_START (f); + area.y = FRAME_TOP_INTERNAL_BORDER_START (f); + area.width = FRAME_RIGHT_INTERNAL_BORDER_END (f) - area.x; + area.height = FRAME_BOTTOM_INTERNAL_BORDER_END (f) - area.y; XIC_Value(Set, xic, XNPreeditAttributes, XNArea, &area); }
--- a/src/insdel.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/insdel.c Mon Mar 29 21:28:13 2010 -0500 @@ -1838,8 +1838,10 @@ { BUFFER_FREE (b->text->beg); xfree (b->text->changes); + b->text->changes = 0; } xfree (b->changes); + b->changes = 0; #ifdef REGION_CACHE_NEEDS_WORK if (b->newline_cache)
--- a/src/keymap.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/keymap.c Mon Mar 29 21:28:13 2010 -0500 @@ -148,7 +148,7 @@ struct Lisp_Keymap { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; #define MARKED_SLOT(x) Lisp_Object x; #include "keymap-slots.h" }; @@ -284,14 +284,15 @@ /* This function can GC */ Lisp_Keymap *keymap = XKEYMAP (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<keymap "); if (!NILP (keymap->name)) { write_fmt_string_lisp (printcharfun, "%S ", 1, keymap->name); } write_fmt_string (printcharfun, "size %ld 0x%x>", - (long) XINT (Fkeymap_fullness (obj)), keymap->header.uid); + (long) XINT (Fkeymap_fullness (obj)), + LISP_OBJECT_UID (obj)); } static const struct memory_description keymap_description[] = { @@ -300,12 +301,11 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("keymap", keymap, - 1, /*dumpable-flag*/ - mark_keymap, print_keymap, 0, - keymap_equal, keymap_hash, - keymap_description, - Lisp_Keymap); +DEFINE_DUMPABLE_LISP_OBJECT ("keymap", keymap, + mark_keymap, print_keymap, 0, + keymap_equal, keymap_hash, + keymap_description, + Lisp_Keymap); /************************************************************************/ /* Traversing keymaps and their parents */ @@ -777,10 +777,8 @@ static Lisp_Object make_keymap (Elemcount size) { - Lisp_Object result; - Lisp_Keymap *keymap = ALLOC_LCRECORD_TYPE (Lisp_Keymap, &lrecord_keymap); - - result = wrap_keymap (keymap); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (keymap); + Lisp_Keymap *keymap = XKEYMAP (obj); #define MARKED_SLOT(x) keymap->x = Qnil; #include "keymap-slots.h" @@ -795,7 +793,7 @@ make_lisp_hash_table (size * 3 / 4, HASH_TABLE_NON_WEAK, HASH_TABLE_EQ); } - return result; + return obj; } DEFUN ("make-keymap", Fmake_keymap, 0, 1, 0, /* @@ -1731,7 +1729,7 @@ if (indx == 0) new_keys = keys; else if (STRINGP (keys)) - new_keys = Fsubstring (keys, Qzero, make_int (indx)); + new_keys = Fsubseq (keys, Qzero, make_int (indx)); else if (VECTORP (keys)) { new_keys = make_vector (indx, Qnil); @@ -4295,7 +4293,7 @@ void syms_of_keymap (void) { - INIT_LRECORD_IMPLEMENTATION (keymap); + INIT_LISP_OBJECT (keymap); DEFSYMBOL (Qminor_mode_map_alist);
--- a/src/keymap.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/keymap.h Mon Mar 29 21:28:13 2010 -0500 @@ -26,7 +26,7 @@ typedef struct Lisp_Keymap Lisp_Keymap; -DECLARE_LRECORD (keymap, Lisp_Keymap); +DECLARE_LISP_OBJECT (keymap, Lisp_Keymap); #define XKEYMAP(x) XRECORD (x, keymap, Lisp_Keymap) #define wrap_keymap(p) wrap_record (p, keymap) #define KEYMAPP(x) RECORDP (x, keymap)
--- a/src/linuxplay.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/linuxplay.c Mon Mar 29 21:28:13 2010 -0500 @@ -72,7 +72,7 @@ static int mix_fd; static int audio_vol; static int audio_fd; -static Ascbyte *audio_dev = "/dev/dsp"; +static const Ascbyte *audio_dev = "/dev/dsp"; /* Intercept SIGINT and SIGHUP in order to close the audio and mixer devices before terminating sound output; this requires reliable
--- a/src/lisp.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/lisp.h Mon Mar 29 21:28:13 2010 -0500 @@ -85,6 +85,16 @@ %%#### marks places that need work for KKCC (the new garbage collector). + @@#### marks places that need work to get Unicode-internal working, + i.e. using UTF-8 as the internal text format. + + #### BILL! marks places that need work for GTK. + + #### GEOM! marks places needing work to fix various bugs in the handling + of window and frame sizing and positioning. Often the root of the + problems is that the code was originally written before there was a + gutter and then not completely fixed up to accommodate the gutter. + */ /************************************************************************/ @@ -1229,6 +1239,9 @@ /* Highly dubious kludge */ /* (thanks, Jamie, I feel better now -- ben) */ MODULE_API void assert_failed (const Ascbyte *, int, const Ascbyte *); +void assert_equal_failed (const Ascbyte *file, int line, EMACS_INT x, + EMACS_INT y, const Ascbyte *exprx, + const Ascbyte *expry); #define ABORT() assert_failed (__FILE__, __LINE__, "ABORT()") #define abort_with_message(msg) assert_failed (__FILE__, __LINE__, msg) @@ -1249,6 +1262,10 @@ ((x) ? (void) 0 : assert_failed (__FILE__, __LINE__, msg)) # define assert_at_line(x, file, line) \ ((x) ? (void) 0 : assert_failed (file, line, #x)) +# define assert_equal(x, y) \ + ((x) == (y) ? (void) 0 : \ + assert_equal_failed (__FILE__, __LINE__, (EMACS_INT) x, (EMACS_INT) y, \ + #x, #y)) #else /* This used to be ((void) (0)) but that triggers lots of unused variable warnings. It's pointless to force all that code to be rewritten, with @@ -1257,6 +1274,7 @@ # define assert(x) disabled_assert (x) # define assert_with_message(x, msg) disabled_assert_with_message (x, msg) # define assert_at_line(x, file, line) disabled_assert_at_line (x, file, line) +# define assert_equal(x, y) disabled_assert ((x) == (y)) #endif /************************************************************************/ @@ -1544,16 +1562,6 @@ RUN_HOOKS_UNTIL_FAILURE }; -#ifdef HAVE_TOOLBARS -enum toolbar_pos -{ - TOP_TOOLBAR, - BOTTOM_TOOLBAR, - LEFT_TOOLBAR, - RIGHT_TOOLBAR -}; -#endif - enum edge_style { EDGE_ETCHED_IN, @@ -1584,8 +1592,6 @@ /* misc */ /* ------------------------------- */ -#ifdef MEMORY_USAGE_STATS - /* This structure is used to keep statistics on the amount of memory in use. @@ -1605,15 +1611,31 @@ the fields to 0, and add any existing values to whatever was there before; this way, you can get a cumulative effect. */ -struct overhead_stats +struct usage_stats { - int was_requested; - int malloc_overhead; - int dynarr_overhead; - int gap_overhead; + Bytecount was_requested; + Bytecount malloc_overhead; + Bytecount dynarr_overhead; + Bytecount gap_overhead; }; -#endif /* MEMORY_USAGE_STATS */ +/* Generic version of usage stats structure including extra non-Lisp and + Lisp storage associated with the object, but not including the memory + used to hold the object itself. Up to 32 statistics are allowed, + in addition to the statistics in `U', which store another slice onto the + ancillary non-Lisp storage. + + Normally, each object creates its own version of this structure, e.g. + `struct window_stats', which parallels the structure in beginning with + a `struct usage_stats' and followed by Bytecount fields, so that a + pointer to that structure can be cast to a pointer of this structure + and sensible results gotten. */ + +struct generic_usage_stats +{ + struct usage_stats u; + Bytecount othervals[32]; +}; /************************************************************************/ @@ -1722,583 +1744,10 @@ } /************************************************************************/ -/** Definitions of dynamic arrays (dynarrs) and other allocators **/ +/** Definitions of dynarrs and other allocators **/ /************************************************************************/ -BEGIN_C_DECLS - -/************* Dynarr declaration *************/ - -#ifdef NEW_GC -#define DECLARE_DYNARR_LISP_IMP() \ - const struct lrecord_implementation *lisp_imp; -#else -#define DECLARE_DYNARR_LISP_IMP() -#endif - -#ifdef ERROR_CHECK_DYNARR -#define DECLARE_DYNARR_LOCKED() \ - int locked; -#else -#define DECLARE_DYNARR_LOCKED() -#endif - -#define Dynarr_declare(type) \ - struct lrecord_header header; \ - type *base; \ - DECLARE_DYNARR_LISP_IMP () \ - DECLARE_DYNARR_LOCKED () \ - int elsize_; \ - int len_; \ - int largest_; \ - int max_ - -typedef struct dynarr -{ - Dynarr_declare (void); -} Dynarr; - -#define XD_DYNARR_DESC(base_type, sub_desc) \ - { XD_BLOCK_PTR, offsetof (base_type, base), \ - XD_INDIRECT(1, 0), {sub_desc} }, \ - { XD_INT, offsetof (base_type, len_) }, \ - { XD_INT_RESET, offsetof (base_type, largest_), XD_INDIRECT(1, 0) }, \ - { XD_INT_RESET, offsetof (base_type, max_), XD_INDIRECT(1, 0) } - -#ifdef NEW_GC -#define XD_LISP_DYNARR_DESC(base_type, sub_desc) \ - { XD_LISP_OBJECT_BLOCK_PTR, offsetof (base_type, base), \ - XD_INDIRECT(1, 0), {sub_desc} }, \ - { XD_INT, offsetof (base_type, len_) }, \ - { XD_INT_RESET, offsetof (base_type, largest_), XD_INDIRECT(1, 0) }, \ - { XD_INT_RESET, offsetof (base_type, max_), XD_INDIRECT(1, 0) } -#endif /* NEW_GC */ - -/************* Dynarr verification *************/ - -/* Dynarr locking and verification. - - [I] VERIFICATION - - Verification routines simply return their basic argument, possibly - casted, but in the process perform some verification on it, aborting if - the verification fails. The verification routines take FILE and LINE - parameters, and use them to output the file and line of the caller - when an abort occurs, rather than the file and line of the inline - function, which is less than useful. - - There are three basic types of verification routines: - - (1) Verify the dynarr itself. This verifies the basic invariant - involving the length/size values: - - 0 <= Dynarr_length(d) <= Dynarr_largest(d) <= Dynarr_max(d) - - (2) Verify the dynarr itself prior to modifying it. This performs - the same verification as previously, but also checks that the - dynarr is not locked (see below). - - (3) Verify a dynarr position. Unfortunately we have to have - different verification routines depending on which kind of operation - is being performed: - - (a) For Dynarr_at(), we check that the POS is bounded by Dynarr_largest(), - i.e. 0 <= POS < Dynarr_largest(). - (b) For Dynarr_atp_allow_end(), we also have to allow - POS == Dynarr_largest(). - (c) For Dynarr_atp(), we behave largely like Dynarr_at() but make a - special exception when POS == 0 and Dynarr_largest() == 0 -- see - comment below. - (d) Some other routines contain the POS verification within their code, - and make the check 0 <= POS < Dynarr_length() or - 0 <= POS <= Dynarr_length(). - - #### It is not well worked-out whether and in what circumstances it's - allowed to use a position that is between Dynarr_length() and - Dynarr_largest(). The ideal solution is to never allow this, and require - instead that code first change the length before accessing higher - positions. That would require looking through all the code that accesses - dynarrs and fixing it appropriately (especially redisplay code, and - especially redisplay code in the vicinity of a reference to - Dynarr_largest(), since such code usually checks explicitly to see whether - there is extra stuff between Dynarr_length() and Dynarr_largest().) - - [II] LOCKING - - The idea behind dynarr locking is simple: Locking a dynarr prevents - any modification from occurring, or rather, leads to an abort upon - any attempt to modify a dynarr. - - Dynarr locking was originally added to catch some sporadic and hard-to- - debug crashes in the redisplay code where dynarrs appeared to be getting - corrupted in an unexpected fashion. The solution was to lock the - dynarrs that were getting corrupted (in this case, the display-line - dynarrs) around calls to routines that weren't supposed to be changing - these dynarrs but might somehow be calling code that modified them. - This eventually revealed that there was a reentrancy problem with - redisplay that involved the QUIT mechanism and the processing done in - order to determine whether C-g had been pressed -- this processing - involves retrieving, processing and queueing pending events to see - whether any of them result in a C-g keypress. However, at least under - MS Windows this can result in redisplay being called reentrantly. - For more info:-- - - (Info-goto-node "(internals)Critical Redisplay Sections") - -*/ - -#ifdef ERROR_CHECK_DYNARR -DECLARE_INLINE_HEADER ( -int -Dynarr_verify_pos_at (void *d, Elemcount pos, const Ascbyte *file, int line) -) -{ - Dynarr *dy = (Dynarr *) d; - /* We use `largest', not `len', because the redisplay code often - accesses stuff between len and largest. */ - assert_at_line (pos >= 0 && pos < dy->largest_, file, line); - return pos; -} - -DECLARE_INLINE_HEADER ( -int -Dynarr_verify_pos_atp (void *d, Elemcount pos, const Ascbyte *file, int line) -) -{ - Dynarr *dy = (Dynarr *) d; - /* We use `largest', not `len', because the redisplay code often - accesses stuff between len and largest. */ - /* [[ Code will often do something like ... - - val = make_bit_vector_from_byte_vector (Dynarr_atp (dyn, 0), - Dynarr_length (dyn)); - - which works fine when the Dynarr_length is non-zero, but when zero, - the result of Dynarr_atp() not only points past the end of the - allocated array, but the array may not have ever been allocated and - hence the return value is NULL. But the length of 0 causes the - pointer to never get checked. These can occur throughout the code - so we put in a special check. --ben ]] - - Update: The common idiom `Dynarr_atp (dyn, 0)' has been changed to - `Dynarr_begin (dyn)'. Possibly this special check at POS 0 can be - done only for Dynarr_begin() not for general Dynarr_atp(). --ben */ - if (pos == 0 && dy->len_ == 0) - return pos; - /* #### It's vaguely possible that some code could legitimately want to - retrieve a pointer to the position just past the end of dynarr memory. - This could happen with Dynarr_atp() but not Dynarr_at(). If so, it - will trigger this assert(). In such cases, it should be obvious that - the code wants to do this; rather than relaxing the assert, we should - probably create a new macro Dynarr_atp_allow_end() which is like - Dynarr_atp() but which allows for pointing at invalid addresses -- we - really want to check for cases of accessing just past the end of - memory, which is a likely off-by-one problem to occur and will usually - not trigger a protection fault (instead, you'll just get random - behavior, possibly overwriting other memory, which is bad). --ben */ - assert_at_line (pos >= 0 && pos < dy->largest_, file, line); - return pos; -} - -DECLARE_INLINE_HEADER ( -int -Dynarr_verify_pos_atp_allow_end (void *d, Elemcount pos, const Ascbyte *file, - int line) -) -{ - Dynarr *dy = (Dynarr *) d; - /* We use `largest', not `len', because the redisplay code often - accesses stuff between len and largest. - We also allow referencing the very end, past the end of allocated - legitimately space. See comments in Dynarr_verify_pos_atp.()*/ - assert_at_line (pos >= 0 && pos <= dy->largest_, file, line); - return pos; -} - -#else -#define Dynarr_verify_pos_at(d, pos, file, line) (pos) -#define Dynarr_verify_pos_atp(d, pos, file, line) (pos) -#define Dynarr_verify_pos_atp_allow_end(d, pos, file, line) (pos) -#endif /* ERROR_CHECK_DYNARR */ - -#ifdef ERROR_CHECK_DYNARR -DECLARE_INLINE_HEADER ( -Dynarr * -Dynarr_verify_1 (void *d, const Ascbyte *file, int line) -) -{ - Dynarr *dy = (Dynarr *) d; - assert_at_line (dy->len_ >= 0 && dy->len_ <= dy->largest_ && - dy->largest_ <= dy->max_, file, line); - return dy; -} - -DECLARE_INLINE_HEADER ( -Dynarr * -Dynarr_verify_mod_1 (void *d, const Ascbyte *file, int line) -) -{ - Dynarr *dy = (Dynarr *) d; - assert_at_line (!dy->locked, file, line); - return Dynarr_verify_1 (d, file, line); -} - -#define Dynarr_verify(d) Dynarr_verify_1 (d, __FILE__, __LINE__) -#define Dynarr_verify_mod(d) Dynarr_verify_mod_1 (d, __FILE__, __LINE__) - -DECLARE_INLINE_HEADER ( -void -Dynarr_lock (void *d) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - dy->locked = 1; -} - -DECLARE_INLINE_HEADER ( -void -Dynarr_unlock (void *d) -) -{ - Dynarr *dy = Dynarr_verify (d); - assert (dy->locked); - dy->locked = 0; -} - -#else /* not ERROR_CHECK_DYNARR */ - -#define Dynarr_verify(d) ((Dynarr *) d) -#define Dynarr_verify_mod(d) ((Dynarr *) d) -#define Dynarr_lock(d) DO_NOTHING -#define Dynarr_unlock(d) DO_NOTHING - -#endif /* ERROR_CHECK_DYNARR */ - -/************* Dynarr creation *************/ - -MODULE_API void *Dynarr_newf (Bytecount elsize); -MODULE_API void Dynarr_free (void *d); - -#ifdef NEW_GC -MODULE_API void *Dynarr_lisp_newf (Bytecount elsize, - const struct lrecord_implementation - *dynarr_imp, - const struct lrecord_implementation *imp); - -#define Dynarr_lisp_new(type, dynarr_imp, imp) \ - ((type##_dynarr *) Dynarr_lisp_newf (sizeof (type), dynarr_imp, imp)) -#define Dynarr_lisp_new2(dynarr_type, type, dynarr_imp, imp) \ - ((dynarr_type *) Dynarr_lisp_newf (sizeof (type)), dynarr_imp, imp) -#endif /* NEW_GC */ -#define Dynarr_new(type) ((type##_dynarr *) Dynarr_newf (sizeof (type))) -#define Dynarr_new2(dynarr_type, type) \ - ((dynarr_type *) Dynarr_newf (sizeof (type))) - -/************* Dynarr access *************/ - -#ifdef ERROR_CHECK_DYNARR -#define Dynarr_at(d, pos) \ - ((d)->base[Dynarr_verify_pos_at (d, pos, __FILE__, __LINE__)]) -#define Dynarr_atp_allow_end(d, pos) \ - (&((d)->base[Dynarr_verify_pos_atp_allow_end (d, pos, __FILE__, __LINE__)])) -#define Dynarr_atp(d, pos) \ - (&((d)->base[Dynarr_verify_pos_atp (d, pos, __FILE__, __LINE__)])) -#else -#define Dynarr_at(d, pos) ((d)->base[pos]) -#define Dynarr_atp(d, pos) (&Dynarr_at (d, pos)) -#define Dynarr_atp_allow_end(d, pos) Dynarr_atp (d, pos) -#endif - -/* Old #define Dynarr_atp(d, pos) (&Dynarr_at (d, pos)) */ -#define Dynarr_begin(d) Dynarr_atp (d, 0) -#define Dynarr_lastp(d) Dynarr_atp (d, Dynarr_length (d) - 1) -#define Dynarr_past_lastp(d) Dynarr_atp_allow_end (d, Dynarr_length (d)) - - -/************* Dynarr length/size retrieval and setting *************/ - -/* Retrieve the length of a dynarr. The `+ 0' is to ensure that this cannot - be used as an lvalue. */ -#define Dynarr_length(d) (Dynarr_verify (d)->len_ + 0) -/* Retrieve the largest ever length seen of a dynarr. The `+ 0' is to - ensure that this cannot be used as an lvalue. */ -#define Dynarr_largest(d) (Dynarr_verify (d)->largest_ + 0) -/* Retrieve the number of elements that fit in the currently allocated - space. The `+ 0' is to ensure that this cannot be used as an lvalue. */ -#define Dynarr_max(d) (Dynarr_verify (d)->max_ + 0) -/* Return the size in bytes of an element in a dynarr. */ -#define Dynarr_elsize(d) (Dynarr_verify (d)->elsize_ + 0) -/* Retrieve the advertised memory usage of a dynarr, i.e. the number of - bytes occupied by the elements in the dynarr, not counting any overhead. */ -#define Dynarr_sizeof(d) (Dynarr_length (d) * Dynarr_elsize (d)) - -/* Actually set the length of a dynarr. This is a low-level routine that - should not be directly used; use Dynarr_set_length() or - Dynarr_set_lengthr() instead. */ -DECLARE_INLINE_HEADER ( -void -Dynarr_set_length_1 (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - dynarr_checking_assert (len >= 0 && len <= Dynarr_max (dy)); - /* Use the raw field references here otherwise we get a crash because - we've set the length but not yet fixed up the largest value. */ - dy->len_ = len; - if (dy->len_ > dy->largest_) - dy->largest_ = dy->len_; - (void) Dynarr_verify_mod (d); -} - -/* "Restricted set-length": Set the length of dynarr D to LEN, - which must be in the range [0, Dynarr_largest(d)]. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_set_lengthr (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - dynarr_checking_assert (len >= 0 && len <= Dynarr_largest (dy)); - Dynarr_set_length_1 (dy, len); -} - -/* "Restricted increment": Increment the length of dynarr D by 1; the resulting - length must be in the range [0, Dynarr_largest(d)]. */ - -#define Dynarr_incrementr(d) Dynarr_set_lengthr (d, Dynarr_length (d) + 1) - - -MODULE_API void Dynarr_resize (void *d, Elemcount size); - -DECLARE_INLINE_HEADER ( -void -Dynarr_resize_to_fit (void *d, Elemcount size) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - if (size > Dynarr_max (dy)) - Dynarr_resize (dy, size); -} - -#define Dynarr_resize_to_add(d, numels) \ - Dynarr_resize_to_fit (d, Dynarr_length (d) + numels) - -/* This is an optimization. This is like Dynarr_set_length() but the length - is guaranteed to be at least as big as the existing length. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_increase_length (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - dynarr_checking_assert (len >= Dynarr_length (dy)); - Dynarr_resize_to_fit (dy, len); - Dynarr_set_length_1 (dy, len); -} - -/* Set the length of dynarr D to LEN. If the length increases, resize as - necessary to fit. (NOTE: This will leave uninitialized memory. If you - aren't planning on immediately overwriting the memory, use - Dynarr_set_length_and_zero() to zero out all the memory that would - otherwise be uninitialized.) */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_set_length (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - Elemcount old_len = Dynarr_length (dy); - if (old_len >= len) - Dynarr_set_lengthr (dy, len); - else - Dynarr_increase_length (d, len); -} - -#define Dynarr_increment(d) Dynarr_increase_length (d, Dynarr_length (d) + 1) - -/* Zero LEN contiguous elements starting at POS. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_zero_many (void *d, Elemcount pos, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - memset ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), 0, - len*Dynarr_elsize (dy)); -} - -/* This is an optimization. This is like Dynarr_set_length_and_zero() but - the length is guaranteed to be at least as big as the existing - length. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_increase_length_and_zero (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - Elemcount old_len = Dynarr_length (dy); - Dynarr_increase_length (dy, len); - Dynarr_zero_many (dy, old_len, len - old_len); -} - -/* Set the length of dynarr D to LEN. If the length increases, resize as - necessary to fit and zero out all the elements between the old and new - lengths. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_set_length_and_zero (void *d, Elemcount len) -) -{ - Dynarr *dy = Dynarr_verify_mod (d); - Elemcount old_len = Dynarr_length (dy); - if (old_len >= len) - Dynarr_set_lengthr (dy, len); - else - Dynarr_increase_length_and_zero (d, len); -} - -/* Reset the dynarr's length to 0. */ -#define Dynarr_reset(d) Dynarr_set_lengthr (d, 0) - -#ifdef MEMORY_USAGE_STATS -struct overhead_stats; -Bytecount Dynarr_memory_usage (void *d, struct overhead_stats *stats); -#endif - -/************* Adding/deleting elements to/from a dynarr *************/ - -/* Set the Lisp implementation of the element at POS in dynarr D. Only - does this if the dynarr holds Lisp objects of a particular type (the - objects themselves, not pointers to them), and only under NEW_GC. */ - -#ifdef NEW_GC -#define DYNARR_SET_LISP_IMP(d, pos) \ -do { \ - if ((d)->lisp_imp) \ - set_lheader_implementation \ - ((struct lrecord_header *)&(((d)->base)[pos]), (d)->lisp_imp); \ -} while (0) -#else -#define DYNARR_SET_LISP_IMP(d, pos) DO_NOTHING -#endif /* (not) NEW_GC */ - -/* Add Element EL to the end of dynarr D. */ - -#define Dynarr_add(d, el) \ -do { \ - Elemcount _da_pos = Dynarr_length (d); \ - (void) Dynarr_verify_mod (d); \ - Dynarr_increment (d); \ - ((d)->base)[_da_pos] = (el); \ - DYNARR_SET_LISP_IMP (d, _da_pos); \ -} while (0) - -/* Set EL as the element at position POS in dynarr D. - Expand the dynarr as necessary so that its length is enough to include - position POS within it, and zero out any new elements created as a - result of expansion, other than the one at POS. */ - -#define Dynarr_set(d, pos, el) \ -do { \ - Elemcount _ds_pos = (pos); \ - (void) Dynarr_verify_mod (d); \ - if (Dynarr_length (d) < _ds_pos + 1) \ - Dynarr_increase_length_and_zero (d, _ds_pos + 1); \ - ((d)->base)[_ds_pos] = (el); \ - DYNARR_SET_LISP_IMP (d, _ds_pos); \ -} while (0) - -/* Add LEN contiguous elements, stored at BASE, to dynarr D. If BASE is - NULL, reserve space but don't store anything. */ - -DECLARE_INLINE_HEADER ( -void -Dynarr_add_many (void *d, const void *base, Elemcount len) -) -{ - /* This duplicates Dynarr_insert_many to some extent; but since it is - called so often, it seemed useful to remove the unnecessary stuff - from that function and to make it inline */ - Dynarr *dy = Dynarr_verify_mod (d); - Elemcount pos = Dynarr_length (dy); - Dynarr_increase_length (dy, Dynarr_length (dy) + len); - if (base) - memcpy ((Rawbyte *) dy->base + pos*Dynarr_elsize (dy), base, - len*Dynarr_elsize (dy)); -} - -/* Insert LEN elements, currently pointed to by BASE, into dynarr D - starting at position POS. */ - -MODULE_API void Dynarr_insert_many (void *d, const void *base, Elemcount len, - Elemcount pos); - -/* Prepend LEN elements, currently pointed to by BASE, to the beginning. */ - -#define Dynarr_prepend_many(d, base, len) Dynarr_insert_many (d, base, len, 0) - -/* Add literal string S to dynarr D, which should hold chars or unsigned - chars. The final zero byte is not stored. */ - -#define Dynarr_add_literal_string(d, s) Dynarr_add_many (d, s, sizeof (s) - 1) - -/* Convert Lisp string S to an external encoding according to CODESYS and - add to dynarr D, which should hold chars or unsigned chars. No final - zero byte is appended. */ - -/* #### This should be an inline function but LISP_STRING_TO_SIZED_EXTERNAL - isn't declared yet. */ - -#define Dynarr_add_ext_lisp_string(d, s, codesys) \ -do { \ - Lisp_Object dyna_ls_s = (s); \ - Lisp_Object dyna_ls_cs = (codesys); \ - Extbyte *dyna_ls_eb; \ - Bytecount dyna_ls_bc; \ - \ - LISP_STRING_TO_SIZED_EXTERNAL (dyna_ls_s, dyna_ls_eb, \ - dyna_ls_bc, dyna_ls_cs); \ - Dynarr_add_many (d, dyna_ls_eb, dyna_ls_bc); \ -} while (0) - -/* Delete LEN elements starting at position POS. */ - -MODULE_API void Dynarr_delete_many (void *d, Elemcount pos, Elemcount len); - -/* Pop off (i.e. delete) the last element from the dynarr and return it */ - -#define Dynarr_pop(d) \ - (dynarr_checking_assert (Dynarr_length (d) > 0), \ - Dynarr_verify_mod (d)->len_--, \ - Dynarr_at (d, Dynarr_length (d))) - -/* Delete the item at POS */ - -#define Dynarr_delete(d, pos) Dynarr_delete_many (d, pos, 1) - -/* Delete the item located at memory address P, which must be a `type *' - pointer, where `type' is the type of the elements of the dynarr. */ -#define Dynarr_delete_by_pointer(d, p) \ - Dynarr_delete_many (d, (p) - ((d)->base), 1) - -/* Delete all elements that are numerically equal to EL. */ - -#define Dynarr_delete_object(d, el) \ -do \ -{ \ - REGISTER int i; \ - for (i = Dynarr_length (d) - 1; i >= 0; i--) \ - { \ - if (el == Dynarr_at (d, i)) \ - Dynarr_delete_many (d, i, 1); \ - } \ -} while (0) +#include "array.h" /************* Dynarr typedefs *************/ @@ -2383,7 +1832,7 @@ } face_cachel_dynarr; #ifdef NEW_GC -DECLARE_LRECORD (face_cachel_dynarr, face_cachel_dynarr); +DECLARE_LISP_OBJECT (face_cachel_dynarr, face_cachel_dynarr); #define XFACE_CACHEL_DYNARR(x) \ XRECORD (x, face_cachel_dynarr, face_cachel_dynarr) #define wrap_face_cachel_dynarr(p) wrap_record (p, face_cachel_dynarr) @@ -2398,7 +1847,7 @@ } glyph_cachel_dynarr; #ifdef NEW_GC -DECLARE_LRECORD (glyph_cachel_dynarr, glyph_cachel_dynarr); +DECLARE_LISP_OBJECT (glyph_cachel_dynarr, glyph_cachel_dynarr); #define XGLYPH_CACHEL_DYNARR(x) \ XRECORD (x, glyph_cachel_dynarr, glyph_cachel_dynarr) #define wrap_glyph_cachel_dynarr(p) wrap_record (p, glyph_cachel_dynarr) @@ -2426,12 +1875,6 @@ } Lisp_Object_ptr_dynarr; -/************* Stack-like malloc/free: Another allocator *************/ - -void *stack_like_malloc (Bytecount size); -void stack_like_free (void *val); - - /************************************************************************/ /** Definitions of other basic Lisp objects **/ /************************************************************************/ @@ -2459,7 +1902,7 @@ struct Lisp_Cons { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; Lisp_Object car_, cdr_; }; typedef struct Lisp_Cons Lisp_Cons; @@ -2476,7 +1919,7 @@ }; #endif -DECLARE_MODULE_API_LRECORD (cons, Lisp_Cons); +DECLARE_MODULE_API_LISP_OBJECT (cons, Lisp_Cons); #define XCONS(x) XRECORD (x, cons, Lisp_Cons) #define wrap_cons(p) wrap_record (p, cons) #define CONSP(x) RECORDP (x, cons) @@ -3014,13 +2457,13 @@ #ifdef NEW_GC struct Lisp_String_Direct_Data { - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; Bytecount size; Ibyte data[1]; }; typedef struct Lisp_String_Direct_Data Lisp_String_Direct_Data; -DECLARE_MODULE_API_LRECORD (string_direct_data, Lisp_String_Direct_Data); +DECLARE_MODULE_API_LISP_OBJECT (string_direct_data, Lisp_String_Direct_Data); #define XSTRING_DIRECT_DATA(x) \ XRECORD (x, string_direct_data, Lisp_String_Direct_Data) #define wrap_string_direct_data(p) wrap_record (p, string_direct_data) @@ -3034,13 +2477,13 @@ struct Lisp_String_Indirect_Data { - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; Bytecount size; Ibyte *data; }; typedef struct Lisp_String_Indirect_Data Lisp_String_Indirect_Data; -DECLARE_MODULE_API_LRECORD (string_indirect_data, Lisp_String_Indirect_Data); +DECLARE_MODULE_API_LISP_OBJECT (string_indirect_data, Lisp_String_Indirect_Data); #define XSTRING_INDIRECT_DATA(x) \ XRECORD (x, string_indirect_data, Lisp_String_Indirect_Data) #define wrap_string_indirect_data(p) wrap_record (p, string_indirect_data) @@ -3080,7 +2523,9 @@ struct { /* WARNING: Everything before ascii_begin must agree exactly with - struct lrecord_header */ + struct lrecord_header. (Actually, the `free' field in old-GC + overlaps with ascii_begin there; we can get away with this + because in old-GC the `free' field is used only for lcrecords. */ unsigned int type :8; #ifdef NEW_GC unsigned int lisp_readonly :1; @@ -3115,7 +2560,7 @@ #define MAX_STRING_ASCII_BEGIN ((1 << 21) - 1) #endif /* not NEW_GC */ -DECLARE_MODULE_API_LRECORD (string, Lisp_String); +DECLARE_MODULE_API_LISP_OBJECT (string, Lisp_String); #define XSTRING(x) XRECORD (x, string, Lisp_String) #define wrap_string(p) wrap_record (p, string) #define STRINGP(x) RECORDP (x, string) @@ -3188,13 +2633,13 @@ struct Lisp_Vector { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; long size; Lisp_Object contents[1]; }; typedef struct Lisp_Vector Lisp_Vector; -DECLARE_LRECORD (vector, Lisp_Vector); +DECLARE_LISP_OBJECT (vector, Lisp_Vector); #define XVECTOR(x) XRECORD (x, vector, Lisp_Vector) #define wrap_vector(p) wrap_record (p, vector) #define VECTORP(x) RECORDP (x, vector) @@ -3225,13 +2670,13 @@ struct Lisp_Bit_Vector { - struct LCRECORD_HEADER lheader; + NORMAL_LISP_OBJECT_HEADER lheader; Elemcount size; unsigned long bits[1]; }; typedef struct Lisp_Bit_Vector Lisp_Bit_Vector; -DECLARE_LRECORD (bit_vector, Lisp_Bit_Vector); +DECLARE_LISP_OBJECT (bit_vector, Lisp_Bit_Vector); #define XBIT_VECTOR(x) XRECORD (x, bit_vector, Lisp_Bit_Vector) #define wrap_bit_vector(p) wrap_record (p, bit_vector) #define BIT_VECTORP(x) RECORDP (x, bit_vector) @@ -3279,7 +2724,7 @@ /* For when we want to include a bit vector in another structure, and we know it's of a fixed size. */ #define DECLARE_INLINE_LISP_BIT_VECTOR(numbits) struct { \ - struct LCRECORD_HEADER lheader; \ + NORMAL_LISP_OBJECT_HEADER lheader; \ Elemcount size; \ unsigned long bits[BIT_VECTOR_LONG_STORAGE(numbits)]; \ } @@ -3314,7 +2759,7 @@ typedef struct Lisp_Symbol Lisp_Symbol; struct Lisp_Symbol { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; /* next symbol in this obarray bucket */ Lisp_Symbol *next; Lisp_Object name; @@ -3330,7 +2775,7 @@ XSTRING_LENGTH (symbol_name (XSYMBOL (sym)))))) #define KEYWORDP(obj) (SYMBOLP (obj) && SYMBOL_IS_KEYWORD (obj)) -DECLARE_MODULE_API_LRECORD (symbol, Lisp_Symbol); +DECLARE_MODULE_API_LISP_OBJECT (symbol, Lisp_Symbol); #define XSYMBOL(x) XRECORD (x, symbol, Lisp_Symbol) #define wrap_symbol(p) wrap_record (p, symbol) #define SYMBOLP(x) RECORDP (x, symbol) @@ -3358,7 +2803,7 @@ struct Lisp_Subr { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; short min_args; short max_args; /* #### We should make these const Ascbyte * or const Ibyte *, not const @@ -3370,7 +2815,7 @@ }; typedef struct Lisp_Subr Lisp_Subr; -DECLARE_LRECORD (subr, Lisp_Subr); +DECLARE_LISP_OBJECT (subr, Lisp_Subr); #define XSUBR(x) XRECORD (x, subr, Lisp_Subr) #define wrap_subr(p) wrap_record (p, subr) #define SUBRP(x) RECORDP (x, subr) @@ -3388,7 +2833,7 @@ typedef struct Lisp_Marker Lisp_Marker; struct Lisp_Marker { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; Lisp_Marker *next; Lisp_Marker *prev; struct buffer *buffer; @@ -3396,7 +2841,7 @@ char insertion_type; }; -DECLARE_MODULE_API_LRECORD (marker, Lisp_Marker); +DECLARE_MODULE_API_LISP_OBJECT (marker, Lisp_Marker); #define XMARKER(x) XRECORD (x, marker, Lisp_Marker) #define wrap_marker(p) wrap_record (p, marker) #define MARKERP(x) RECORDP (x, marker) @@ -3458,8 +2903,18 @@ x = wrong_type_argument (Qnatnump, x); \ } while (0) +END_C_DECLS + +/* -------------- properties of internally-formatted text ------------- */ + +#include "text.h" + /*------------------------------- char ---------------------------------*/ +BEGIN_C_DECLS + +#ifdef ERROR_CHECK_TYPES + /* NOTE: There are basic functions for converting between a character and the string representation of a character in text.h, as well as lots of other character-related stuff. There are other functions/macros for @@ -3467,31 +2922,6 @@ Ichar, the length of an Ichar when converted to text, etc. */ -#ifdef MULE - -MODULE_API int non_ascii_valid_ichar_p (Ichar ch); - -/* Return whether the given Ichar is valid. - */ - -DECLARE_INLINE_HEADER ( -int -valid_ichar_p (Ichar ch) -) -{ - return (! (ch & ~0xFF)) || non_ascii_valid_ichar_p (ch); -} - -#else /* not MULE */ - -/* This works when CH is negative, and correctly returns non-zero only when CH - is in the range [0, 255], inclusive. */ -#define valid_ichar_p(ch) (! (ch & ~0xFF)) - -#endif /* not MULE */ - -#ifdef ERROR_CHECK_TYPES - DECLARE_INLINE_HEADER ( int CHARP_1 (Lisp_Object obj, const Ascbyte *file, int line) @@ -3646,12 +3076,12 @@ struct Lisp_Float { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; union { double d; struct Lisp_Float *unused_next_; } data; }; typedef struct Lisp_Float Lisp_Float; -DECLARE_LRECORD (float, Lisp_Float); +DECLARE_LISP_OBJECT (float, Lisp_Float); #define XFLOAT(x) XRECORD (x, float, Lisp_Float) #define wrap_float(p) wrap_record (p, float) #define FLOATP(x) RECORDP (x, float) @@ -3734,7 +3164,7 @@ struct weak_box { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object value; Lisp_Object next_weak_box; /* don't mark through this! */ @@ -3744,7 +3174,7 @@ Lisp_Object make_weak_box (Lisp_Object value); Lisp_Object weak_box_ref (Lisp_Object value); -DECLARE_LRECORD (weak_box, struct weak_box); +DECLARE_LISP_OBJECT (weak_box, struct weak_box); #define XWEAK_BOX(x) XRECORD (x, weak_box, struct weak_box) #define XSET_WEAK_BOX(x, v) (XWEAK_BOX (x)->value = (v)) #define wrap_weak_box(p) wrap_record (p, weak_box) @@ -3756,7 +3186,7 @@ struct ephemeron { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object key; @@ -3781,7 +3211,7 @@ Lisp_Object zap_finalize_list(void); Lisp_Object make_ephemeron(Lisp_Object key, Lisp_Object value, Lisp_Object finalizer); -DECLARE_LRECORD(ephemeron, struct ephemeron); +DECLARE_LISP_OBJECT(ephemeron, struct ephemeron); #define XEPHEMERON(x) XRECORD (x, ephemeron, struct ephemeron) #define XEPHEMERON_REF(x) (XEPHEMERON (x)->value) #define XEPHEMERON_NEXT(x) (XCDR (XEPHEMERON(x)->cons_chain)) @@ -3815,13 +3245,13 @@ struct weak_list { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object list; /* don't mark through this! */ enum weak_list_type type; Lisp_Object next_weak; /* don't mark through this! */ }; -DECLARE_LRECORD (weak_list, struct weak_list); +DECLARE_LISP_OBJECT (weak_list, struct weak_list); #define XWEAK_LIST(x) XRECORD (x, weak_list, struct weak_list) #define wrap_weak_list(p) wrap_record (p, weak_list) #define WEAK_LISTP(x) RECORDP (x, weak_list) @@ -3839,37 +3269,6 @@ END_C_DECLS /************************************************************************/ -/* Definitions related to the format of text and of characters */ -/************************************************************************/ - -/* Note: - - "internally formatted text" and the term "internal format" in - general are likely to refer to the format of text in buffers and - strings; "externally formatted text" and the term "external format" - refer to any text format used in the O.S. or elsewhere outside of - XEmacs. The format of text and of a character are related and - there must be a one-to-one relationship (hopefully through a - relatively simple algorithmic means of conversion) between a string - of text and an equivalent array of characters, but the conversion - between the two is NOT necessarily trivial. - - In a non-Mule XEmacs, allowed characters are numbered 0 through - 255, where no fixed meaning is assigned to them, but (when - representing text, rather than bytes in a binary file) in practice - the lower half represents ASCII and the upper half some other 8-bit - character set (chosen by setting the font, case tables, syntax - tables, etc. appropriately for the character set through ad-hoc - means such as the `iso-8859-1' file and the - `standard-display-european' function). - - #### Finish this. - - */ -#include "text.h" - - -/************************************************************************/ /* Definitions of primitive Lisp functions and variables */ /************************************************************************/ @@ -3976,7 +3375,6 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ min_args, \ max_args, \ @@ -3996,7 +3394,6 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ min_args, \ max_args, \ @@ -4051,6 +3448,136 @@ while (NILP (Ffunctionp (fun))) \ signal_invalid_function_error (fun); \ } while (0) + +/************************************************************************/ +/* Parsing keyword arguments */ +/************************************************************************/ + +/* The C subr must have been declared with MANY as its max args, and this + PARSE_KEYWORDS call must come before any statements. + + FUNCTION is the name of the current function, as a symbol. + + NARGS is the count of arguments supplied to FUNCTION. + + ARGS is a pointer to the argument vector (not a Lisp vector) supplied to + FUNCTION. + + KEYWORDS_OFFSET is the offset into ARGS where the keyword arguments start. + + KEYWORD_COUNT is the number of keywords FUNCTION is normally prepared to + handle. + + KEYWORDS is a parenthesised list of those keywords, without the initial + Q_. + + KEYWORD_DEFAULTS allows you to set non-nil defaults. Put (keywordname = + initial_value) in this parameter, a collection of C statements surrounded + by parentheses and separated by the comma operator. If you don't need + this, supply NULL as KEYWORD_DEFAULTS. + + ALLOW_OTHER_KEYS corresponds to the &allow-other-keys argument list + entry in defun*; it is 1 if other keys are normally allowed, 0 + otherwise. This may be overridden in the caller by specifying + :allow-other-keys t in the argument list. + + For keywords which appear multiple times in the called argument list, the + leftmost one overrides, as specified in section 7.1.1 of the CLHS. + + If you want to check whether a given keyword argument was set (as in the + SVAR argument to defun*), supply Qunbound as its default in + KEYWORD_DEFAULTS, and examine it once PARSE_KEYWORDS is done. Lisp code + cannot supply Qunbound as an argument, so if it is still Qunbound, it was + not set. + + There is no elegant way with this macro to have one name for the keyword + and an unrelated name for the local variable, as is possible with the + ((:keyword unrelated-var)) syntax in defun* and in Common Lisp. That + shouldn't matter in practice. */ + +#define PARSE_KEYWORDS(function, nargs, args, keywords_offset, \ + keyword_count, keywords, keyword_defaults, \ + allow_other_keys) \ + DECLARE_N_KEYWORDS_##keyword_count keywords; \ + \ + do \ + { \ + Lisp_Object pk_key, pk_value; \ + Elemcount pk_i = nargs - 1; \ + Boolint pk_allow_other_keys = allow_other_keys; \ + \ + if ((nargs - keywords_offset) & 1) \ + { \ + if (!allow_other_keys \ + && !(pk_allow_other_keys \ + = non_nil_allow_other_keys_p (keywords_offset, \ + nargs, args))) \ + { \ + signal_wrong_number_of_arguments_error (function, nargs); \ + } \ + else \ + { \ + /* Ignore the trailing arg; so below always sees an even \ + number of arguments. */ \ + pk_i -= 1; \ + } \ + } \ + \ + (void)(keyword_defaults); \ + \ + /* Start from the end, because the leftmost element overrides. */ \ + while (pk_i > keywords_offset) \ + { \ + pk_value = args[pk_i--]; \ + pk_key = args[pk_i--]; \ + \ + if (0) {} \ + CHECK_N_KEYWORDS_##keyword_count keywords \ + else if (allow_other_keys || pk_allow_other_keys) \ + { \ + continue; \ + } \ + else if (!(pk_allow_other_keys \ + = non_nil_allow_other_keys_p (keywords_offset, \ + nargs, args))) \ + { \ + invalid_keyword_argument (function, pk_key); \ + } \ + } \ + } while (0) + +#define DECLARE_N_KEYWORDS_1(a) \ + Lisp_Object a = Qnil +#define DECLARE_N_KEYWORDS_2(a,b) \ + DECLARE_N_KEYWORDS_1(a), b = Qnil +#define DECLARE_N_KEYWORDS_3(a,b,c) \ + DECLARE_N_KEYWORDS_2(a,b), c = Qnil +#define DECLARE_N_KEYWORDS_4(a,b,c,d) \ + DECLARE_N_KEYWORDS_3(a,b,c), d = Qnil +#define DECLARE_N_KEYWORDS_5(a,b,c,d,e) \ + DECLARE_N_KEYWORDS_4(a,b,c,d), e = Qnil +#define DECLARE_N_KEYWORDS_6(a,b,c,d,e,f) \ + DECLARE_N_KEYWORDS_5(a,b,c,d,e), f = Qnil +#define DECLARE_N_KEYWORDS_7(a,b,c,d,e,f,g) \ + DECLARE_N_KEYWORDS_6(a,b,c,d,e,f), g = Qnil + +#define CHECK_N_KEYWORDS_1(a) \ + else if (EQ (pk_key, Q_##a)) { a = pk_value; } +#define CHECK_N_KEYWORDS_2(a,b) CHECK_N_KEYWORDS_1(a) \ + else if (EQ (pk_key, Q_##b)) { b = pk_value; } +#define CHECK_N_KEYWORDS_3(a,b,c) CHECK_N_KEYWORDS_2(a,b) \ + else if (EQ (pk_key, Q_##c)) { c = pk_value; } +#define CHECK_N_KEYWORDS_4(a,b,c,d) CHECK_N_KEYWORDS_3(a,b,c) \ + else if (EQ (pk_key, Q_##d)) { d = pk_value; } +#define CHECK_N_KEYWORDS_5(a,b,c,d,e) CHECK_N_KEYWORDS_4(a,b,c,d) \ + else if (EQ (pk_key, Q_##e)) { e = pk_value; } +#define CHECK_N_KEYWORDS_6(a,b,c,d,e,f) CHECK_N_KEYWORDS_5(a,b,c,d,e) \ + else if (EQ (pk_key, Q_##f)) { f = pk_value; } +#define CHECK_N_KEYWORDS_7(a,b,c,d,e,f,g) CHECK_N_KEYWORDS_6(a,b,c,d,e,f) \ + else if (EQ (pk_key, Q_##g)) { g = pk_value; } + +Boolint non_nil_allow_other_keys_p (Elemcount offset, int nargs, + Lisp_Object *args); /************************************************************************/ @@ -4645,8 +4172,6 @@ number of header files that need to be included -- good for a number of reasons. --ben */ -/*--------------- prototypes for various public c functions ------------*/ - /* Prototypes for all init/syms_of/vars_of initialization functions. */ #include "symsinit.h" @@ -4667,6 +4192,7 @@ MODULE_API EXFUN (Fmake_vector, 2); MODULE_API EXFUN (Fvector, MANY); +void deadbeef_memory (void *ptr, Bytecount size); #ifndef NEW_GC void release_breathing_space (void); #endif /* not NEW_GC */ @@ -4688,19 +4214,21 @@ MODULE_API Lisp_Object list3 (Lisp_Object, Lisp_Object, Lisp_Object); MODULE_API Lisp_Object list4 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); -MODULE_API Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, - Lisp_Object); -MODULE_API Lisp_Object list6 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, +MODULE_API Lisp_Object list5 (Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object, Lisp_Object); +MODULE_API Lisp_Object list6 (Lisp_Object, Lisp_Object, Lisp_Object, + Lisp_Object, Lisp_Object, Lisp_Object); +MODULE_API Lisp_Object listn (int numargs, ...); +MODULE_API Lisp_Object listu (Lisp_Object, ...); DECLARE_DOESNT_RETURN (memory_full (void)); void disksave_object_finalization (void); +void finish_object_memory_usage_stats (void); extern int purify_flag; #ifndef NEW_GC extern EMACS_INT gc_generation_number[1]; #endif /* not NEW_GC */ int c_readonly (Lisp_Object); int lisp_readonly (Lisp_Object); -MODULE_API void copy_lisp_object (Lisp_Object dst, Lisp_Object src); MODULE_API Lisp_Object build_istring (const Ibyte *); MODULE_API Lisp_Object build_cistring (const CIbyte *); MODULE_API Lisp_Object build_ascstring (const Ascbyte *); @@ -4717,21 +4245,6 @@ void free_marker (Lisp_Object); int object_dead_p (Lisp_Object); void mark_object (Lisp_Object obj); -#ifndef NEW_GC -#ifdef USE_KKCC -#ifdef DEBUG_XEMACS -void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj, int level, int pos); -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj, level, pos) -void kkcc_backtrace (void); -#else -void kkcc_gc_stack_push_lisp_object_1 (Lisp_Object obj); -#define kkcc_gc_stack_push_lisp_object(obj, level, pos) \ - kkcc_gc_stack_push_lisp_object_1 (obj) -#define kkcc_backtrace() -#endif -#endif /* USE_KKCC */ -#endif /* not NEW_GC */ int marked_p (Lisp_Object obj); extern int funcall_allocation_flag; extern int need_to_garbage_collect; @@ -4740,10 +4253,7 @@ extern Lisp_Object Qpost_gc_hook, Qgarbage_collecting; void recompute_funcall_allocation_flag (void); -#ifdef MEMORY_USAGE_STATS -Bytecount malloced_storage_size (void *, Bytecount, struct overhead_stats *); -Bytecount fixed_type_block_overhead (Bytecount); -#endif +Bytecount malloced_storage_size (void *, Bytecount, struct usage_stats *); #ifdef EVENT_DATA_AS_OBJECTS Lisp_Object make_key_data (void); @@ -4806,6 +4316,7 @@ extern Lisp_Object Qbefore_change_function, Qbefore_change_functions; extern Lisp_Object Qbuffer_or_string_p, Qdefault_directory, Qfirst_change_hook; extern Lisp_Object Qpermanent_local, Vafter_change_function; +extern Lisp_Object Qbuffer_live_p; extern Lisp_Object Vafter_change_functions, Vbefore_change_function; extern Lisp_Object Vbefore_change_functions, Vbuffer_alist, Vbuffer_defaults; extern Lisp_Object Vinhibit_read_only, Vtransient_mark_mode; @@ -4821,6 +4332,12 @@ /* Defined in callint.c */ EXFUN (Fcall_interactively, 3); EXFUN (Fprefix_numeric_value, 1); +extern Lisp_Object Qcall_interactively; +extern Lisp_Object Qmouse_leave_buffer_hook; +extern Lisp_Object Qread_from_minibuffer; +extern Lisp_Object Vcommand_history; +extern Lisp_Object Vcurrent_prefix_arg; +extern Lisp_Object Vmark_even_if_inactive; /* Defined in casefiddle.c */ EXFUN (Fdowncase, 2); @@ -4835,12 +4352,28 @@ /* Defined in chartab.c */ EXFUN (Freset_char_table, 1); +extern Lisp_Object Qcategory_designator_p; +extern Lisp_Object Qcategory_table_value_p; + +/* Defined in cmdloop.c */ +extern Lisp_Object Qdisabled_command_hook; +extern Lisp_Object Qreally_early_error_handler; +extern Lisp_Object Qtop_level; +extern Lisp_Object Vdisabled_command_hook; /* Defined in cmds.c */ EXFUN (Fbeginning_of_line, 2); EXFUN (Fend_of_line, 2); EXFUN (Fforward_char, 2); EXFUN (Fforward_line, 2); +extern Lisp_Object Qself_insert_command; + +/* Defined in console.c */ +extern Lisp_Object Qconsole_live_p; +extern Lisp_Object Vconsole_list; + +/* Defined in console-stream.c */ +extern Lisp_Object Vstdio_str; /* Defined in data.c */ EXFUN (Fadd1, 1); @@ -4908,7 +4441,8 @@ Qcircular_list, Qcircular_property_list, Qconversion_error, Qcyclic_variable_indirection, Qdomain_error, Qediting_error, Qend_of_buffer, Qend_of_file, Qerror, Qfile_error, Qinternal_error, - Qinvalid_change, Qinvalid_constant, Qinvalid_function, Qinvalid_operation, + Qinvalid_change, Qinvalid_constant, Qinvalid_function, + Qinvalid_keyword_argument, Qinvalid_operation, Qinvalid_read_syntax, Qinvalid_state, Qio_error, Qlist_formation_error, Qmalformed_list, Qmalformed_property_list, Qno_catch, Qout_of_memory, Qoverflow_error, Qprinting_unreadable_object, Qquit, Qrange_error, @@ -4916,8 +4450,18 @@ Qstructure_formation_error, Qtext_conversion_error, Qunderflow_error, Qvoid_function, Qvoid_variable, Qwrong_number_of_arguments, Qwrong_type_argument; +extern Lisp_Object Qcdr; +extern Lisp_Object Qerror_lacks_explanatory_string; +extern Lisp_Object Qfile_error; +extern Lisp_Object Qsequencep; extern MODULE_API Lisp_Object Qinvalid_argument, Qsyntax_error; +/* Defined in device.c */ +extern Lisp_Object Qdevice_live_p; + +/* Defined in device-x.c */ +extern Lisp_Object Vx_initial_argv_list; + /* Defined in dired.c */ Lisp_Object make_directory_hash_table (const Ibyte *); Lisp_Object wasteful_word_to_lisp (unsigned int); @@ -4930,6 +4474,7 @@ Lisp_Object name_reloc, int standard_doc_file); Lisp_Object read_doc_string (Lisp_Object); +extern Lisp_Object Vinternal_doc_file_name; /* Defined in doprnt.c */ Bytecount emacs_doprnt_va (Lisp_Object stream, const Ibyte *format_nonreloc, @@ -5002,10 +4547,16 @@ Lisp_Object save_restriction_restore (Lisp_Object); void widen_buffer (struct buffer *b, int no_clip); int beginning_of_line_p (struct buffer *b, Charbpos pt); - -/* Defined in emacsfns.c */ Lisp_Object save_current_buffer_restore (Lisp_Object); +extern Lisp_Object Qformat; +extern Lisp_Object Qmark; +extern Lisp_Object Qpoint; +extern Lisp_Object Qregion_beginning; +extern Lisp_Object Qregion_end; +extern Lisp_Object Quser_files_and_directories; +extern Lisp_Object Vsystem_name; + /* Defined in emacs.c */ EXFUN_NORETURN (Fkill_emacs, 1); EXFUN (Frunning_temacs_p, 0); @@ -5029,12 +4580,31 @@ DECLARE_DOESNT_RETURN (really_abort (void)); void zero_out_command_line_status_vars (void); +extern Lisp_Object Qsave_buffers_kill_emacs; +extern Lisp_Object Vcommand_line_args; +extern Lisp_Object Vconfigure_info_directory; +extern Lisp_Object Vconfigure_site_directory; +extern Lisp_Object Vconfigure_site_module_directory; +extern Lisp_Object Vdata_directory; +extern Lisp_Object Vdoc_directory; +extern Lisp_Object Vemacs_major_version; +extern Lisp_Object Vemacs_minor_version; +extern Lisp_Object Vexec_directory; +extern Lisp_Object Vexec_path; +extern Lisp_Object Vinvocation_directory; +extern Lisp_Object Vinvocation_name; +extern Lisp_Object Vmodule_directory; +extern Lisp_Object Vsite_directory; +extern Lisp_Object Vsite_module_directory; + /* Defined in emodules.c */ #ifdef HAVE_SHLIB EXFUN (Flist_modules, 0); EXFUN (Fload_module, 3); extern int unloading_module; #endif +extern Lisp_Object Qdll_error; +extern Lisp_Object Qmodule; /* Defined in eval.c */ MODULE_API EXFUN (Fapply, MANY); @@ -5136,6 +4706,8 @@ Lisp_Object frob2)); void maybe_invalid_argument (const Ascbyte *, Lisp_Object, Lisp_Object, Error_Behavior); +MODULE_API DECLARE_DOESNT_RETURN (invalid_keyword_argument (Lisp_Object fun, + Lisp_Object kw)); MODULE_API DECLARE_DOESNT_RETURN (invalid_operation (const Ascbyte *reason, Lisp_Object frob)); MODULE_API DECLARE_DOESNT_RETURN (invalid_operation_2 (const Ascbyte *reason, @@ -5345,8 +4917,23 @@ ...) PRINTF_ARGS (3, 4); extern int backtrace_with_internal_sections; +extern Lisp_Object Qand_optional; +extern Lisp_Object Qand_rest; +extern Lisp_Object Qautoload; +extern Lisp_Object Qcommandp; +extern Lisp_Object Qdefun; +extern Lisp_Object Qexit; +extern Lisp_Object Qinhibit_quit; +extern Lisp_Object Qinteractive; +extern Lisp_Object Qmacro; +extern Lisp_Object Qprogn; +extern Lisp_Object Qrun_hooks; +extern Lisp_Object Qvalues; extern Lisp_Object Vdebug_on_error; extern Lisp_Object Vstack_trace_on_error; +extern Lisp_Object Vautoload_queue; + +extern MODULE_API Lisp_Object Vinhibit_quit, Vquit_flag; /* Defined in event-stream.c */ EXFUN (Faccept_process_output, 3); @@ -5368,6 +4955,19 @@ Lisp_Object, int, int, int, int); extern int modifier_keys_are_sticky; +extern Lisp_Object Qdisabled; +extern Lisp_Object Qsans_modifiers; +extern Lisp_Object Qself_insert_defer_undo; +extern Lisp_Object Vcontrolling_terminal; +extern Lisp_Object Vcurrent_mouse_event; +extern Lisp_Object Vlast_command; +extern Lisp_Object Vlast_command_char; +extern Lisp_Object Vlast_command_event; +extern Lisp_Object Vlast_input_event; +extern Lisp_Object Vrecent_keys_ring; +extern Lisp_Object Vthis_command_keys; +extern Lisp_Object Vunread_command_event; + /* Defined in event-Xt.c */ void signal_special_Xt_user_event (Lisp_Object, Lisp_Object, Lisp_Object); @@ -5382,6 +4982,22 @@ EXFUN (Fevent_x_pixel, 1); EXFUN (Fevent_y_pixel, 1); +extern Lisp_Object Qevent_live_p; + + +/* Defined in extents.c */ +extern Lisp_Object Qend_open; +extern Lisp_Object Qextent_live_p; +extern Lisp_Object Qstart_open; + +/* Defined in faces.c */ +extern Lisp_Object Qbackground; +extern Lisp_Object Qbackground_pixmap; +extern Lisp_Object Qblinking; +extern Lisp_Object Qdim; +extern Lisp_Object Qdisplay_table; +extern Lisp_Object Qforeground; +extern Lisp_Object Qunderline; /* Defined in file-coding.c */ EXFUN (Fcoding_category_list, 0); @@ -5469,6 +5085,9 @@ Ibyte *find_end_of_directory_component (const Ibyte *path, Bytecount len); +extern Lisp_Object Qfile_name_sans_extension; +extern Lisp_Object Vdirectory_sep_char; + /* Defined in filelock.c */ EXFUN (Funlock_buffer, 0); @@ -5529,7 +5148,7 @@ EXFUN (Fsort, 2); EXFUN (Fstring_equal, 2); EXFUN (Fstring_lessp, 2); -EXFUN (Fsubstring, 3); +EXFUN (Fsubseq, 3); EXFUN (Fvalid_plist_p, 1); Lisp_Object list_sort (Lisp_Object, Lisp_Object, @@ -5580,15 +5199,48 @@ Lisp_Object add_prefix_to_symbol (const Ascbyte *ascii_string, Lisp_Object symbol); +extern Lisp_Object Qidentity; +extern Lisp_Object Qstring_lessp; +extern Lisp_Object Qyes_or_no_p; +extern Lisp_Object Vfeatures; + +/* Defined in frame.c */ +extern Lisp_Object Qframe_live_p; + /* Defined in free-hook.c */ EXFUN (Freally_free, 1); +/* Defined in general.c */ +#define SYMBOL(fou) extern Lisp_Object fou +#define SYMBOL_MODULE_API(fou) extern MODULE_API Lisp_Object fou +#define SYMBOL_KEYWORD(la_cle_est_fou) extern Lisp_Object la_cle_est_fou +#define SYMBOL_GENERAL(tout_le_monde, est_fou) \ + extern Lisp_Object tout_le_monde + +#include "general-slots.h" + +#undef SYMBOL +#undef SYMBOL_MODULE_API +#undef SYMBOL_KEYWORD +#undef SYMBOL_GENERAL + /* Defined in glyphs.c */ EXFUN (Fmake_glyph_internal, 1); Error_Behavior decode_error_behavior_flag (Lisp_Object); Lisp_Object encode_error_behavior_flag (Error_Behavior); +extern Lisp_Object Qbuffer_glyph_p; +extern Lisp_Object Qcolor_pixmap_image_instance_p; +extern Lisp_Object Qicon_glyph_p; +extern Lisp_Object Qmono_pixmap_image_instance_p; +extern Lisp_Object Qnothing_image_instance_p; +extern Lisp_Object Qpointer_glyph_p; +extern Lisp_Object Qpointer_image_instance_p; +extern Lisp_Object Qsubwindow; +extern Lisp_Object Qsubwindow_image_instance_p; +extern Lisp_Object Qtext_image_instance_p; + /* Defined in glyphs-shared.c */ void shared_resource_validate (Lisp_Object instantiator); Lisp_Object shared_resource_normalize (Lisp_Object inst, @@ -5597,11 +5249,17 @@ Lisp_Object tag); extern Lisp_Object Q_resource_type, Q_resource_id; +/* Defined in glyphs-widget.c */ +extern Lisp_Object Qlayout; +extern Lisp_Object Qnative_layout; + /* Defined in gui.c */ DECLARE_DOESNT_RETURN (gui_error (const Ascbyte *reason, Lisp_Object frob)); DECLARE_DOESNT_RETURN (gui_error_2 (const Ascbyte *reason, Lisp_Object frob0, Lisp_Object frob1)); +extern Lisp_Object Qgui_error; + /* Defined in indent.c */ EXFUN (Findent_to, 3); EXFUN (Fvertical_motion, 3); @@ -5656,9 +5314,22 @@ # define LOADHIST_ATTACH(x) #endif /*! LOADHIST */ +extern Lisp_Object Qfeaturep; +extern Lisp_Object Qload; +extern Lisp_Object Qread_char; +extern Lisp_Object Qstandard_input; +extern Lisp_Object Vcurrent_load_list; +extern Lisp_Object Vfile_domain; +extern Lisp_Object Vload_file_name_internal; +extern Lisp_Object Vload_history; +extern Lisp_Object Vload_path; +extern Lisp_Object Vstandard_input; + /* Defined in macros.c */ EXFUN (Fexecute_kbd_macro, 2); +extern Lisp_Object Vexecuting_macro; + /* Defined in marker.c */ EXFUN (Fcopy_marker, 2); EXFUN (Fmake_marker, 0); @@ -5675,11 +5346,18 @@ Lisp_Object noseeum_copy_marker (Lisp_Object, Lisp_Object); Lisp_Object set_marker_restricted (Lisp_Object, Lisp_Object, Lisp_Object); #ifdef MEMORY_USAGE_STATS -int compute_buffer_marker_usage (struct buffer *, struct overhead_stats *); +Bytecount compute_buffer_marker_usage (struct buffer *b); #endif void init_buffer_markers (struct buffer *b); void uninit_buffer_markers (struct buffer *b); +/* Defined in menubar.c */ +extern Lisp_Object Qactivate_menubar_hook; +extern Lisp_Object Qcurrent_menubar; +extern Lisp_Object Vactivate_menubar_hook; +extern Lisp_Object Vblank_menubar; +extern Lisp_Object Vmenubar_configuration; + /* Defined in minibuf.c */ extern int minibuf_level; Charcount scmp_1 (const Ibyte *, const Ibyte *, Charcount, int); @@ -5704,10 +5382,26 @@ void message_no_translate (const char *, ...) PRINTF_ARGS (1, 2); void clear_message (void); +extern Lisp_Object Qcompletion_ignore_case; +extern Lisp_Object Vecho_area_buffer; +extern Lisp_Object Vminibuf_preprompt; +extern Lisp_Object Vminibuf_prompt; +extern Lisp_Object Vminibuffer_zero; + /* Defined in mule-charset.c */ EXFUN (Fmake_charset, 3); extern Lisp_Object Ql2r, Qr2l; +extern Lisp_Object Qdirection; +extern Lisp_Object Qfinal; +extern Lisp_Object Qgraphic; +extern Lisp_Object Qlong_name; +extern Lisp_Object Qregistries; +extern Lisp_Object Qreverse_direction_charset; +extern Lisp_Object Qshort_name; + +/* Defined in nt.c */ +extern Lisp_Object Vmswindows_get_true_file_attributes; /* Defined in print.c */ EXFUN (Fdisplay_error, 2); @@ -5778,13 +5472,30 @@ Lisp_Object (*) (Lisp_Object), Lisp_Object, Lisp_Object); void float_to_string (char *, double); -void internal_object_printer (Lisp_Object, Lisp_Object, int); -MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object (const CIbyte *, +void internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, + int UNUSED (escapeflag)); +void external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, + int UNUSED (escapeflag)); +MODULE_API DECLARE_DOESNT_RETURN (printing_unreadable_object_fmt (const CIbyte *, ...)) PRINTF_ARGS (1, 2); -DECLARE_DOESNT_RETURN (printing_unreadable_lcrecord (Lisp_Object obj, +DECLARE_DOESNT_RETURN (printing_unreadable_lisp_object (Lisp_Object obj, const Ibyte *name)); +extern Lisp_Object Qexternal_debugging_output; +extern Lisp_Object Qprint_length; +extern Lisp_Object Qprint_string_length; +extern Lisp_Object Qstandard_output; +extern Lisp_Object Vprint_length; +extern Lisp_Object Vprint_level; +extern Lisp_Object Vstandard_output; + +/* Defined in process.c */ +extern Lisp_Object Qnetwork_error; +extern MODULE_API Lisp_Object Qprocess_error; +extern Lisp_Object Vprocess_environment; +extern Lisp_Object Vshell_file_name; + /* Defined in rangetab.c */ EXFUN (Fclear_range_table, 1); EXFUN (Fget_range_table, 3); @@ -5846,6 +5557,9 @@ void init_device_sound (struct device *); DECLARE_DOESNT_RETURN (report_sound_error (const Ascbyte *, Lisp_Object)); +extern Lisp_Object Qsound_error; +extern Lisp_Object Vsynchronous_sounds; + /* Defined in specifier.c */ EXFUN (Fadd_spec_to_specifier, 5); EXFUN (Fspecifier_spec_list, 4); @@ -5889,6 +5603,14 @@ int function_p, Lisp_Object follow_past_lisp_magic); +extern Lisp_Object Qconst_specifier; +extern Lisp_Object Qmakunbound; +extern Lisp_Object Qset; +extern Lisp_Object Qvariable_documentation; +extern Lisp_Object Qvariable_domain; +extern MODULE_API Lisp_Object Qt, Qunbound; +extern Lisp_Object Vobarray; + /* Defined in syntax.c */ Charbpos scan_words (struct buffer *, Charbpos, int); EXFUN (Fchar_syntax, 2); @@ -6286,6 +6008,9 @@ MODULE_API int find_pos_of_existing_active_alloca_convert (const char * srctext); +/* Defined in undo.c */ +extern Lisp_Object Qinhibit_read_only; + /* Defined in unicode.c */ extern const struct sized_memory_description to_unicode_description; extern const struct sized_memory_description from_unicode_description; @@ -6296,9 +6021,9 @@ extern Lisp_Object Qutf_16, Qutf_8, Qucs_4, Qutf_7, Qutf_32; #ifdef MEMORY_USAGE_STATS Bytecount compute_from_unicode_table_size (Lisp_Object charset, - struct overhead_stats *stats); + struct usage_stats *stats); Bytecount compute_to_unicode_table_size (Lisp_Object charset, - struct overhead_stats *stats); + struct usage_stats *stats); #endif /* MEMORY_USAGE_STATS */ /* Defined in undo.c */ @@ -6323,139 +6048,11 @@ /* Defined in vm-limit.c */ void memory_warnings (void *, void (*) (const char *)); -/*--------------- prototypes for constant symbols ------------*/ - -/* #### We should get rid of this and put the prototypes back up there in - #### the per-file stuff, where they belong. */ - -/* Use the following when you have to add a bunch of symbols. */ - -/* - -(defun redo-symbols (beg end) - "Snarf any symbols out of the region and print them into a temporary buffer, -which is displayed when the function finishes. The symbols are laid out with -`extern Lisp_Object ' before each one, with as many as can fit on one line -\(the maximum line width is controlled by the constant `max-line-length' in the -code)." - (interactive "r") - (save-excursion - (goto-char beg) - (let (syms) - (while (re-search-forward "\\s-\\(Q[A-Za-z_0-9]+\\)" end t) - (push (match-string 1) syms)) - (setq syms (sort syms #'string-lessp)) - (with-output-to-temp-buffer "*Symbols*" - (let* ((col 0) - (start "extern Lisp_Object ") - (startlen (length start)) - ;; with a default-width frame of 80 chars, you can only fit - ;; 79 before wrapping. you can see this to a lower value if - ;; you don't want it right up against the right margin. - (max-line-length 79)) - (dolist (sym syms) - (cond (;; if something already on line (this will always be the - ;; case except the very first iteration), see what - ;; space we've got. (need to take into account 2 - ;; for the comma+space, 1 for the semicolon at the - ;; end.) if enough space, do it. - (and (> col 0) (< (+ col (length sym) 2) - (1- max-line-length))) - (princ ", ") - (princ sym) - (incf col 2) - (incf col (length sym))) - (t - ;; either we're first iteration or we ran out of space. - ;; if the latter, terminate the previous line. this - ;; loop is written on purpose so that it always prints - ;; at least one item, even if that would go over. - (when (> col 0) - (princ ";\n") - (setq col 0)) - (princ start) - (incf col startlen) - (princ sym) - (incf col (length sym))))) - ;; finally terminate the last line. - (princ ";\n")))))) - -*/ - -extern Lisp_Object Qactivate_menubar_hook, Qand_optional, Qand_rest, Qautoload, - Qbackground, Qbackground_pixmap, Qblinking, Qbuffer_glyph_p, Qbuffer_live_p, - Qcall_interactively, Qcategory_designator_p, - Qcategory_table_value_p, Qcdr, Qcolor_pixmap_image_instance_p, Qcommandp, - Qcompletion_ignore_case, Qconsole_live_p, Qconst_specifier, Qcurrent_menubar, - Qdefun, Qdevice_live_p, Qdim, Qdirection, Qdisabled, Qdisabled_command_hook, - Qdisplay_table, Qdll_error, Qend_open, Qerror_lacks_explanatory_string, - Qevent_live_p, Qexit, Qextent_live_p, Qexternal_debugging_output, Qfeaturep, - Qfile_error, Qfile_name_sans_extension, Qfinal, Qforeground, Qformat, - Qframe_live_p, Qgraphic, Qgui_error, Qicon_glyph_p, Qidentity, Qinhibit_quit, - Qinhibit_read_only, Qinteractive, Qlayout, Qload, Qlong_name, Qmacro, - Qmakunbound, Qmark, Qmodule, Qmono_pixmap_image_instance_p, - Qmouse_leave_buffer_hook, Qnative_layout, Qnetwork_error, - Qnothing_image_instance_p, Qpoint, Qpointer_glyph_p, - Qpointer_image_instance_p, Qprint_length, Qprint_string_length, Qprogn, - Qread_char, Qread_from_minibuffer, Qreally_early_error_handler, - Qregion_beginning, Qregion_end, Qregistries, Qreverse_direction_charset, - Qrun_hooks, Qsans_modifiers, Qsave_buffers_kill_emacs, Qself_insert_command, - Qself_insert_defer_undo, Qsequencep, Qset, Qshort_name, Qsound_error, - Qstandard_input, Qstandard_output, Qstart_open, Qstring_lessp, Qsubwindow, - Qsubwindow_image_instance_p, Qtext_image_instance_p, Qtop_level, Qunderline, - Quser_files_and_directories, Qvalues, Qvariable_documentation, - Qvariable_domain, Qwindow_live_p, Qyes_or_no_p; - -extern MODULE_API Lisp_Object Qprocess_error, Qt, Qunbound; - -#define SYMBOL(fou) extern Lisp_Object fou -#define SYMBOL_MODULE_API(fou) extern MODULE_API Lisp_Object fou -#define SYMBOL_KEYWORD(la_cle_est_fou) extern Lisp_Object la_cle_est_fou -#define SYMBOL_GENERAL(tout_le_monde, est_fou) \ - extern Lisp_Object tout_le_monde - -#include "general-slots.h" - -#undef SYMBOL -#undef SYMBOL_MODULE_API -#undef SYMBOL_KEYWORD -#undef SYMBOL_GENERAL - -/*--------------- prototypes for variables of type Lisp_Object ------------*/ - -/* #### We should get rid of this and put the prototypes back up there in - #### the per-file stuff, where they belong. */ - -extern Lisp_Object Vactivate_menubar_hook; -extern Lisp_Object Vautoload_queue, Vblank_menubar; -extern Lisp_Object Vcommand_history; -extern Lisp_Object Vcommand_line_args, Vconfigure_info_directory; -extern Lisp_Object Vconfigure_site_directory, Vconfigure_site_module_directory; -extern Lisp_Object Vconsole_list, Vcontrolling_terminal; -extern Lisp_Object Vcurrent_load_list; -extern Lisp_Object Vcurrent_mouse_event, Vcurrent_prefix_arg, Vdata_directory; -extern Lisp_Object Vdirectory_sep_char, Vdisabled_command_hook; -extern Lisp_Object Vdoc_directory, Vinternal_doc_file_name; -extern Lisp_Object Vecho_area_buffer, Vemacs_major_version; -extern Lisp_Object Vemacs_minor_version, Vexec_directory, Vexec_path; -extern Lisp_Object Vexecuting_macro, Vfeatures, Vfile_domain; -extern Lisp_Object Vinvocation_directory, Vinvocation_name; -extern Lisp_Object Vlast_command, Vlast_command_char; -extern Lisp_Object Vlast_command_event, Vlast_input_event; -extern Lisp_Object Vload_file_name_internal, Vload_history; -extern Lisp_Object Vload_path, Vmark_even_if_inactive, Vmenubar_configuration; -extern Lisp_Object Vminibuf_preprompt, Vminibuf_prompt, Vminibuffer_zero; -extern Lisp_Object Vmodule_directory, Vmswindows_downcase_file_names; -extern Lisp_Object Vmswindows_get_true_file_attributes, Vobarray; -extern Lisp_Object Vprint_length, Vprint_level, Vprocess_environment; -extern Lisp_Object Vrecent_keys_ring, Vshell_file_name, Vsite_directory; -extern Lisp_Object Vsite_module_directory; -extern Lisp_Object Vstandard_input, Vstandard_output, Vstdio_str; -extern Lisp_Object Vsynchronous_sounds, Vsystem_name; -extern Lisp_Object Vthis_command_keys, Vunread_command_event; -extern Lisp_Object Vx_initial_argv_list; - -extern MODULE_API Lisp_Object Vinhibit_quit, Vquit_flag; +/* Defined in win32.c */ +extern Lisp_Object Vmswindows_downcase_file_names; + +/* Defined in window.c */ +extern Lisp_Object Qwindow_live_p; END_C_DECLS
--- a/src/lread.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/lread.c Mon Mar 29 21:28:13 2010 -0500 @@ -1982,8 +1982,14 @@ if (*read_ptr == '+') read_ptr++; ratio_set_string (scratch_ratio, read_ptr, 0); - ratio_canonicalize (scratch_ratio); - return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + if (bignum_sign (ratio_denominator (scratch_ratio)) != 0) { + ratio_canonicalize (scratch_ratio); + return Fcanonicalize_number (make_ratio_rt (scratch_ratio)); + } + return Fsignal (Qinvalid_read_syntax, + list2 (build_msg_string + ("Invalid ratio constant in reader"), + make_string ((Ibyte *) read_ptr, len))); } #endif if (isfloat_string (read_ptr)) @@ -3466,6 +3472,7 @@ #ifdef I18N3 Vfile_domain = Qnil; + staticpro (&Vfile_domain); #endif Vread_objects = Qnil;
--- a/src/lrecord.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/lrecord.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* The "lrecord" structure (header of a compound lisp object). Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc. - Copyright (C) 1996, 2001, 2002, 2004, 2005, 2010 Ben Wing. + Copyright (C) 1996, 2001, 2002, 2004, 2005, 2009, 2010 Ben Wing. This file is part of XEmacs. @@ -26,40 +26,132 @@ #ifndef INCLUDED_lrecord_h_ #define INCLUDED_lrecord_h_ -/* The "lrecord" type of Lisp object is used for all object types other - than a few simple ones (like char and int). This allows many types to be - implemented but only a few bits required in a Lisp object for type - information. (The tradeoff is that each object has its type marked in - it, thereby increasing its size.) All lrecords begin with a `struct - lrecord_header', which identifies the lisp object type, by providing an - index into a table of `struct lrecord_implementation', which describes - the behavior of the lisp object. It also contains some other data bits. +/* All objects other than char and int are implemented as structures and + passed by reference. Such objects are called "record objects" ("record" + is another term for "structure"). The "wrapped" value of such an object + (i.e. when stored in a variable of type Lisp_Object) is simply the raw + pointer coerced to an integral type the same size as the pointer + (usually `long'). + + Under old-GC (i.e. when NEW_GC is not defined), there are two kinds of + record objects: normal objects (those allocated on their own with + xmalloc()) and frob-block objects (those allocated as pieces of large, + usually 2K, chunks of memory known as "frob blocks"). Under NEW_GC, + there is only one type of record object. Stuff below that applies to + frob-block objects is assumed to apply to the same type of object as + normal objects under NEW_GC. + + Record objects have a header at the beginning of their structure, which + is used internally to identify the type of the object (so that an + object's type can be recovered from its pointer); in addition, it holds + a few flags and a "UID", which for most objects is shown when it is + printed, and is primarily useful for debugging purposes. The header of + a normal object is declared as NORMAL_LISP_OBJECT_HEADER and that of a + frob-block object FROB_BLOCK_LISP_OBJECT_HEADER. + + FROB_BLOCK_LISP_OBJECT_HEADER boils down to a `struct lrecord_header'. + This is a 32-bit value made up of bit fields, where 8 bits are used to + hold the type, 2 or 3 bits are used for flags associated with the + garbage collector, and the remaining 21 or 22 bits hold the UID. + + Under NEW_GC, NORMAL_LISP_OBJECT_HEADER also resolves to `struct + lrecord_header'. Under old-GC, however, NORMAL_LISP_OBJECT_HEADER + resolves to a `struct old_lcrecord_header' (note the `c'), which is a + larger structure -- on 32-bit machines it occupies 2 machine words + instead of 1. Such an object is known internally as an "lcrecord". The + first word of `struct old_lcrecord_header' is an embedded `struct + lrecord_header' with the same information as for frob-block objects; + that way, all objects can be cast to a `struct lrecord_header' to + determine their type or other info. The other word is a pointer, used + to thread all lcrecords together in one big linked list. + + Under old-GC, normal objects (i.e. lcrecords) are allocated in + individual chunks using the underlying allocator (i.e. xmalloc(), which + is a thin wrapper around malloc()). Frob-block objects are more + efficient than normal objects, as they have a smaller header and don't + have the additional memory overhead associated with malloc() -- instead, + as mentioned above, they are carved out of 2K chunks of memory called + "frob blocks"). However, it is slightly more tricky to create such + objects, as they require special routines in alloc.c to create an object + of each such type and to sweep them during garbage collection. In + addition, there is currently no mechanism for handling variable-sized + frob-block objects (e.g. vectors), whereas variable-sized normal objects + are not a problem. Frob-block objects are typically used for basic + objects that exist in large numbers, such as `cons' or `string'. -#ifndef NEW_GC - Lrecords are of two types: straight lrecords, and lcrecords. - Straight lrecords are used for those types of objects that have - their own allocation routines (typically allocated out of 2K chunks - of memory called `frob blocks'). These objects have a `struct - lrecord_header' at the top, containing only the bits needed to find - the lrecord_implementation for the object. There are special - routines in alloc.c to create an object of each such type. + Note that strings are an apparent exception to the statement above that + variable-sized objects can't be handled. Under old-GC strings work as + follows. A string consists of two parts -- a fixed-size "string header" + that is allocated as a standard frob-block object, and a "string-chars" + structure that is allocated out of special 8K-sized frob blocks that + have a dedicated garbage-collection handler that compacts the blocks + during the sweep stage, relocating the string-chars data (but not the + string headers) to eliminate gaps. Strings larger than 8K are not + placed in frob blocks, but instead are stored as individually malloc()ed + blocks of memory. Strings larger than 8K are called "big strings" and + those smaller than 8K are called "small strings". + + Under new-GC, there is no difference between big and small strings, + just as there is no difference between normal and frob-block objects. + There is only one allocation method, which is capable of handling + variable-sized objects. This apparently allocates all objects in + frob blocks according to the size of the object. + + To create a new normal Lisp object, see the toolbar-button example + below. To create a new frob-block Lisp object, follow the lead of + one of the existing frob-block objects, such as extents or events. + Note that you do not need to supply all the methods (see below); + reasonable defaults are provided for many of them. Alternatively, if + you're just looking for a way of encapsulating data (which possibly + could contain Lisp_Objects in it), you may well be able to use the + opaque type. +*/ + +/* + How to declare a Lisp object: + + NORMAL_LISP_OBJECT_HEADER: + Header for normal objects + + FROB_BLOCK_LISP_OBJECT_HEADER: + Header for frob-block objects - Lcrecords are used for less common sorts of objects that don't do - their own allocation. Each such object is malloc()ed individually, - and the objects are chained together through a `next' pointer. - Lcrecords have a `struct old_lcrecord_header' at the top, which - contains a `struct lrecord_header' and a `next' pointer, and are - allocated using old_alloc_lcrecord_type() or its variants. -#endif + How to allocate a Lisp object: + + - For normal objects of a fixed size, simply call + ALLOC_NORMAL_LISP_OBJECT (type), where TYPE is the name of the type + (e.g. toolbar_button). Such objects can be freed manually using + free_normal_lisp_object. + + - For normal objects whose size can vary (and hence which have a + size_in_bytes_method rather than a static_size), call + ALLOC_SIZED_LISP_OBJECT (size, type), where TYPE is the + name of the type. NOTE: You cannot call free_normal_lisp_object() on such + on object! (At least when not NEW_GC) + + - For frob-block objects, use + ALLOC_FROB_BLOCK_LISP_OBJECT (type, lisp_type, var, lrec_ptr). + But these objects need special handling; if you don't understand this, + just ignore it. - Creating a new Lisp object type is fairly easy; just follow the - lead of some existing type (e.g. hash tables). Note that you - do not need to supply all the methods (see below); reasonable - defaults are provided for many of them. Alternatively, if you're - just looking for a way of encapsulating data (which possibly - could contain Lisp_Objects in it), you may well be able to use - the opaque type. -*/ + - Some lrecords, which are used totally internally, use the + noseeum-* functions for debugging reasons. + + Other operations: + + - copy_lisp_object (dst, src) + + - zero_nonsized_lisp_object (obj), zero_sized_lisp_object (obj, size): + BUT NOTE, it is not necessary to zero out newly allocated Lisp objects. + This happens automatically. + + - lisp_object_size (obj): Return the size of a Lisp object. NOTE: This + requires that the object is properly initialized. + + - lisp_object_storage_size (obj, stats): Return the storage size of a + Lisp objcet, including malloc or frob-block overhead; also, if STATS + is non-NULL, accumulate info about the size and overhead into STATS. + */ #ifdef NEW_GC /* @@ -74,44 +166,42 @@ object descriptions exist to indicate the size of these structures and the Lisp object pointers within them. - At least one definite issue is that under New-GC dumpable objects cannot - contain any finalizers (see pdump_register_object()). This means that any - substructures in dumpable objects that are allocated separately and - normally freed in a finalizer need instead to be made into actual Lisp - objects. If those structures are Dynarrs, they need to be made into - Dynarr Lisp objects (e.g. face-cachel-dynarr or glyph-cachel-dynarr), - which are created using Dynarr_lisp_new() or Dynarr_new_new2(). - Furthermore, the objects contained in the Dynarr also need to be Lisp - objects (e.g. face-cachel or glyph-cachel). + At least one definite issue is that under New-GC dumpable objects cannot + contain any finalizers (see pdump_register_object()). This means that + any substructures in dumpable objects that are allocated separately and + normally freed in a finalizer need instead to be made into actual Lisp + objects. If those structures are Dynarrs, they need to be made into + Dynarr Lisp objects (e.g. face-cachel-dynarr or glyph-cachel-dynarr), + which are created using Dynarr_lisp_new() or Dynarr_new_new2(). + Furthermore, the objects contained in the Dynarr also need to be Lisp + objects (e.g. face-cachel or glyph-cachel). --ben */ - #endif - - #ifdef NEW_GC -#define ALLOC_LCRECORD_TYPE alloc_lrecord_type -#define COPY_SIZED_LCRECORD copy_sized_lrecord -#define COPY_LCRECORD copy_lrecord -#define LISPOBJ_STORAGE_SIZE(ptr, size, stats) \ - mc_alloced_storage_size (size, stats) -#define ZERO_LCRECORD zero_lrecord -#define LCRECORD_HEADER lrecord_header -#define BASIC_ALLOC_LCRECORD alloc_lrecord -#define FREE_LCRECORD free_lrecord +#define ALLOC_NORMAL_LISP_OBJECT(type) alloc_lrecord (&lrecord_##type) +#define ALLOC_SIZED_LISP_OBJECT(size, type) \ + alloc_sized_lrecord (size, &lrecord_##type) +#define NORMAL_LISP_OBJECT_HEADER struct lrecord_header +#define FROB_BLOCK_LISP_OBJECT_HEADER struct lrecord_header +#define LISP_OBJECT_FROB_BLOCK_P(obj) 0 +#define IF_NEW_GC(x) x +#define IF_OLD_GC(x) 0 #else /* not NEW_GC */ -#define ALLOC_LCRECORD_TYPE old_alloc_lcrecord_type -#define COPY_SIZED_LCRECORD old_copy_sized_lcrecord -#define COPY_LCRECORD old_copy_lcrecord -#define LISPOBJ_STORAGE_SIZE malloced_storage_size -#define ZERO_LCRECORD old_zero_lcrecord -#define LCRECORD_HEADER old_lcrecord_header -#define BASIC_ALLOC_LCRECORD old_basic_alloc_lcrecord -#define FREE_LCRECORD old_free_lcrecord +#define ALLOC_NORMAL_LISP_OBJECT(type) alloc_automanaged_lcrecord (&lrecord_##type) +#define ALLOC_SIZED_LISP_OBJECT(size, type) \ + old_alloc_sized_lcrecord (size, &lrecord_##type) +#define NORMAL_LISP_OBJECT_HEADER struct old_lcrecord_header +#define FROB_BLOCK_LISP_OBJECT_HEADER struct lrecord_header +#define LISP_OBJECT_FROB_BLOCK_P(obj) (XRECORD_LHEADER_IMPLEMENTATION(obj)->frob_block_p) +#define IF_NEW_GC(x) 0 +#define IF_OLD_GC(x) x #endif /* not NEW_GC */ +#define LISP_OBJECT_UID(obj) (XRECORD_LHEADER (obj)->uid) + BEGIN_C_DECLS struct lrecord_header @@ -150,34 +240,45 @@ /* 1 if the object is readonly from lisp */ unsigned int lisp_readonly :1; + /* The `free' field is currently used only for lcrecords under old-GC. + It is a flag that indicates whether this lcrecord is on a "free list". + Free lists are used to minimize the number of calls to malloc() when + we're repeatedly allocating and freeing a number of the same sort of + lcrecord. Lcrecords on a free list always get marked in a different + fashion, so we can use this flag as a sanity check to make sure that + free lists only have freed lcrecords and there are no freed lcrecords + elsewhere. */ + unsigned int free :1; + /* The `uid' field is just for debugging/printing convenience. Having this slot doesn't hurt us spacewise, since the bits are unused anyway. (The bits are used for strings, though.) */ - unsigned int uid :21; + unsigned int uid :20; #endif /* not NEW_GC */ }; struct lrecord_implementation; int lrecord_type_index (const struct lrecord_implementation *implementation); -extern int lrecord_uid_counter; +extern int lrecord_uid_counter[]; #ifdef NEW_GC -#define set_lheader_implementation(header,imp) do { \ - struct lrecord_header* SLI_header = (header); \ - SLI_header->type = (imp)->lrecord_type_index; \ - SLI_header->lisp_readonly = 0; \ - SLI_header->free = 0; \ - SLI_header->uid = lrecord_uid_counter++; \ +#define set_lheader_implementation(header,imp) do { \ + struct lrecord_header* SLI_header = (header); \ + SLI_header->type = (imp)->lrecord_type_index; \ + SLI_header->lisp_readonly = 0; \ + SLI_header->free = 0; \ + SLI_header->uid = lrecord_uid_counter[(imp)->lrecord_type_index]++; \ } while (0) #else /* not NEW_GC */ -#define set_lheader_implementation(header,imp) do { \ - struct lrecord_header* SLI_header = (header); \ - SLI_header->type = (imp)->lrecord_type_index; \ - SLI_header->mark = 0; \ - SLI_header->c_readonly = 0; \ - SLI_header->lisp_readonly = 0; \ - SLI_header->uid = lrecord_uid_counter++; \ +#define set_lheader_implementation(header,imp) do { \ + struct lrecord_header* SLI_header = (header); \ + SLI_header->type = (imp)->lrecord_type_index; \ + SLI_header->mark = 0; \ + SLI_header->c_readonly = 0; \ + SLI_header->lisp_readonly = 0; \ + SLI_header->free = 0; \ + SLI_header->uid = lrecord_uid_counter[(imp)->lrecord_type_index]++; \ } while (0) #endif /* not NEW_GC */ @@ -188,7 +289,7 @@ /* The `next' field is normally used to chain all lcrecords together so that the GC can find (and free) all of them. - `old_basic_alloc_lcrecord' threads lcrecords together. + `old_alloc_sized_lcrecord' threads lcrecords together. The `next' field may be used for other purposes as long as some other mechanism is provided for letting the GC do its work. @@ -197,20 +298,6 @@ out of memory chunks, and are able to find all unmarked members by sweeping through the elements of the list of chunks. */ struct old_lcrecord_header *next; - - /* The `uid' field is just for debugging/printing convenience. - Having this slot doesn't hurt us much spacewise, since an - lcrecord already has the above slots plus malloc overhead. */ - unsigned int uid :31; - - /* The `free' field is a flag that indicates whether this lcrecord - is on a "free list". Free lists are used to minimize the number - of calls to malloc() when we're repeatedly allocating and freeing - a number of the same sort of lcrecord. Lcrecords on a free list - always get marked in a different fashion, so we can use this flag - as a sanity check to make sure that free lists only have freed - lcrecords and there are no freed lcrecords elsewhere. */ - unsigned int free :1; }; /* Used for lcrecords in an lcrecord-list. */ @@ -227,7 +314,9 @@ /* Symbol value magic types come first to make SYMBOL_VALUE_MAGIC_P fast. #### This should be replaced by a symbol_value_magic_p flag in the Lisp_Symbol lrecord_header. */ - lrecord_type_symbol_value_forward, /* 0 */ + /* Don't assign any type to 0, so in case we come across zeroed memory + it will be more obvious when printed */ + lrecord_type_symbol_value_forward = 1, lrecord_type_symbol_value_varalias, lrecord_type_symbol_value_lisp_magic, lrecord_type_symbol_value_buffer_local, @@ -281,9 +370,7 @@ lrecord_type_frame, lrecord_type_window, lrecord_type_window_mirror, - lrecord_type_window_configuration, lrecord_type_gui_item, - lrecord_type_popup_data, lrecord_type_toolbar_button, lrecord_type_scrollbar_instance, lrecord_type_color_instance, @@ -376,21 +463,20 @@ mark methods will be removed. */ Lisp_Object (*marker) (Lisp_Object); - /* `printer' converts the object to a printed representation. - This can be NULL; in this case default_object_printer() will be - used instead. */ + /* `printer' converts the object to a printed representation. `printer' + should never be NULL (if so, you will get an assertion failure when + trying to print such an object). Either supply a specific printing + method, or use the default methods internal_object_printer() (for + internal objects that should not be visible at Lisp level) or + external_object_printer() (for objects visible at Lisp level). */ void (*printer) (Lisp_Object, Lisp_Object printcharfun, int escapeflag); - /* `finalizer' is called at GC time when the object is about to be freed, - and at dump time (FOR_DISKSAVE will be non-zero in this case). It - should perform any necessary cleanup (e.g. freeing malloc()ed memory - or releasing objects created in external libraries, such as - window-system windows or file handles). This can be NULL, meaning no - special finalization is necessary. - - WARNING: remember that `finalizer' is called at dump time even though - the object is not being freed -- check the FOR_DISKSAVE argument. */ - void (*finalizer) (void *header, int for_disksave); + /* `finalizer' is called at GC time when the object is about to be freed. + It should perform any necessary cleanup, such as freeing malloc()ed + memory or releasing pointers or handles to objects created in external + libraries, such as window-system windows or file handles. This can be + NULL, meaning no special finalization is necessary. */ + void (*finalizer) (Lisp_Object obj); /* This can be NULL, meaning compare objects with EQ(). */ int (*equal) (Lisp_Object obj1, Lisp_Object obj2, int depth, @@ -408,6 +494,29 @@ /* Data layout description for your object. See long comment below. */ const struct memory_description *description; + /* Only one of `static_size' and `size_in_bytes_method' is non-0. If + `static_size' is 0, this type is not instantiable by + ALLOC_NORMAL_LISP_OBJECT(). If both are 0 (this should never happen), + this object cannot be instantiated; you will get an abort() if you + try.*/ + Bytecount static_size; + Bytecount (*size_in_bytes_method) (Lisp_Object); + + /* The (constant) index into lrecord_implementations_table */ + enum lrecord_type lrecord_type_index; + +#ifndef NEW_GC + /* A "frob-block" lrecord is any lrecord that's not an lcrecord, i.e. + one that does not have an old_lcrecord_header at the front and which + is (usually) allocated in frob blocks. */ + unsigned int frob_block_p :1; +#endif /* not NEW_GC */ + + /**********************************************************************/ + /* Remaining stuff is not assignable statically using + DEFINE_*_LISP_OBJECT, but must be assigned with OBJECT_HAS_METHOD, + OBJECT_HAS_PROPERTY or the like. */ + /* These functions allow any object type to have builtin property lists that can be manipulated from the lisp level with `get', `put', `remprop', and `object-plist'. */ @@ -416,25 +525,91 @@ int (*remprop) (Lisp_Object obj, Lisp_Object prop); Lisp_Object (*plist) (Lisp_Object obj); -#ifdef NEW_GC - /* Only one of `static_size' and `size_in_bytes_method' is non-0. */ -#else /* not NEW_GC */ - /* Only one of `static_size' and `size_in_bytes_method' is non-0. - If both are 0, this type is not instantiable by - old_basic_alloc_lcrecord(). */ -#endif /* not NEW_GC */ - Bytecount static_size; - Bytecount (*size_in_bytes_method) (const void *header); + /* `disksave' is called at dump time. It is used for objects that + contain pointers or handles to objects created in external libraries, + such as window-system windows or file handles. Such external objects + cannot be dumped, so it is necessary to release them at dump time and + arrange somehow or other for them to be resurrected if necessary later + on. + + It seems that even non-dumpable objects may be around at dump time, + and a disksave may be provided. (In fact, the only object currently + with a disksave, lstream, is non-dumpable.) + + Objects rarely need to provide this method; most of the time it will + be NULL. */ + void (*disksave) (Lisp_Object); + +#ifdef MEMORY_USAGE_STATS + /* Return memory-usage information about the object in question, stored + into STATS. + + Two types of information are stored: storage (including overhead) for + ancillary non-Lisp structures attached to the object, and storage + (including overhead) for ancillary Lisp objects attached to the + object. The third type of memory-usage information (storage for the + object itself) is not noted here, because it's computed automatically + by the calling function. Also, the computed storage for ancillary + Lisp objects is the sum of all three source of memory associated with + the Lisp object: the object itself, ancillary non-Lisp structures and + ancillary Lisp objects. Note also that the `struct usage_stats u' at + the beginning of the STATS structure is for ancillary non-Lisp usage + *ONLY*; do not store any memory into it related to ancillary Lisp + objects. + + Note that it may be subjective which Lisp objects are considered + "attached" to the object. Some guidelines: + + -- Lisp objects which are "internal" to the main object and not + accessible except through the main object should be included + -- Objects linked by a weak reference should *NOT* be included + */ + void (*memory_usage) (Lisp_Object obj, struct generic_usage_stats *stats); - /* The (constant) index into lrecord_implementations_table */ - enum lrecord_type lrecord_type_index; + /* List of tags to be given to the extra statistics, one per statistic. + Qnil or Qt can be present to separate off different slices. Qnil + separates different slices within the same group of statistics. + These represent different ways of partitioning the same memory space. + Qt separates different groups; these represent different spaces of + memory. + + If Qt is not present, all slices describe extra non-Lisp-Object memory + associated with a Lisp object. If Qt is present, slices before Qt + describe non-Lisp-Object memory, as before, and slices after Qt + describe ancillary Lisp-Object memory logically associated with the + object. For example, if the object is a table, then ancillary + Lisp-Object memory might be the entries in the table. This info is + only advisory since it will duplicate memory described elsewhere and + since it may not be possible to be completely accurate, e.g. it may + not be clear what to count in "ancillary objects", and the value may + be too high if the same object occurs multiple times in the table. */ + Lisp_Object memusage_stats_list; + + /* --------------------------------------------------------------------- */ -#ifndef NEW_GC - /* A "basic" lrecord is any lrecord that's not an lcrecord, i.e. - one that does not have an old_lcrecord_header at the front and which - is (usually) allocated in frob blocks. */ - unsigned int basic_p :1; -#endif /* not NEW_GC */ + /* The following are automatically computed based on the value in + `memusage_stats_list' (see compute_memusage_stats_length()). */ + + /* Total number of additional type-specific statistics related to memory + usage. */ + Elemcount num_extra_memusage_stats; + + /* Number of additional type-specific statistics belonging to the first + slice of the group describing non-Lisp-Object memory usage for this + object. These stats occur starting at offset 0. */ + Elemcount num_extra_nonlisp_memusage_stats; + + /* The offset into the extra statistics at which the Lisp-Object + memory-usage statistics begin. */ + Elemcount offset_lisp_ancillary_memusage_stats; + + /* Number of additional type-specific statistics belonging to the first + slice of the group describing Lisp-Object memory usage for this + object. These stats occur starting at offset + `offset_lisp_ancillary_memusage_stats'. */ + Elemcount num_extra_lisp_ancillary_memusage_stats; + +#endif /* MEMORY_USAGE_STATS */ }; /* All the built-in lisp object types are enumerated in `enum lrecord_type'. @@ -442,9 +617,11 @@ room in `lrecord_implementations_table' for such new lisp object types. */ #define MODULE_DEFINABLE_TYPE_COUNT 32 -extern MODULE_API const struct lrecord_implementation * +extern MODULE_API struct lrecord_implementation * lrecord_implementations_table[lrecord_type_last_built_in_type + MODULE_DEFINABLE_TYPE_COUNT]; +/* Given a Lisp object, return its implementation + (struct lrecord_implementation) */ #define XRECORD_LHEADER_IMPLEMENTATION(obj) \ LHEADER_IMPLEMENTATION (XRECORD_LHEADER (obj)) #define LHEADER_IMPLEMENTATION(lh) lrecord_implementations_table[(lh)->type] @@ -481,7 +658,7 @@ if (MCACF_implementation && MCACF_implementation->finalizer) \ { \ GC_STAT_FINALIZED; \ - MCACF_implementation->finalizer (ptr, 0); \ + MCACF_implementation->finalizer (MCACF_obj); \ } \ } \ } while (0) @@ -496,8 +673,8 @@ { \ const struct lrecord_implementation *MCACF_implementation \ = LHEADER_IMPLEMENTATION (MCACF_lheader); \ - if (MCACF_implementation && MCACF_implementation->finalizer) \ - MCACF_implementation->finalizer (ptr, 1); \ + if (MCACF_implementation && MCACF_implementation->disksave) \ + MCACF_implementation->disksave (MCACF_obj); \ } \ } while (0) @@ -645,12 +822,10 @@ doesn't care about the dumper flag and makes use of some of the stuff normally omitted from the "abbreviated" description -- see above. - A memory_description is an array of values. (This is actually - misnamed, in that it does not just describe lrecords, but any - blocks of memory.) The first value of each line is a type, the - second the offset in the lrecord structure. The third and - following elements are parameters; their presence, type and number - is type-dependent. + A memory_description is an array of values. The first value of each + line is a type, the second the offset in the lrecord structure. The + third and following elements are parameters; their presence, type and + number is type-dependent. The description ends with an "XD_END" record. @@ -754,7 +929,7 @@ struct Lisp_Hash_Table { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Elemcount size; Elemcount count; Elemcount rehash_count; @@ -819,7 +994,7 @@ struct Lisp_Specifier { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; struct specifier_methods *methods; ... @@ -844,17 +1019,28 @@ XD_LISP_OBJECT - A Lisp object. This is also the type to use for pointers to other lrecords + A Lisp_Object. This is also the type to use for pointers to other lrecords (e.g. struct frame *). XD_LISP_OBJECT_ARRAY - An array of Lisp objects or (equivalently) pointers to lrecords. + An array of Lisp_Objects or (equivalently) pointers to lrecords. The parameter (i.e. third element) is the count. This would be declared as Lisp_Object foo[666]. For something declared as Lisp_Object *foo, use XD_BLOCK_PTR, whose description parameter is a sized_memory_description consisting of only XD_LISP_OBJECT and XD_END. + XD_INLINE_LISP_OBJECT_BLOCK_PTR + + An pointer to a contiguous block of inline Lisp objects -- i.e., the Lisp + object itself rather than a Lisp_Object pointer is stored in the block. + This is used only under NEW_GC and is useful for increased efficiency when + an array of the same kind of object is needed. Examples of the use of this + type are Lisp dynarrs, where the array elements are inline Lisp objects + rather than non-Lisp structures, as is normally the case; and hash tables, + where the key/value pairs are encapsulated as hash-table-entry objects and + an array of inline hash-table-entry objects is stored. + XD_LO_LINK Weak link in a linked list of objects of the same type. This is a @@ -1020,7 +1206,7 @@ XD_LISP_OBJECT_ARRAY, XD_LISP_OBJECT, #ifdef NEW_GC - XD_LISP_OBJECT_BLOCK_PTR, + XD_INLINE_LISP_OBJECT_BLOCK_PTR, #endif /* NEW_GC */ XD_LO_LINK, XD_OPAQUE_PTR, @@ -1070,10 +1256,9 @@ lcrecord-lists, where the objects have had their type changed to lrecord_type_free and also have had their free bit set, but we mark them as normal. */ - XD_FLAG_FREE_LISP_OBJECT = 8 + XD_FLAG_FREE_LISP_OBJECT = 8, #endif /* not NEW_GC */ #if 0 - , /* Suggestions for other possible flags: */ /* Eliminate XD_UNION_DYNAMIC_SIZE and replace it with a flag, like this. */ @@ -1085,7 +1270,7 @@ expanded and we need to stick a pointer in the second slot (although we could still ensure that the second slot in the first entry was NULL or <0). */ - XD_FLAG_DESCRIPTION_MAP = 32 + XD_FLAG_DESCRIPTION_MAP = 32, #endif }; @@ -1128,20 +1313,20 @@ This function must put a pointer to the opaque result in *data and its size in *size. */ - void (*convert)(const void *object, void **data, Bytecount *size); + void (*convert) (const void *object, void **data, Bytecount *size); /* Post-conversion cleanup. Optional (null if not provided). When provided it will be called post-dumping to free any storage allocated for the conversion results. */ - void (*convert_free)(const void *object, void *data, Bytecount size); + void (*convert_free) (const void *object, void *data, Bytecount size); /* De-conversion. At reload time, rebuilds the object from the converted form. "object" is 0 for the PTR case, return is ignored in the DATA case. */ - void *(*deconvert)(void *object, void *data, Bytecount size); + void *(*deconvert) (void *object, void *data, Bytecount size); }; @@ -1153,133 +1338,257 @@ #define XD_INDIRECT_VAL(code) ((-1 - (code)) & 255) #define XD_INDIRECT_DELTA(code) ((-1 - (code)) >> 8) -/* DEFINE_LRECORD_IMPLEMENTATION is for objects with constant size. - DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION is for objects whose size varies. +/* DEFINE_*_LISP_OBJECT is for objects with constant size. (Either + DEFINE_DUMPABLE_LISP_OBJECT for objects that can be saved in a dumped + executable, or DEFINE_NODUMP_LISP_OBJECT for objects that cannot be + saved -- e.g. that contain pointers to non-persistent external objects + such as window-system windows.) + + DEFINE_*_SIZABLE_LISP_OBJECT is for objects whose size varies. + + DEFINE_*_FROB_BLOCK_LISP_OBJECT is for objects that are allocated in + large blocks ("frob blocks"), which are parceled up individually. Such + objects need special handling in alloc.c. This does not apply to + NEW_GC, because it does this automatically. + + DEFINE_*_INTERNAL_LISP_OBJECT is for "internal" objects that should + never be visible on the Lisp level. This is a shorthand for the most + common type of internal objects, which have no equal or hash method + (since they generally won't appear in hash tables), no finalizer and + internal_object_printer() as their print method (which prints that the + object is internal and shouldn't be visible externally). For internal + objects needing a finalizer, equal or hash method, or wanting to + customize the print method, use the normal DEFINE_*_LISP_OBJECT + mechanism for defining these objects. + + DEFINE_MODULE_* is for objects defined in an external module. + + MAKE_LISP_OBJECT and MAKE_MODULE_LISP_OBJECT are what underlies all of + these; they define a structure containing pointers to object methods + and other info such as the size of the structure containing the object. */ +/* #### FIXME What's going on here? */ #if defined (ERROR_CHECK_TYPES) # define DECLARE_ERROR_CHECK_TYPES(c_name, structtype) #else # define DECLARE_ERROR_CHECK_TYPES(c_name, structtype) #endif +/********* The dumpable versions *********** */ -#define DEFINE_BASIC_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,structtype) \ -DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype) +#define DEFINE_DUMPABLE_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \ +MAKE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,sizeof (structtype),0,0,structtype) + +#define DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,0,sizer,0,structtype) -#define DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \ -MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof(structtype),0,1,structtype) +#define DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \ +MAKE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,sizeof(structtype),0,1,structtype) + +#define DEFINE_DUMPABLE_FROB_BLOCK_SIZABLE_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,0,sizer,1,structtype) -#define DEFINE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,structtype) \ -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype) +#define DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT(name,c_name,marker,desc,structtype) \ +DEFINE_DUMPABLE_LISP_OBJECT(name,c_name,marker,internal_object_printer,0,0,0,desc,structtype) + +#define DEFINE_DUMPABLE_SIZABLE_INTERNAL_LISP_OBJECT(name,c_name,marker,desc,sizer,structtype) \ +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT(name,c_name,marker,internal_object_printer,0,0,0,desc,sizer,structtype) -#define DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \ -MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof (structtype),0,0,structtype) +/********* The non-dumpable versions *********** */ + +#define DEFINE_NODUMP_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \ +MAKE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer,nuker,equal,hash,desc,sizeof (structtype),0,0,structtype) -#define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,sizer,structtype) +#define DEFINE_NODUMP_SIZABLE_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer,nuker,equal,hash,desc,0,sizer,0,structtype) + +#define DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,structtype) \ +MAKE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer,nuker,equal,hash,desc,sizeof(structtype),0,1,structtype) -#define DEFINE_BASIC_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ -MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,0,sizer,1,structtype) +#define DEFINE_NODUMP_FROB_BLOCK_SIZABLE_LISP_OBJECT(name,c_name,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer,nuker,equal,hash,desc,0,sizer,1,structtype) -#define DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizer,structtype) \ -MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,0,sizer,0,structtype) +#define DEFINE_NODUMP_INTERNAL_LISP_OBJECT(name,c_name,marker,desc,structtype) \ +DEFINE_NODUMP_LISP_OBJECT(name,c_name,marker,internal_object_printer,0,0,0,desc,structtype) + +#define DEFINE_NODUMP_SIZABLE_INTERNAL_LISP_OBJECT(name,c_name,marker,desc,sizer,structtype) \ +DEFINE_NODUMP_SIZABLE_LISP_OBJECT(name,c_name,marker,internal_object_printer,0,0,0,desc,sizer,structtype) + +/********* MAKE_LISP_OBJECT, the underlying macro *********** */ #ifdef NEW_GC -#define MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \ +#define MAKE_LISP_OBJECT(name,c_name,dumpable,marker,printer,nuker, \ +equal,hash,desc,size,sizer,frob_block_p,structtype) \ DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ -const struct lrecord_implementation lrecord_##c_name = \ +struct lrecord_implementation lrecord_##c_name = \ { name, dumpable, marker, printer, nuker, equal, hash, desc, \ - getprop, putprop, remprop, plist, size, sizer, \ - lrecord_type_##c_name } + size, sizer, lrecord_type_##c_name } #else /* not NEW_GC */ -#define MAKE_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \ +#define MAKE_LISP_OBJECT(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,size,sizer,frob_block_p,structtype) \ DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ -const struct lrecord_implementation lrecord_##c_name = \ +struct lrecord_implementation lrecord_##c_name = \ { name, dumpable, marker, printer, nuker, equal, hash, desc, \ - getprop, putprop, remprop, plist, size, sizer, \ - lrecord_type_##c_name, basic_p } + size, sizer, lrecord_type_##c_name, frob_block_p } #endif /* not NEW_GC */ -#define DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,structtype) \ -DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,structtype) + +/********* The module dumpable versions *********** */ -#define DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,structtype) \ -MAKE_EXTERNAL_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizeof (structtype),0,0,structtype) +#define DEFINE_DUMPABLE_MODULE_LISP_OBJECT(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,structtype) \ +MAKE_MODULE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,sizeof (structtype),0,0,structtype) + +#define DEFINE_DUMPABLE_MODULE_SIZABLE_LISP_OBJECT(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_MODULE_LISP_OBJECT(name,c_name,1 /*dumpable*/,marker,printer,nuker,equal,hash,desc,0,sizer,0,structtype) + +/********* The module non-dumpable versions *********** */ -#define DEFINE_EXTERNAL_LRECORD_SEQUENCE_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,sizer,structtype) \ -DEFINE_EXTERNAL_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,0,0,0,0,sizer,structtype) +#define DEFINE_NODUMP_MODULE_LISP_OBJECT(name,c_name,dumpable,marker, \ +printer,nuker,equal,hash,desc,structtype) \ +MAKE_MODULE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer, \ +nuker,equal,hash,desc,sizeof (structtype),0,0,structtype) -#define DEFINE_EXTERNAL_LRECORD_SEQUENCE_IMPLEMENTATION_WITH_PROPS(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,sizer,structtype) \ -MAKE_EXTERNAL_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,0,sizer,0,structtype) +#define DEFINE_NODUMP_MODULE_SIZABLE_LISP_OBJECT(name,c_name,dumpable, \ +marker,printer,nuker,equal,hash,desc,sizer,structtype) \ +MAKE_MODULE_LISP_OBJECT(name,c_name,0 /*non-dumpable*/,marker,printer, \ +nuker,equal,hash,desc,0,sizer,0,structtype) + +/********* MAKE_MODULE_LISP_OBJECT, the underlying macro *********** */ #ifdef NEW_GC -#define MAKE_EXTERNAL_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \ +#define MAKE_MODULE_LISP_OBJECT(name,c_name,dumpable,marker,printer, \ +nuker,equal,hash,desc,size,sizer,frob_block_p,structtype) \ DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ int lrecord_type_##c_name; \ struct lrecord_implementation lrecord_##c_name = \ { name, dumpable, marker, printer, nuker, equal, hash, desc, \ - getprop, putprop, remprop, plist, size, sizer, \ - lrecord_type_last_built_in_type } + size, sizer, lrecord_type_last_built_in_type } #else /* not NEW_GC */ -#define MAKE_EXTERNAL_LRECORD_IMPLEMENTATION(name,c_name,dumpable,marker,printer,nuker,equal,hash,desc,getprop,putprop,remprop,plist,size,sizer,basic_p,structtype) \ +#define MAKE_MODULE_LISP_OBJECT(name,c_name,dumpable,marker,printer, \ +nuker,equal,hash,desc,size,sizer,frob_block_p,structtype) \ DECLARE_ERROR_CHECK_TYPES(c_name, structtype) \ int lrecord_type_##c_name; \ struct lrecord_implementation lrecord_##c_name = \ { name, dumpable, marker, printer, nuker, equal, hash, desc, \ - getprop, putprop, remprop, plist, size, sizer, \ - lrecord_type_last_built_in_type, basic_p } + size, sizer, lrecord_type_last_built_in_type, frob_block_p } #endif /* not NEW_GC */ +#ifdef MEMORY_USAGE_STATS +#define INIT_MEMORY_USAGE_STATS(type) \ +do \ +{ \ + lrecord_implementations_table[lrecord_type_##type]-> \ + memusage_stats_list = Qnil; \ + lrecord_implementations_table[lrecord_type_##type]-> \ + num_extra_memusage_stats = -1; \ + lrecord_implementations_table[lrecord_type_##type]-> \ + num_extra_nonlisp_memusage_stats = -1; \ + staticpro (&lrecord_implementations_table[lrecord_type_##type]-> \ + memusage_stats_list); \ +} while (0) +#else +#define INIT_MEMORY_USAGE_STATS(type) DO_NOTHING +#endif /* (not) MEMORY_USAGE_STATS */ + +#define INIT_LISP_OBJECT_BEGINNING(type) \ +do \ +{ \ + lrecord_implementations_table[lrecord_type_##type] = &lrecord_##type; \ + INIT_MEMORY_USAGE_STATS (type); \ +} while (0) + #ifdef USE_KKCC extern MODULE_API const struct memory_description *lrecord_memory_descriptions[]; -#define INIT_LRECORD_IMPLEMENTATION(type) do { \ - lrecord_implementations_table[lrecord_type_##type] = &lrecord_##type; \ +#define INIT_LISP_OBJECT(type) do { \ + INIT_LISP_OBJECT_BEGINNING (type); \ lrecord_memory_descriptions[lrecord_type_##type] = \ lrecord_implementations_table[lrecord_type_##type]->description; \ } while (0) #else /* not USE_KKCC */ extern MODULE_API Lisp_Object (*lrecord_markers[]) (Lisp_Object); -#define INIT_LRECORD_IMPLEMENTATION(type) do { \ - lrecord_implementations_table[lrecord_type_##type] = &lrecord_##type; \ - lrecord_markers[lrecord_type_##type] = \ - lrecord_implementations_table[lrecord_type_##type]->marker; \ +#define INIT_LISP_OBJECT(type) do { \ + INIT_LISP_OBJECT_BEGINNING (type); \ + lrecord_markers[lrecord_type_##type] = \ + lrecord_implementations_table[lrecord_type_##type]->marker; \ } while (0) #endif /* not USE_KKCC */ -#define INIT_EXTERNAL_LRECORD_IMPLEMENTATION(type) do { \ - lrecord_type_##type = lrecord_type_count++; \ - lrecord_##type.lrecord_type_index = lrecord_type_##type; \ - INIT_LRECORD_IMPLEMENTATION(type); \ +#define INIT_MODULE_LISP_OBJECT(type) do { \ + lrecord_type_##type = lrecord_type_count++; \ + lrecord_##type.lrecord_type_index = lrecord_type_##type; \ + INIT_LISP_OBJECT (type); \ } while (0) #ifdef HAVE_SHLIB /* Allow undefining types in order to support module unloading. */ #ifdef USE_KKCC -#define UNDEF_LRECORD_IMPLEMENTATION(type) do { \ - lrecord_implementations_table[lrecord_type_##type] = NULL; \ - lrecord_memory_descriptions[lrecord_type_##type] = NULL; \ +#define UNDEF_LISP_OBJECT(type) do { \ + lrecord_implementations_table[lrecord_type_##type] = NULL; \ + lrecord_memory_descriptions[lrecord_type_##type] = NULL; \ } while (0) #else /* not USE_KKCC */ -#define UNDEF_LRECORD_IMPLEMENTATION(type) do { \ - lrecord_implementations_table[lrecord_type_##type] = NULL; \ - lrecord_markers[lrecord_type_##type] = NULL; \ +#define UNDEF_LISP_OBJECT(type) do { \ + lrecord_implementations_table[lrecord_type_##type] = NULL; \ + lrecord_markers[lrecord_type_##type] = NULL; \ } while (0) #endif /* not USE_KKCC */ -#define UNDEF_EXTERNAL_LRECORD_IMPLEMENTATION(type) do { \ +#define UNDEF_MODULE_LISP_OBJECT(type) do { \ if (lrecord_##type.lrecord_type_index == lrecord_type_count - 1) { \ /* This is the most recently defined type. Clean up nicely. */ \ lrecord_type_##type = lrecord_type_count--; \ } /* Else we can't help leaving a hole with this implementation. */ \ - UNDEF_LRECORD_IMPLEMENTATION(type); \ + UNDEF_LISP_OBJECT(type); \ } while (0) #endif /* HAVE_SHLIB */ +/*************** Macros for declaring that a Lisp object has a + particular method, or for calling such a method. ********/ + +/* Declare that object-type TYPE has method M; used in + initialization routines */ +#define OBJECT_HAS_METHOD(type, m) \ + (lrecord_##type.m = type##_##m) +/* Same but the method name come before the type */ +#define OBJECT_HAS_PREMETHOD(type, m) \ + (lrecord_##type.m = m##_##type) +/* Same but the name of the method is explicitly given */ +#define OBJECT_HAS_NAMED_METHOD(type, m, func) \ + (lrecord_##type.m = (func)) +/* Object type has a property with the given value. */ +#define OBJECT_HAS_PROPERTY(type, prop, val) \ + (lrecord_##type.prop = (val)) + +/* Does the given object method exist? */ +#define HAS_OBJECT_METH_P(obj, m) \ + (!!(XRECORD_LHEADER_IMPLEMENTATION (obj)->m)) +/* Call an object method. */ +#define OBJECT_METH(obj, m, args) \ + ((XRECORD_LHEADER_IMPLEMENTATION (obj)->m) args) + +/* Call an object method, if it exists. */ +#define MAYBE_OBJECT_METH(obj, m, args) \ +do \ +{ \ + const struct lrecord_implementation *_mom_imp = \ + XRECORD_LHEADER_IMPLEMENTATION (obj); \ + if (_mom_imp->m) \ + ((_mom_imp->m) args); \ +} while (0) + +/* Call an object method, if it exists, or return GIVEN. NOTE: + Multiply-evaluates OBJ. */ +#define OBJECT_METH_OR_GIVEN(obj, m, args, given) \ + (HAS_OBJECT_METH_P (obj, m) ? OBJECT_METH (obj, m, args) : (given)) + +#define OBJECT_PROPERTY(obj, prop) (XRECORD_LHEADER_IMPLEMENTATION (obj)->prop) + +/************** Other stuff **************/ + #define LRECORDP(a) (XTYPE (a) == Lisp_Type_Record) #define XRECORD_LHEADER(a) ((struct lrecord_header *) XPNTR (a)) @@ -1291,9 +1600,9 @@ 1. Declare the struct for your object in a header file somewhere. Remember that it must begin with - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; - 2. Put the "standard junk" (DECLARE_RECORD()/XFOO/etc.) below the + 2. Put the "standard junk" (DECLARE_LISP_OBJECT()/XFOO/etc.) below the struct definition -- see below. 3. Add this header file to inline.c. @@ -1306,12 +1615,17 @@ describing the purpose of the descriptions; and comments elsewhere in this file describing the exact syntax of the description structures. - 6. Define your object with DEFINE_LRECORD_IMPLEMENTATION() or some - variant. + 6. Define your object with DEFINE_*_LISP_OBJECT() or some + variant. At the minimum, you need to decide whether your object can + be dumped. Objects that are created as part of the loadup process and + need to be persistent across dumping should be created dumpable. + Nondumpable objects are generally those associated with display, + particularly those containing a pointer to an external library object + (e.g. a window-system window). 7. Include the header file in the .c file where you defined the object. - 8. Put a call to INIT_LRECORD_IMPLEMENTATION() for the object in the + 8. Put a call to INIT_LISP_OBJECT() for the object in the .c file's syms_of_foo() function. 9. Add a type enum for the object to enum lrecord_type, earlier in this @@ -1319,132 +1633,165 @@ --ben -An example: + An example: ------------------------------ in toolbar.h ----------------------------- -struct toolbar_button -{ - struct LCRECORD_HEADER header; - - Lisp_Object next; - Lisp_Object frame; - - Lisp_Object up_glyph; - Lisp_Object down_glyph; - Lisp_Object disabled_glyph; - - Lisp_Object cap_up_glyph; - Lisp_Object cap_down_glyph; - Lisp_Object cap_disabled_glyph; - - Lisp_Object callback; - Lisp_Object enabled_p; - Lisp_Object help_string; - - char enabled; - char down; - char pushright; - char blank; - - int x, y; - int width, height; - int dirty; - int vertical; - int border_width; -}; - -[[ the standard junk: ]] - -DECLARE_LRECORD (toolbar_button, struct toolbar_button); -#define XTOOLBAR_BUTTON(x) XRECORD (x, toolbar_button, struct toolbar_button) -#define wrap_toolbar_button(p) wrap_record (p, toolbar_button) -#define TOOLBAR_BUTTONP(x) RECORDP (x, toolbar_button) -#define CHECK_TOOLBAR_BUTTON(x) CHECK_RECORD (x, toolbar_button) -#define CONCHECK_TOOLBAR_BUTTON(x) CONCHECK_RECORD (x, toolbar_button) - + struct toolbar_button + { + NORMAL_LISP_OBJECT_HEADER header; + + Lisp_Object next; + Lisp_Object frame; + + Lisp_Object up_glyph; + Lisp_Object down_glyph; + Lisp_Object disabled_glyph; + + Lisp_Object cap_up_glyph; + Lisp_Object cap_down_glyph; + Lisp_Object cap_disabled_glyph; + + Lisp_Object callback; + Lisp_Object enabled_p; + Lisp_Object help_string; + + char enabled; + char down; + char pushright; + char blank; + + int x, y; + int width, height; + int dirty; + int vertical; + int border_width; + }; + + [[ the standard junk: ]] + + DECLARE_LISP_OBJECT (toolbar_button, struct toolbar_button); + #define XTOOLBAR_BUTTON(x) XRECORD (x, toolbar_button, struct toolbar_button) + #define wrap_toolbar_button(p) wrap_record (p, toolbar_button) + #define TOOLBAR_BUTTONP(x) RECORDP (x, toolbar_button) + #define CHECK_TOOLBAR_BUTTON(x) CHECK_RECORD (x, toolbar_button) + #define CONCHECK_TOOLBAR_BUTTON(x) CONCHECK_RECORD (x, toolbar_button) + ------------------------------ in toolbar.c ----------------------------- - -#include "toolbar.h" - -... + + #include "toolbar.h" + + ... + + static const struct memory_description toolbar_button_description [] = { + { XD_LISP_OBJECT, offsetof (struct toolbar_button, next) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, frame) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, up_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, down_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, disabled_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_up_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_down_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_disabled_glyph) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, callback) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, enabled_p) }, + { XD_LISP_OBJECT, offsetof (struct toolbar_button, help_string) }, + { XD_END } + }; + + static Lisp_Object + allocate_toolbar_button (struct frame *f, int pushright) + { + struct toolbar_button *tb; + + tb = XTOOLBAR_BUTTON (ALLOC_NORMAL_LISP_OBJECT (toolbar_button)); + tb->next = Qnil; + tb->frame = wrap_frame (f); + tb->up_glyph = Qnil; + tb->down_glyph = Qnil; + tb->disabled_glyph = Qnil; + tb->cap_up_glyph = Qnil; + tb->cap_down_glyph = Qnil; + tb->cap_disabled_glyph = Qnil; + tb->callback = Qnil; + tb->enabled_p = Qnil; + tb->help_string = Qnil; + + tb->pushright = pushright; + tb->x = tb->y = tb->width = tb->height = -1; + tb->dirty = 1; + + return wrap_toolbar_button (tb); + } + + static Lisp_Object + mark_toolbar_button (Lisp_Object obj) + { + struct toolbar_button *data = XTOOLBAR_BUTTON (obj); + mark_object (data->next); + mark_object (data->frame); + mark_object (data->up_glyph); + mark_object (data->down_glyph); + mark_object (data->disabled_glyph); + mark_object (data->cap_up_glyph); + mark_object (data->cap_down_glyph); + mark_object (data->cap_disabled_glyph); + mark_object (data->callback); + mark_object (data->enabled_p); + return data->help_string; + } + + DEFINE_NODUMP_LISP_OBJECT ("toolbar-button", toolbar_button, + mark_toolbar_button, + external_object_printer, 0, 0, 0, + toolbar_button_description, + struct toolbar_button); + + ... + + void + syms_of_toolbar (void) + { + INIT_LISP_OBJECT (toolbar_button); + + ...; + } + +------------------------------ in inline.c ----------------------------- + + #ifdef HAVE_TOOLBARS + #include "toolbar.h" + #endif + +------------------------------ in lrecord.h ----------------------------- + + enum lrecord_type + { + ... + lrecord_type_toolbar_button, + ... + }; -static const struct memory_description toolbar_button_description [] = { - { XD_LISP_OBJECT, offsetof (struct toolbar_button, next) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, frame) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, up_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, down_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, disabled_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_up_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_down_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, cap_disabled_glyph) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, callback) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, enabled_p) }, - { XD_LISP_OBJECT, offsetof (struct toolbar_button, help_string) }, - { XD_END } -}; - -static Lisp_Object -mark_toolbar_button (Lisp_Object obj) -\{ - struct toolbar_button *data = XTOOLBAR_BUTTON (obj); - mark_object (data->next); - mark_object (data->frame); - mark_object (data->up_glyph); - mark_object (data->down_glyph); - mark_object (data->disabled_glyph); - mark_object (data->cap_up_glyph); - mark_object (data->cap_down_glyph); - mark_object (data->cap_disabled_glyph); - mark_object (data->callback); - mark_object (data->enabled_p); - return data->help_string; -} +------------------------------ in .gdbinit.in.in ----------------------------- -[[ If your object should never escape to Lisp, declare its print method - as internal_object_printer instead of 0. ]] - -DEFINE_LRECORD_IMPLEMENTATION ("toolbar-button", toolbar_button, - 0, mark_toolbar_button, 0, 0, 0, 0, - toolbar_button_description, - struct toolbar_button); - -... - -void -syms_of_toolbar (void) -{ - INIT_LRECORD_IMPLEMENTATION (toolbar_button); - - ...; -} + ... + else + if $lrecord_type == lrecord_type_toolbar_button + pstructtype toolbar_button + ... + ... + ... + end ------------------------------- in inline.c ----------------------------- - -#ifdef HAVE_TOOLBARS -#include "toolbar.h" -#endif - ------------------------------- in lrecord.h ----------------------------- - -enum lrecord_type -{ - ... - lrecord_type_toolbar_button, - ... -}; - - ---ben + --ben */ /* Note: Object types defined in external dynamically-loaded modules (not -part of the XEmacs main source code) should use DECLARE_EXTERNAL_LRECORD -and DEFINE_EXTERNAL_LRECORD_IMPLEMENTATION rather than DECLARE_LRECORD -and DEFINE_LRECORD_IMPLEMENTATION. The EXTERNAL versions declare and +part of the XEmacs main source code) should use DECLARE_*_MODULE_LISP_OBJECT +and DEFINE_*_MODULE_LISP_OBJECT rather than DECLARE_*_LISP_OBJECT +and DEFINE_*_LISP_OBJECT. The MODULE versions declare and allocate an enumerator for the type being defined. */ @@ -1452,58 +1799,45 @@ #ifdef ERROR_CHECK_TYPES -# define DECLARE_LRECORD(c_name, structtype) \ -extern const struct lrecord_implementation lrecord_##c_name; \ -DECLARE_INLINE_HEADER ( \ -structtype * \ -error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ -) \ -{ \ +# define DECLARE_LISP_OBJECT(c_name, structtype) \ +extern struct lrecord_implementation lrecord_##c_name; \ +DECLARE_INLINE_HEADER ( \ +structtype * \ +error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ +) \ +{ \ assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ - return (structtype *) XPNTR (obj); \ -} \ + return (structtype *) XPNTR (obj); \ +} \ extern Lisp_Object Q##c_name##p -# define DECLARE_MODULE_API_LRECORD(c_name, structtype) \ -extern MODULE_API const struct lrecord_implementation lrecord_##c_name; \ -DECLARE_INLINE_HEADER ( \ -structtype * \ -error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ -) \ -{ \ - assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ - return (structtype *) XPNTR (obj); \ -} \ -extern MODULE_API Lisp_Object Q##c_name##p - -# define DECLARE_EXTERNAL_LRECORD(c_name, structtype) \ -extern int lrecord_type_##c_name; \ -extern struct lrecord_implementation lrecord_##c_name; \ -DECLARE_INLINE_HEADER ( \ -structtype * \ -error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ -) \ -{ \ - assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ - return (structtype *) XPNTR (obj); \ -} \ -extern Lisp_Object Q##c_name##p - -# define DECLARE_NONRECORD(c_name, type_enum, structtype) \ +# define DECLARE_MODULE_API_LISP_OBJECT(c_name, structtype) \ +extern MODULE_API struct lrecord_implementation lrecord_##c_name; \ DECLARE_INLINE_HEADER ( \ structtype * \ error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ ) \ { \ - assert_at_line (XTYPE (obj) == type_enum, file, line); \ + assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ + return (structtype *) XPNTR (obj); \ +} \ +extern MODULE_API Lisp_Object Q##c_name##p + +# define DECLARE_MODULE_LISP_OBJECT(c_name, structtype) \ +extern int lrecord_type_##c_name; \ +extern struct lrecord_implementation lrecord_##c_name; \ +DECLARE_INLINE_HEADER ( \ +structtype * \ +error_check_##c_name (Lisp_Object obj, const Ascbyte *file, int line) \ +) \ +{ \ + assert_at_line (RECORD_TYPEP (obj, lrecord_type_##c_name), file, line); \ return (structtype *) XPNTR (obj); \ } \ extern Lisp_Object Q##c_name##p # define XRECORD(x, c_name, structtype) \ error_check_##c_name (x, __FILE__, __LINE__) -# define XNONRECORD(x, c_name, type_enum, structtype) \ - error_check_##c_name (x, __FILE__, __LINE__) DECLARE_INLINE_HEADER ( Lisp_Object @@ -1522,21 +1856,17 @@ #else /* not ERROR_CHECK_TYPES */ -# define DECLARE_LRECORD(c_name, structtype) \ +# define DECLARE_LISP_OBJECT(c_name, structtype) \ extern Lisp_Object Q##c_name##p; \ -extern const struct lrecord_implementation lrecord_##c_name -# define DECLARE_MODULE_API_LRECORD(c_name, structtype) \ -extern MODULE_API Lisp_Object Q##c_name##p; \ -extern MODULE_API const struct lrecord_implementation lrecord_##c_name -# define DECLARE_EXTERNAL_LRECORD(c_name, structtype) \ +extern struct lrecord_implementation lrecord_##c_name +# define DECLARE_MODULE_API_LISP_OBJECT(c_name, structtype) \ +extern MODULE_API Lisp_Object Q##c_name##p; \ +extern MODULE_API struct lrecord_implementation lrecord_##c_name +# define DECLARE_MODULE_LISP_OBJECT(c_name, structtype) \ extern Lisp_Object Q##c_name##p; \ extern int lrecord_type_##c_name; \ extern struct lrecord_implementation lrecord_##c_name -# define DECLARE_NONRECORD(c_name, type_enum, structtype) \ -extern Lisp_Object Q##c_name##p # define XRECORD(x, c_name, structtype) ((structtype *) XPNTR (x)) -# define XNONRECORD(x, c_name, type_enum, structtype) \ - ((structtype *) XPNTR (x)) /* wrap_pointer_1 is so named as a suggestion not to use it unless you know what you're doing. */ #define wrap_record(ptr, ty) wrap_pointer_1 (ptr) @@ -1590,13 +1920,13 @@ struct lcrecord_list { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object free; Elemcount size; const struct lrecord_implementation *implementation; }; -DECLARE_LRECORD (lcrecord_list, struct lcrecord_list); +DECLARE_LISP_OBJECT (lcrecord_list, struct lcrecord_list); #define XLCRECORD_LIST(x) XRECORD (x, lcrecord_list, struct lcrecord_list) #define wrap_lcrecord_list(p) wrap_record (p, lcrecord_list) #define LCRECORD_LISTP(x) RECORDP (x, lcrecord_list) @@ -1611,13 +1941,13 @@ lrecords. lcrecords themselves are divided into three types: (1) auto-managed, (2) hand-managed, and (3) unmanaged. "Managed" refers to using a special object called an lcrecord-list to keep track of freed - lcrecords, which can freed with FREE_LCRECORD() or the like and later be - recycled when a new lcrecord is required, rather than requiring new - malloc(). Thus, allocation of lcrecords can be very + lcrecords, which can freed with free_normal_lisp_object() or the like + and later be recycled when a new lcrecord is required, rather than + requiring new malloc(). Thus, allocation of lcrecords can be very cheap. (Technically, the lcrecord-list manager could divide up large chunks of memory and allocate out of that, mimicking what happens with lrecords. At that point, however, we'd want to rethink the whole - division between lrecords and lcrecords.) + division between lrecords and lcrecords.) NOTE: There is a fundamental limitation of lcrecord-lists, which is that they only handle blocks of a particular, fixed size. Thus, objects that @@ -1625,9 +1955,9 @@ in particular dictate the various types of management: -- "Auto-managed" means that you just go ahead and allocate the lcrecord - whenever you want, using old_alloc_lcrecord_type(), and the appropriate + whenever you want, using ALLOC_NORMAL_LISP_OBJECT(), and the appropriate lcrecord-list manager is automatically created. To free, you just call - "FREE_LCRECORD()" and the appropriate lcrecord-list manager is + "free_normal_lisp_object()" and the appropriate lcrecord-list manager is automatically located and called. The limitation here of course is that all your objects are of the same size. (#### Eventually we should have a more sophisticated system that tracks the sizes seen and creates one @@ -1648,7 +1978,7 @@ to hand-manage them, or (b) the objects you create are always or almost always Lisp-visible, and thus there's no point in freeing them (and it wouldn't be safe to do so). You just create them with - BASIC_ALLOC_LCRECORD(), and that's it. + ALLOC_SIZED_LISP_OBJECT(), and that's it. --ben @@ -1661,10 +1991,10 @@ 1) Create an lcrecord-list object using make_lcrecord_list(). This is often done at initialization. Remember to staticpro_nodump() this object! The arguments to make_lcrecord_list() are the same as would be - passed to BASIC_ALLOC_LCRECORD(). + passed to ALLOC_SIZED_LISP_OBJECT(). - 2) Instead of calling BASIC_ALLOC_LCRECORD(), call alloc_managed_lcrecord() - and pass the lcrecord-list earlier created. + 2) Instead of calling ALLOC_SIZED_LISP_OBJECT(), call + alloc_managed_lcrecord() and pass the lcrecord-list earlier created. 3) When done with the lcrecord, call free_managed_lcrecord(). The standard freeing caveats apply: ** make sure there are no pointers to @@ -1674,7 +2004,7 @@ lcrecord goodbye as if it were garbage-collected. This means: -- the contents of the freed lcrecord are undefined, and the contents of something produced by alloc_managed_lcrecord() - are undefined, just like for BASIC_ALLOC_LCRECORD(). + are undefined, just like for ALLOC_SIZED_LISP_OBJECT(). -- the mark method for the lcrecord's type will *NEVER* be called on freed lcrecords. -- the finalize method for the lcrecord's type will be called @@ -1682,8 +2012,9 @@ */ /* UNMANAGED MODEL: */ -void *old_basic_alloc_lcrecord (Bytecount size, - const struct lrecord_implementation *); +Lisp_Object old_alloc_lcrecord (const struct lrecord_implementation *); +Lisp_Object old_alloc_sized_lcrecord (Bytecount size, + const struct lrecord_implementation *); /* HAND-MANAGED MODEL: */ Lisp_Object make_lcrecord_list (Elemcount size, @@ -1693,85 +2024,34 @@ void free_managed_lcrecord (Lisp_Object lcrecord_list, Lisp_Object lcrecord); /* AUTO-MANAGED MODEL: */ -MODULE_API void * -alloc_automanaged_lcrecord (Bytecount size, - const struct lrecord_implementation *); +MODULE_API Lisp_Object +alloc_automanaged_sized_lcrecord (Bytecount size, + const struct lrecord_implementation *imp); +MODULE_API Lisp_Object +alloc_automanaged_lcrecord (const struct lrecord_implementation *imp); -#define old_alloc_lcrecord_type(type, lrecord_implementation) \ - ((type *) alloc_automanaged_lcrecord (sizeof (type), lrecord_implementation)) +#define old_alloc_lcrecord_type(type, imp) \ + ((type *) XPNTR (alloc_automanaged_lcrecord (sizeof (type), imp))) void old_free_lcrecord (Lisp_Object rec); - -/* Copy the data from one lcrecord structure into another, but don't - overwrite the header information. */ - -#define old_copy_sized_lcrecord(dst, src, size) \ - memcpy ((Rawbyte *) (dst) + sizeof (struct old_lcrecord_header), \ - (Rawbyte *) (src) + sizeof (struct old_lcrecord_header), \ - (size) - sizeof (struct old_lcrecord_header)) - -#define old_copy_lcrecord(dst, src) \ - old_copy_sized_lcrecord (dst, src, sizeof (*(dst))) - -#define old_zero_sized_lcrecord(lcr, size) \ - memset ((Rawbyte *) (lcr) + sizeof (struct old_lcrecord_header), 0, \ - (size) - sizeof (struct old_lcrecord_header)) - -#define old_zero_lcrecord(lcr) old_zero_sized_lcrecord (lcr, sizeof (*(lcr))) - #else /* NEW_GC */ -/* How to allocate a lrecord: - - - If the size of the lrecord is fix, say it equals its size of its - struct, then use alloc_lrecord_type. - - - If the size varies, i.e. it is not equal to the size of its - struct, use alloc_lrecord and specify the amount of storage you - need for the object. - - - Some lrecords, which are used totally internally, use the - noseeum-* functions for the reason of debugging. - - - To free a Lisp_Object manually, use free_lrecord. */ - -void *alloc_lrecord (Bytecount size, - const struct lrecord_implementation *); - -void *alloc_lrecord_array (Bytecount size, int elemcount, - const struct lrecord_implementation *); +MODULE_API Lisp_Object alloc_sized_lrecord (Bytecount size, + const struct lrecord_implementation *imp); +Lisp_Object noseeum_alloc_sized_lrecord (Bytecount size, + const struct lrecord_implementation *imp); +MODULE_API Lisp_Object alloc_lrecord (const struct lrecord_implementation *imp); +Lisp_Object noseeum_alloc_lrecord (const struct lrecord_implementation *imp); -#define alloc_lrecord_type(type, lrecord_implementation) \ - ((type *) alloc_lrecord (sizeof (type), lrecord_implementation)) - -void *noseeum_alloc_lrecord (Bytecount size, - const struct lrecord_implementation *); - -#define noseeum_alloc_lrecord_type(type, lrecord_implementation) \ - ((type *) noseeum_alloc_lrecord (sizeof (type), lrecord_implementation)) - -void free_lrecord (Lisp_Object rec); - - -/* Copy the data from one lrecord structure into another, but don't - overwrite the header information. */ - -#define copy_sized_lrecord(dst, src, size) \ - memcpy ((char *) (dst) + sizeof (struct lrecord_header), \ - (char *) (src) + sizeof (struct lrecord_header), \ - (size) - sizeof (struct lrecord_header)) - -#define copy_lrecord(dst, src) copy_sized_lrecord (dst, src, sizeof (*(dst))) +MODULE_API Lisp_Object alloc_lrecord_array (int elemcount, + const struct lrecord_implementation *imp); +MODULE_API Lisp_Object alloc_sized_lrecord_array (Bytecount size, + int elemcount, + const struct lrecord_implementation *imp); #endif /* NEW_GC */ -#define zero_sized_lrecord(lcr, size) \ - memset ((char *) (lcr) + sizeof (struct lrecord_header), 0, \ - (size) - sizeof (struct lrecord_header)) - -#define zero_lrecord(lcr) zero_sized_lrecord (lcr, sizeof (*(lcr))) - DECLARE_INLINE_HEADER ( Bytecount detagged_lisp_object_size (const struct lrecord_header *h) @@ -1780,7 +2060,7 @@ const struct lrecord_implementation *imp = LHEADER_IMPLEMENTATION (h); return (imp->size_in_bytes_method ? - imp->size_in_bytes_method (h) : + imp->size_in_bytes_method (wrap_pointer_1 (h)) : imp->static_size); } @@ -1792,6 +2072,21 @@ return detagged_lisp_object_size (XRECORD_LHEADER (o)); } +struct usage_stats; + +MODULE_API void copy_lisp_object (Lisp_Object dst, Lisp_Object src); +MODULE_API void zero_sized_lisp_object (Lisp_Object obj, Bytecount size); +MODULE_API void zero_nonsized_lisp_object (Lisp_Object obj); +Bytecount lisp_object_storage_size (Lisp_Object obj, + struct usage_stats *ustats); +Bytecount lisp_object_memory_usage_full (Lisp_Object object, + Bytecount *storage_size, + Bytecount *extra_nonlisp_storage, + Bytecount *extra_lisp_storage, + struct generic_usage_stats *stats); +Bytecount lisp_object_memory_usage (Lisp_Object object); +void free_normal_lisp_object (Lisp_Object obj); + /************************************************************************/ /* Dumping */
--- a/src/lstream.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/lstream.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Generic stream implementation. Copyright (C) 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1996, 2001, 2002 Ben Wing. + Copyright (C) 1996, 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -64,42 +64,36 @@ Lstream *lstr = XLSTREAM (obj); write_fmt_string (printcharfun, - "#<INTERNAL OBJECT (XEmacs bug?) (%s lstream) 0x%lx>", - lstr->imp->name, (long) lstr); + "#<INTERNAL OBJECT (XEmacs bug?) (%s lstream) 0x%x>", + lstr->imp->name, LISP_OBJECT_UID (obj)); } static void -finalize_lstream (void *header, int for_disksave) +finalize_lstream (Lisp_Object obj) { /* WARNING WARNING WARNING. This function (and all finalize functions) - may get called more than once on the same object, and may get called - (at dump time) on objects that are not being released. */ - Lstream *lstr = (Lstream *) header; + may get called more than once on the same object. */ + Lstream *lstr = XLSTREAM (obj); + + if (lstr->flags & LSTREAM_FL_IS_OPEN) + Lstream_close (lstr); + + if (lstr->imp->finalizer) + (lstr->imp->finalizer) (lstr); +} + +static void +disksave_lstream (Lisp_Object lstream) +{ + Lstream *lstr = XLSTREAM (lstream); #if 0 /* this may cause weird Broken Pipes? */ - if (for_disksave) - { - Lstream_pseudo_close (lstr); - return; - } + Lstream_pseudo_close (lstr); + return; #endif - if (lstr->flags & LSTREAM_FL_IS_OPEN) - { - if (for_disksave) - { - if (lstr->flags & LSTREAM_FL_CLOSE_AT_DISKSAVE) - Lstream_close (lstr); - } - else - /* Just close. */ - Lstream_close (lstr); - } - - if (!for_disksave) - { - if (lstr->imp->finalizer) - (lstr->imp->finalizer) (lstr); - } + if ((lstr->flags & LSTREAM_FL_IS_OPEN) && + (lstr->flags & LSTREAM_FL_CLOSE_AT_DISKSAVE)) + Lstream_close (lstr); } inline static Bytecount @@ -110,9 +104,9 @@ } static Bytecount -sizeof_lstream (const void *header) +sizeof_lstream (Lisp_Object obj) { - return aligned_sizeof_lstream (((const Lstream *) header)->imp->size); + return aligned_sizeof_lstream (XLSTREAM (obj)->imp->size); } static const struct memory_description lstream_implementation_description_1[] @@ -150,12 +144,12 @@ 0, lstream_empty_extra_description_1 }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("stream", lstream, - 0, /*dumpable-flag*/ - mark_lstream, print_lstream, - finalize_lstream, 0, 0, - lstream_description, - sizeof_lstream, Lstream); +DEFINE_NODUMP_SIZABLE_LISP_OBJECT ("stream", lstream, + mark_lstream, print_lstream, + finalize_lstream, + 0, 0, /* no equal or hash */ + lstream_description, + sizeof_lstream, Lstream); /* Change the buffering of a stream. See lstream.h. By default the @@ -197,9 +191,8 @@ { Lstream *p; #ifdef NEW_GC - p = XLSTREAM (wrap_pointer_1 - (alloc_lrecord (aligned_sizeof_lstream (imp->size), - &lrecord_lstream))); + p = XLSTREAM (ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_lstream (imp->size), + lstream)); #else /* not NEW_GC */ int i; @@ -221,9 +214,10 @@ p = XLSTREAM (alloc_managed_lcrecord (Vlstream_free_list[i])); #endif /* not NEW_GC */ - /* Zero it out, except the header. */ - memset ((char *) p + sizeof (p->header), '\0', - aligned_sizeof_lstream (imp->size) - sizeof (p->header)); + /* Formerly, we zeroed out the object minus its header, but it's now + handled automatically. ALLOC_SIZED_LISP_OBJECT() always zeroes out + the whole object other than its header, and alloc_managed_lcrecord() + does the same. */ p->imp = imp; Lstream_set_buffering (p, LSTREAM_BLOCK_BUFFERED, 0); p->flags = LSTREAM_FL_IS_OPEN; @@ -302,7 +296,7 @@ Lisp_Object val = wrap_lstream (lstr); #ifdef NEW_GC - free_lrecord (val); + free_normal_lisp_object (val); #else /* not NEW_GC */ for (i = 0; i < lstream_type_count; i++) { @@ -1826,6 +1820,18 @@ /************************************************************************/ void +syms_of_lstream (void) +{ + INIT_LISP_OBJECT (lstream); +} + +void +lstream_objects_create (void) +{ + OBJECT_HAS_PREMETHOD (lstream, disksave); +} + +void lstream_type_create (void) { LSTREAM_HAS_METHOD (stdio, reader); @@ -1881,5 +1887,4 @@ void vars_of_lstream (void) { - INIT_LRECORD_IMPLEMENTATION (lstream); }
--- a/src/lstream.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/lstream.h Mon Mar 29 21:28:13 2010 -0500 @@ -30,7 +30,7 @@ /* definition of Lstream object */ /************************************************************************/ -DECLARE_LRECORD (lstream, struct lstream); +DECLARE_LISP_OBJECT (lstream, struct lstream); #define XLSTREAM(x) XRECORD (x, lstream, struct lstream) #define wrap_lstream(p) wrap_record (p, lstream) #define LSTREAMP(x) RECORDP (x, lstream) @@ -230,7 +230,7 @@ struct lstream { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; const Lstream_implementation *imp; /* methods for this stream */ Lstream_buffering buffering; /* type of buffering in use */ Bytecount buffering_size; /* number of bytes buffered */
--- a/src/marker.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/marker.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Markers: examining, setting and killing. Copyright (C) 1985, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. - Copyright (C) 2002 Ben Wing. + Copyright (C) 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -60,7 +60,7 @@ Lisp_Marker *marker = XMARKER (obj); if (print_readably) - printing_unreadable_object ("#<marker 0x%lx>", (long) marker); + printing_unreadable_object_fmt ("#<marker 0x%x>", LISP_OBJECT_UID (obj)); write_ascstring (printcharfun, GETTEXT ("#<marker ")); if (!marker->buffer) @@ -73,7 +73,7 @@ } if (marker->insertion_type) write_ascstring (printcharfun, " insertion-type=t"); - write_fmt_string (printcharfun, " 0x%lx>", (long) marker); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static int @@ -107,28 +107,17 @@ #ifdef NEW_GC static void -finalize_marker (void *header, int for_disksave) +finalize_marker (Lisp_Object obj) { - if (!for_disksave) - { - Lisp_Object tem = wrap_marker (header); - unchain_marker (tem); - } + unchain_marker (obj); } +#endif /* NEW_GC */ -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("marker", marker, - 1, /*dumpable-flag*/ - mark_marker, print_marker, - finalize_marker, - marker_equal, marker_hash, - marker_description, Lisp_Marker); -#else /* not NEW_GC */ -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("marker", marker, - 1, /*dumpable-flag*/ - mark_marker, print_marker, 0, - marker_equal, marker_hash, - marker_description, Lisp_Marker); -#endif /* not NEW_GC */ +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("marker", marker, + mark_marker, print_marker, + IF_NEW_GC (finalize_marker), + marker_equal, marker_hash, + marker_description, Lisp_Marker); /* Operations on markers. */ @@ -503,25 +492,15 @@ #ifdef MEMORY_USAGE_STATS -int -compute_buffer_marker_usage (struct buffer *b, struct overhead_stats *ovstats) +Bytecount +compute_buffer_marker_usage (struct buffer *b) { Lisp_Marker *m; - int total = 0; - int overhead; + Bytecount total = 0; for (m = BUF_MARKERS (b); m; m = m->next) - total += sizeof (Lisp_Marker); - ovstats->was_requested += total; -#ifdef NEW_GC - overhead = mc_alloced_storage_size (total, 0); -#else /* not NEW_GC */ - overhead = fixed_type_block_overhead (total); -#endif /* not NEW_GC */ - /* #### claiming this is all malloc overhead is not really right, - but it has to go somewhere. */ - ovstats->malloc_overhead += overhead; - return total + overhead; + total += lisp_object_memory_usage (wrap_marker (m)); + return total; } #endif /* MEMORY_USAGE_STATS */ @@ -530,7 +509,7 @@ void syms_of_marker (void) { - INIT_LRECORD_IMPLEMENTATION (marker); + INIT_LISP_OBJECT (marker); DEFSUBR (Fmarker_position); DEFSUBR (Fmarker_buffer);
--- a/src/mc-alloc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/mc-alloc.c Mon Mar 29 21:28:13 2010 -0500 @@ -417,20 +417,6 @@ /*--- misc functions ---------------------------------------------------*/ -/* moved here from alloc.c */ -#ifdef ERROR_CHECK_GC -static void -deadbeef_memory (void *ptr, Bytecount size) -{ - UINT_32_BIT *ptr4 = (UINT_32_BIT *) ptr; - Bytecount beefs = size >> 2; - - /* In practice, size will always be a multiple of four. */ - while (beefs--) - (*ptr4++) = 0xDEADBEEF; /* -559038737 base 10 */ -} -#endif /* ERROR_CHECK_GC */ - /* Visits all pages (page_headers) hooked into the used heap pages list and executes f with the current page header as argument. Needed for sweep. Returns number of processed pages. */ @@ -976,9 +962,8 @@ } -#ifdef MEMORY_USAGE_STATS Bytecount -mc_alloced_storage_size (Bytecount claimed_size, struct overhead_stats *stats) +mc_alloced_storage_size (Bytecount claimed_size, struct usage_stats *stats) { size_t used_size = get_used_list_size_value (get_used_list_index (claimed_size)); @@ -993,7 +978,6 @@ return used_size; } -#endif /* not MEMORY_USAGE_STATS */
--- a/src/mc-alloc.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/mc-alloc.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* New allocator for XEmacs. Copyright (C) 2005 Marcus Crestani. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -122,12 +123,10 @@ /* Functions and macros related with allocation statistics: */ -#ifdef MEMORY_USAGE_STATS /* Returns the real size, including overhead, which is actually alloced for an object with given claimed_size. */ Bytecount mc_alloced_storage_size (Bytecount claimed_size, - struct overhead_stats *stats); -#endif /* MEMORY_USAGE_STATS */ + struct usage_stats *stats); /* Incremental Garbage Collector / Write Barrier Support: */
--- a/src/minibuf.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/minibuf.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Minibuffer input and completion. Copyright (C) 1985, 1986, 1992-1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2002 Ben Wing. + Copyright (C) 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -513,7 +513,7 @@ return Qt; /* Else extract the part in which all completions agree */ - return Fsubstring (bestmatch, Qzero, make_int (bestmatchsize)); + return Fsubseq (bestmatch, Qzero, make_int (bestmatchsize)); } @@ -991,8 +991,10 @@ #endif Vminibuffer_zero = Fget_buffer_create (build_ascstring (" *Minibuf-0*")); + staticpro_nodump (&Vminibuffer_zero); Vecho_area_buffer = Fget_buffer_create (build_ascstring (" *Echo Area*")); + staticpro_nodump (&Vecho_area_buffer); } void
--- a/src/mule-charset.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/mule-charset.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Functions to handle multilingual characters. Copyright (C) 1992, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2001, 2002, 2004, 2005 Ben Wing. + Copyright (C) 2001, 2002, 2004, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -141,7 +141,7 @@ Lisp_Charset *cs = XCHARSET (obj); if (print_readably) - printing_unreadable_lcrecord + printing_unreadable_lisp_object (obj, XSTRING_DATA (XSYMBOL (XCHARSET_NAME (obj))->name)); write_fmt_string_lisp (printcharfun, "#<charset %s %S %S %S", 4, @@ -158,7 +158,7 @@ CHARSET_GRAPHIC (cs), CHARSET_FINAL (cs)); print_internal (CHARSET_REGISTRIES (cs), printcharfun, 0); - write_fmt_string (printcharfun, " 0x%x>", cs->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static const struct memory_description charset_description[] = { @@ -178,10 +178,9 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("charset", charset, - 1, /* dumpable flag */ - mark_charset, print_charset, 0, - 0, 0, charset_description, Lisp_Charset); +DEFINE_DUMPABLE_LISP_OBJECT ("charset", charset, + mark_charset, print_charset, 0, + 0, 0, charset_description, Lisp_Charset); /* Make a new charset. */ /* #### SJT Should generic properties be allowed? */ static Lisp_Object @@ -196,8 +195,8 @@ if (!overwrite) { - cs = ALLOC_LCRECORD_TYPE (Lisp_Charset, &lrecord_charset); - obj = wrap_charset (cs); + obj = ALLOC_NORMAL_LISP_OBJECT (charset); + cs = XCHARSET (obj); if (final) { @@ -991,58 +990,25 @@ struct charset_stats { - int from_unicode; - int to_unicode; - int other; + struct usage_stats u; + Bytecount from_unicode; + Bytecount to_unicode; }; static void compute_charset_usage (Lisp_Object charset, struct charset_stats *stats, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { - struct Lisp_Charset *c = XCHARSET (charset); - xzero (*stats); - stats->other += LISPOBJ_STORAGE_SIZE (c, sizeof (*c), ovstats); - stats->from_unicode += compute_from_unicode_table_size (charset, ovstats); - stats->to_unicode += compute_to_unicode_table_size (charset, ovstats); + stats->from_unicode += compute_from_unicode_table_size (charset, ustats); + stats->to_unicode += compute_to_unicode_table_size (charset, ustats); } -DEFUN ("charset-memory-usage", Fcharset_memory_usage, 1, 1, 0, /* -Return stats about the memory usage of charset CHARSET. -The values returned are in the form of an alist of usage types and -byte counts. The byte counts attempt to encompass all the memory used -by the charset (separate from the memory logically associated with a -charset or frame), including internal structures and any malloc() -overhead associated with them. In practice, the byte counts are -underestimated for various reasons, e.g. because certain memory usage -is very hard to determine \(e.g. the amount of memory used inside the -Xt library or inside the X server). +static void +charset_memory_usage (Lisp_Object charset, struct generic_usage_stats *gustats) +{ + struct charset_stats *stats = (struct charset_stats *) gustats; -Multiple slices of the total memory usage may be returned, separated -by a nil. Each slice represents a particular view of the memory, a -particular way of partitioning it into groups. Within a slice, there -is no overlap between the groups of memory, and each slice collectively -represents all the memory concerned. -*/ - (charset)) -{ - struct charset_stats stats; - struct overhead_stats ovstats; - Lisp_Object val = Qnil; - - charset = Fget_charset (charset); - xzero (ovstats); - compute_charset_usage (charset, &stats, &ovstats); - - val = acons (Qfrom_unicode, make_int (stats.from_unicode), val); - val = acons (Qto_unicode, make_int (stats.to_unicode), val); - val = Fcons (Qnil, val); - val = acons (Qactually_requested, make_int (ovstats.was_requested), val); - val = acons (Qmalloc_overhead, make_int (ovstats.malloc_overhead), val); - val = acons (Qgap_overhead, make_int (ovstats.gap_overhead), val); - val = acons (Qdynarr_overhead, make_int (ovstats.dynarr_overhead), val); - - return Fnreverse (val); + compute_charset_usage (charset, stats, &stats->u); } #endif /* MEMORY_USAGE_STATS */ @@ -1053,9 +1019,17 @@ /************************************************************************/ void +mule_charset_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (charset, memory_usage); +#endif +} + +void syms_of_mule_charset (void) { - INIT_LRECORD_IMPLEMENTATION (charset); + INIT_LISP_OBJECT (charset); DEFSUBR (Fcharsetp); DEFSUBR (Ffind_charset); @@ -1076,10 +1050,6 @@ DEFSUBR (Fset_charset_registries); DEFSUBR (Fcharsets_in_region); -#ifdef MEMORY_USAGE_STATS - DEFSUBR (Fcharset_memory_usage); -#endif - DEFSYMBOL (Qcharsetp); DEFSYMBOL (Qregistries); DEFSYMBOL (Qfinal); @@ -1128,6 +1098,11 @@ { int i, j, k; +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY + (charset, memusage_stats_list, list2 (Qfrom_unicode, Qto_unicode)); +#endif /* MEMORY_USAGE_STATS */ + chlook = xnew_and_zero (struct charset_lookup); /* zero for Purify. */ dump_add_root_block_ptr (&chlook, &charset_lookup_description);
--- a/src/mule-coding.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/mule-coding.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Conversion functions for I18N encodings, but not Unicode (in separate file). Copyright (C) 1991, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -2545,7 +2545,7 @@ if (EQ (charset, Vcharset_control_1)) { if (XCODING_SYSTEM_ISO2022_ESCAPE_QUOTED (codesys) - && fit_to_be_escape_quoted (c)) + && fit_to_be_escape_quoted (c - 0x20)) Dynarr_add (dst, ISO_CODE_ESC); /* you asked for it ... */ Dynarr_add (dst, c - 0x20); @@ -2839,14 +2839,15 @@ return 1; } +#ifdef ENABLE_COMPOSITE_CHARS +#define USED_IF_COMPOSITE_CHARS(x) x +#else +#define USED_IF_COMPOSITE_CHARS(x) UNUSED (x) +#endif + static void -iso2022_finalize_coding_stream ( -#ifdef ENABLE_COMPOSITE_CHARS - struct coding_stream *str -#else - struct coding_stream *UNUSED (str) -#endif - ) +iso2022_finalize_coding_stream (struct coding_stream * + USED_IF_COMPOSITE_CHARS (str)) { #ifdef ENABLE_COMPOSITE_CHARS struct iso2022_coding_stream *data = @@ -3247,7 +3248,10 @@ { struct iso2022_detector *data = DETECTION_STATE_DATA (st, iso2022); if (data->iso) - xfree (data->iso); + { + xfree (data->iso); + data->iso = 0; + } }
--- a/src/native-gtk-toolbar.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/native-gtk-toolbar.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* toolbar implementation -- GTK interface. Copyright (C) 2000 Aaron Lehmann + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -32,29 +33,8 @@ #include "toolbar.h" #include "window.h" -#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ - do { \ - switch (pos) \ - { \ - case TOP_TOOLBAR: \ - (frame)->top_toolbar_was_visible = flag; \ - break; \ - case BOTTOM_TOOLBAR: \ - (frame)->bottom_toolbar_was_visible = flag; \ - break; \ - case LEFT_TOOLBAR: \ - (frame)->left_toolbar_was_visible = flag; \ - break; \ - case RIGHT_TOOLBAR: \ - (frame)->right_toolbar_was_visible = flag; \ - break; \ - default: \ - ABORT (); \ - } \ - } while (0) - static void -gtk_clear_toolbar (struct frame *f, enum toolbar_pos pos); +gtk_clear_toolbar (struct frame *f, enum edge_pos pos); static void gtk_toolbar_callback (GtkWidget *UNUSED (w), gpointer user_data) @@ -66,7 +46,7 @@ static void -gtk_output_toolbar (struct frame *f, enum toolbar_pos pos) +gtk_output_toolbar (struct frame *f, enum edge_pos pos) { GtkWidget *toolbar; Lisp_Object button, window, glyph, instance; @@ -114,7 +94,7 @@ { gtk_clear_toolbar (f, pos); FRAME_GTK_TOOLBAR_WIDGET (f)[pos] = toolbar = - gtk_toolbar_new (((pos == TOP_TOOLBAR) || (pos == BOTTOM_TOOLBAR)) ? + gtk_toolbar_new (((pos == TOP_EDGE) || (pos == BOTTOM_EDGE)) ? GTK_ORIENTATION_HORIZONTAL : GTK_ORIENTATION_VERTICAL, GTK_TOOLBAR_BOTH); } @@ -193,7 +173,7 @@ } static void -gtk_clear_toolbar (struct frame *f, enum toolbar_pos pos) +gtk_clear_toolbar (struct frame *f, enum edge_pos pos) { FRAME_GTK_TOOLBAR_CHECKSUM (f, pos) = 0; SET_TOOLBAR_WAS_VISIBLE_FLAG (f, pos, 0); @@ -204,25 +184,15 @@ static void gtk_output_frame_toolbars (struct frame *f) { - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - gtk_output_toolbar (f, TOP_TOOLBAR); - else if (f->top_toolbar_was_visible) - gtk_clear_toolbar (f, TOP_TOOLBAR); - - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - gtk_output_toolbar (f, BOTTOM_TOOLBAR); - else if (f->bottom_toolbar_was_visible) - gtk_clear_toolbar (f, LEFT_TOOLBAR); + enum edge_pos pos; - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - gtk_output_toolbar (f, LEFT_TOOLBAR); - else if (f->left_toolbar_was_visible) - gtk_clear_toolbar (f, LEFT_TOOLBAR); - - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - gtk_output_toolbar (f, RIGHT_TOOLBAR); - else if (f->right_toolbar_was_visible) - gtk_clear_toolbar (f, RIGHT_TOOLBAR); + EDGE_POS_LOOP (pos) + { + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + gtk_output_toolbar (f, pos); + else if (f->toolbar_was_visible[pos]) + gtk_clear_toolbar (f, pos); + } } static void
--- a/src/number.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/number.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* Numeric types for XEmacs. Copyright (C) 2004 Jerry James. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -60,17 +61,15 @@ #ifdef NEW_GC static void -bignum_finalize (void *header, int for_disksave) +bignum_finalize (Lisp_Object obj) { - if (!for_disksave) - { - struct Lisp_Bignum *num = (struct Lisp_Bignum *) header; - bignum_fini (num->data); - } + struct Lisp_Bignum *num = XBIGNUM (obj); + /* #### WARNING: It would be better to put some sort of check to make + sure this doesn't happen more than once, just in case --- + e.g. checking if it's zero before finalizing and then setting it to + zero after finalizing. */ + bignum_fini (num->data); } -#define BIGNUM_FINALIZE bignum_finalize -#else -#define BIGNUM_FINALIZE 0 #endif static int @@ -122,11 +121,10 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bignum", bignum, 1, 0, bignum_print, - BIGNUM_FINALIZE, bignum_equal, - bignum_hash, bignum_description, - Lisp_Bignum); - +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bignum", bignum, 0, bignum_print, + IF_NEW_GC (bignum_finalize), + bignum_equal, bignum_hash, + bignum_description, Lisp_Bignum); #endif /* HAVE_BIGNUM */ Lisp_Object Qbignump; @@ -153,18 +151,16 @@ #ifdef NEW_GC static void -ratio_finalize (void *header, int for_disksave) +ratio_finalize (Lisp_Object obj) { - if (!for_disksave) - { - struct Lisp_Ratio *num = (struct Lisp_Ratio *) header; - ratio_fini (num->data); - } + struct Lisp_Ratio *num = XRATIO (obj); + /* #### WARNING: It would be better to put some sort of check to make + sure this doesn't happen more than once, just in case --- + e.g. checking if it's zero before finalizing and then setting it to + zero after finalizing. */ + ratio_fini (num->data); } -#define RATIO_FINALIZE ratio_finalize -#else -#define RATIO_FINALIZE 0 -#endif +#endif /* not NEW_GC */ static int ratio_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), @@ -184,9 +180,10 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("ratio", ratio, 0, 0, ratio_print, - RATIO_FINALIZE, ratio_equal, ratio_hash, - ratio_description, Lisp_Ratio); +DEFINE_NODUMP_FROB_BLOCK_LISP_OBJECT ("ratio", ratio, 0, ratio_print, + IF_NEW_GC (ratio_finalize), + ratio_equal, ratio_hash, + ratio_description, Lisp_Ratio); #endif /* HAVE_RATIO */ @@ -258,18 +255,16 @@ #ifdef NEW_GC static void -bigfloat_finalize (void *header, int for_disksave) +bigfloat_finalize (Lisp_Object obj) { - if (!for_disksave) - { - struct Lisp_Bigfloat *num = (struct Lisp_Bigfloat *) header; - bigfloat_fini (num->bf); - } + struct Lisp_Bigfloat *num = XBIGFLOAT (obj); + /* #### WARNING: It would be better to put some sort of check to make + sure this doesn't happen more than once, just in case --- + e.g. checking if it's zero before finalizing and then setting it to + zero after finalizing. */ + bigfloat_fini (num->bf); } -#define BIGFLOAT_FINALIZE bigfloat_finalize -#else -#define BIGFLOAT_FINALIZE 0 -#endif +#endif /* not NEW_GC */ static int bigfloat_equal (Lisp_Object obj1, Lisp_Object obj2, int UNUSED (depth), @@ -289,10 +284,11 @@ { XD_END } }; -DEFINE_BASIC_LRECORD_IMPLEMENTATION ("bigfloat", bigfloat, 1, 0, - bigfloat_print, BIGFLOAT_FINALIZE, - bigfloat_equal, bigfloat_hash, - bigfloat_description, Lisp_Bigfloat); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("bigfloat", bigfloat, 0, + bigfloat_print, + IF_NEW_GC (bigfloat_finalize), + bigfloat_equal, bigfloat_hash, + bigfloat_description, Lisp_Bigfloat); #endif /* HAVE_BIGFLOAT */ @@ -762,13 +758,13 @@ syms_of_number (void) { #ifdef HAVE_BIGNUM - INIT_LRECORD_IMPLEMENTATION (bignum); + INIT_LISP_OBJECT (bignum); #endif #ifdef HAVE_RATIO - INIT_LRECORD_IMPLEMENTATION (ratio); + INIT_LISP_OBJECT (ratio); #endif #ifdef HAVE_BIGFLOAT - INIT_LRECORD_IMPLEMENTATION (bigfloat); + INIT_LISP_OBJECT (bigfloat); #endif /* Type predicates */
--- a/src/number.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/number.h Mon Mar 29 21:28:13 2010 -0500 @@ -71,12 +71,12 @@ struct Lisp_Bignum { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; bignum data; }; typedef struct Lisp_Bignum Lisp_Bignum; -DECLARE_LRECORD (bignum, Lisp_Bignum); +DECLARE_LISP_OBJECT (bignum, Lisp_Bignum); #define XBIGNUM(x) XRECORD (x, bignum, Lisp_Bignum) #define wrap_bignum(p) wrap_record (p, bignum) #define BIGNUMP(x) RECORDP (x, bignum) @@ -159,12 +159,12 @@ struct Lisp_Ratio { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; ratio data; }; typedef struct Lisp_Ratio Lisp_Ratio; -DECLARE_LRECORD (ratio, Lisp_Ratio); +DECLARE_LISP_OBJECT (ratio, Lisp_Ratio); #define XRATIO(x) XRECORD (x, ratio, Lisp_Ratio) #define wrap_ratio(p) wrap_record (p, ratio) #define RATIOP(x) RECORDP (x, ratio) @@ -233,12 +233,12 @@ #ifdef HAVE_BIGFLOAT struct Lisp_Bigfloat { - struct lrecord_header lheader; + FROB_BLOCK_LISP_OBJECT_HEADER lheader; bigfloat bf; }; typedef struct Lisp_Bigfloat Lisp_Bigfloat; -DECLARE_LRECORD (bigfloat, Lisp_Bigfloat); +DECLARE_LISP_OBJECT (bigfloat, Lisp_Bigfloat); #define XBIGFLOAT(x) XRECORD (x, bigfloat, Lisp_Bigfloat) #define wrap_bigfloat(p) wrap_record (p, bigfloat) #define BIGFLOATP(x) RECORDP (x, bigfloat)
--- a/src/opaque.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/opaque.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Opaque Lisp objects. Copyright (C) 1993, 1994, 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 1996, 2002 Ben Wing. + Copyright (C) 1995, 1996, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -51,8 +51,8 @@ write_fmt_string (printcharfun, - "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%lx>", - (long)(p->size), (unsigned long) p); + "#<INTERNAL OBJECT (XEmacs bug?) (opaque, size=%lu) 0x%x>", + (long)(p->size), LISP_OBJECT_UID (obj)); } inline static Bytecount @@ -62,9 +62,9 @@ } static Bytecount -sizeof_opaque (const void *header) +sizeof_opaque (Lisp_Object obj) { - return aligned_sizeof_opaque (((const Lisp_Opaque *) header)->size); + return aligned_sizeof_opaque (XOPAQUE (obj)->size); } /* Return an opaque object of size SIZE. @@ -74,8 +74,9 @@ Lisp_Object make_opaque (const void *data, Bytecount size) { - Lisp_Opaque *p = (Lisp_Opaque *) - BASIC_ALLOC_LCRECORD (aligned_sizeof_opaque (size), &lrecord_opaque); + Lisp_Object obj = + ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_opaque (size), opaque); + Lisp_Opaque *p = XOPAQUE (obj); p->size = size; if (data == OPAQUE_CLEAR) @@ -85,9 +86,7 @@ else memcpy (p->data, data, size); - { - return wrap_opaque (p); - } + return obj; } /* This will not work correctly for opaques with subobjects! */ @@ -116,12 +115,11 @@ { XD_END } }; -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("opaque", opaque, - 1, /*dumpable-flag*/ - 0, print_opaque, 0, - equal_opaque, hash_opaque, - opaque_description, - sizeof_opaque, Lisp_Opaque); +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("opaque", opaque, + 0, print_opaque, 0, + equal_opaque, hash_opaque, + opaque_description, + sizeof_opaque, Lisp_Opaque); /* stuff to handle opaque pointers */ @@ -134,8 +132,8 @@ write_fmt_string (printcharfun, - "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%lx>", - (long)(p->ptr), (unsigned long) p); + "#<INTERNAL OBJECT (XEmacs bug?) (opaque-ptr, adr=0x%lx) 0x%x>", + (long)(p->ptr), LISP_OBJECT_UID (obj)); } static int @@ -155,19 +153,16 @@ { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("opaque-ptr", opaque_ptr, - 0, /*dumpable-flag*/ - 0, print_opaque_ptr, 0, - equal_opaque_ptr, hash_opaque_ptr, - opaque_ptr_description, Lisp_Opaque_Ptr); +DEFINE_NODUMP_LISP_OBJECT ("opaque-ptr", opaque_ptr, + 0, print_opaque_ptr, 0, + equal_opaque_ptr, hash_opaque_ptr, + opaque_ptr_description, Lisp_Opaque_Ptr); Lisp_Object make_opaque_ptr (void *val) { #ifdef NEW_GC - Lisp_Object res = - wrap_pointer_1 (alloc_lrecord_type (Lisp_Opaque_Ptr, - &lrecord_opaque_ptr)); + Lisp_Object res = ALLOC_NORMAL_LISP_OBJECT (opaque_ptr); #else /* not NEW_GC */ Lisp_Object res = alloc_managed_lcrecord (Vopaque_ptr_free_list); #endif /* not NEW_GC */ @@ -182,7 +177,7 @@ free_opaque_ptr (Lisp_Object ptr) { #ifdef NEW_GC - free_lrecord (ptr); + free_normal_lisp_object (ptr); #else /* not NEW_GC */ free_managed_lcrecord (Vopaque_ptr_free_list, ptr); #endif /* not NEW_GC */ @@ -201,8 +196,8 @@ void init_opaque_once_early (void) { - INIT_LRECORD_IMPLEMENTATION (opaque); - INIT_LRECORD_IMPLEMENTATION (opaque_ptr); + INIT_LISP_OBJECT (opaque); + INIT_LISP_OBJECT (opaque_ptr); #ifndef NEW_GC reinit_opaque_early ();
--- a/src/opaque.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/opaque.h Mon Mar 29 21:28:13 2010 -0500 @@ -28,12 +28,12 @@ typedef struct Lisp_Opaque { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Bytecount size; max_align_t data[1]; } Lisp_Opaque; -DECLARE_LRECORD (opaque, Lisp_Opaque); +DECLARE_LISP_OBJECT (opaque, Lisp_Opaque); #define XOPAQUE(x) XRECORD (x, opaque, Lisp_Opaque) #define wrap_opaque(p) wrap_record (p, opaque) #define OPAQUEP(x) RECORDP (x, opaque) @@ -54,11 +54,11 @@ typedef struct Lisp_Opaque_Ptr { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; void *ptr; } Lisp_Opaque_Ptr; -DECLARE_LRECORD (opaque_ptr, Lisp_Opaque_Ptr); +DECLARE_LISP_OBJECT (opaque_ptr, Lisp_Opaque_Ptr); #define XOPAQUE_PTR(x) XRECORD (x, opaque_ptr, Lisp_Opaque_Ptr) #define wrap_opaque_ptr(p) wrap_record (p, opaque_ptr) #define OPAQUE_PTRP(x) RECORDP (x, opaque_ptr)
--- a/src/print.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/print.c Mon Mar 29 21:28:13 2010 -0500 @@ -1415,7 +1415,7 @@ if (EQ (obj, tortoise) && len > 0) { if (print_readably) - printing_unreadable_object ("circular list"); + printing_unreadable_object_fmt ("circular list"); else write_ascstring (printcharfun, "... <circular list>"); break; @@ -1523,7 +1523,7 @@ } DOESNT_RETURN -printing_unreadable_object (const Ascbyte *fmt, ...) +printing_unreadable_object_fmt (const Ascbyte *fmt, ...) { Lisp_Object obj; va_list args; @@ -1537,70 +1537,48 @@ } DOESNT_RETURN -printing_unreadable_lcrecord (Lisp_Object obj, const Ibyte *name) +printing_unreadable_lisp_object (Lisp_Object obj, const Ibyte *name) { - struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); - -#ifndef NEW_GC - /* This must be a real lcrecord */ - assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p); -#endif + struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); if (name) - printing_unreadable_object - ("#<%s %s 0x%x>", -#ifdef NEW_GC - LHEADER_IMPLEMENTATION (header)->name, -#else /* not NEW_GC */ - LHEADER_IMPLEMENTATION (&header->lheader)->name, -#endif /* not NEW_GC */ - name, - header->uid); + printing_unreadable_object_fmt ("#<%s %s 0x%x>", imp->name, name, header->uid); else - printing_unreadable_object - ("#<%s 0x%x>", -#ifdef NEW_GC - LHEADER_IMPLEMENTATION (header)->name, -#else /* not NEW_GC */ - LHEADER_IMPLEMENTATION (&header->lheader)->name, -#endif /* not NEW_GC */ - header->uid); + printing_unreadable_object_fmt ("#<%s 0x%x>", imp->name, header->uid); } void -default_object_printer (Lisp_Object obj, Lisp_Object printcharfun, - int UNUSED (escapeflag)) +external_object_printer (Lisp_Object obj, Lisp_Object printcharfun, + int UNUSED (escapeflag)) { - struct LCRECORD_HEADER *header = (struct LCRECORD_HEADER *) XPNTR (obj); - -#ifndef NEW_GC - /* This must be a real lcrecord */ - assert (!LHEADER_IMPLEMENTATION (&header->lheader)->basic_p); -#endif + struct lrecord_header *header = (struct lrecord_header *) XPNTR (obj); + const struct lrecord_implementation *imp = + XRECORD_LHEADER_IMPLEMENTATION (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); - write_fmt_string (printcharfun, "#<%s 0x%x>", -#ifdef NEW_GC - LHEADER_IMPLEMENTATION (header)->name, -#else /* not NEW_GC */ - LHEADER_IMPLEMENTATION (&header->lheader)->name, -#endif /* not NEW_GC */ - header->uid); + write_fmt_string (printcharfun, "#<%s 0x%x>", imp->name, header->uid); } void internal_object_printer (Lisp_Object obj, Lisp_Object printcharfun, int UNUSED (escapeflag)) { + if (print_readably) + printing_unreadable_object_fmt + ("#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%x>", + XRECORD_LHEADER_IMPLEMENTATION (obj)->name, LISP_OBJECT_UID (obj)); + /* Internal objects shouldn't normally escape to the Lisp level; that's why we say "XEmacs bug?". This can happen, however, when printing backtraces. */ write_fmt_string (printcharfun, - "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%lx>", + "#<INTERNAL OBJECT (XEmacs bug?) (%s) 0x%x>", XRECORD_LHEADER_IMPLEMENTATION (obj)->name, - (unsigned long) XPNTR (obj)); + LISP_OBJECT_UID (obj)); } enum printing_badness @@ -1935,11 +1913,13 @@ } } - if (LHEADER_IMPLEMENTATION (lheader)->printer) - ((LHEADER_IMPLEMENTATION (lheader)->printer) - (obj, printcharfun, escapeflag)); - else - internal_object_printer (obj, printcharfun, escapeflag); + /* Either use a custom-written printer, or use + internal_object_printer or external_object_printer, depending on + whether the object is internal (not visible at Lisp level) or + external. */ + assert (LHEADER_IMPLEMENTATION (lheader)->printer); + ((LHEADER_IMPLEMENTATION (lheader)->printer) + (obj, printcharfun, escapeflag)); break; } @@ -2437,19 +2417,10 @@ debug_out ("<< bad object type=%d 0x%lx>>", header->type, (EMACS_INT) header); else -#ifdef NEW_GC debug_out ("#<%s addr=0x%lx uid=0x%lx>", LHEADER_IMPLEMENTATION (header)->name, (EMACS_INT) header, (EMACS_INT) ((struct lrecord_header *) header)->uid); -#else /* not NEW_GC */ - debug_out ("#<%s addr=0x%lx uid=0x%lx>", - LHEADER_IMPLEMENTATION (header)->name, - (EMACS_INT) header, - (EMACS_INT) (LHEADER_IMPLEMENTATION (header)->basic_p ? - ((struct lrecord_header *) header)->uid : - ((struct old_lcrecord_header *) header)->uid)); -#endif /* not NEW_GC */ } }
--- a/src/process-nt.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/process-nt.c Mon Mar 29 21:28:13 2010 -0500 @@ -656,9 +656,8 @@ } static void -nt_finalize_process_data (Lisp_Process *p, int for_disksave) +nt_finalize_process_data (Lisp_Process *p) { - assert (!for_disksave); /* If it's still in the list of processes we are waiting on delete it. This can happen if we forcibly delete a process and are unable to kill it. */ @@ -1159,7 +1158,7 @@ of handles when lots of processes are run. (The handle gets closed anyway upon GC, but that might be a ways away, esp. if deleted-exited-processes is set to nil.) */ - nt_finalize_process_data (p, 0); + nt_finalize_process_data (p); } /*
--- a/src/process.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/process.c Mon Mar 29 21:28:13 2010 -0500 @@ -2,7 +2,7 @@ Copyright (C) 1985, 1986, 1987, 1988, 1992, 1993, 1994, 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 1996, 2001, 2002, 2004, 2005 Ben Wing. + Copyright (C) 1995, 1996, 2001, 2002, 2004, 2005, 2010 Ben Wing. This file is part of XEmacs. @@ -150,7 +150,7 @@ Lisp_Process *process = XPROCESS (obj); if (print_readably) - printing_unreadable_lcrecord (obj, XSTRING_DATA (process->name)); + printing_unreadable_lisp_object (obj, XSTRING_DATA (process->name)); if (!escapeflag) { @@ -176,30 +176,26 @@ #endif /* HAVE_WINDOW_SYSTEM */ static void -finalize_process (void *header, int for_disksave) +finalize_process (Lisp_Object obj) { /* #### this probably needs to be tied into the tty event loop */ /* #### when there is one */ - Lisp_Process *p = (Lisp_Process *) header; + Lisp_Process *p = XPROCESS (obj); #ifdef HAVE_WINDOW_SYSTEM - if (!for_disksave) - { - debug_process_finalization (p); - } + debug_process_finalization (p); #endif /* HAVE_WINDOW_SYSTEM */ if (p->process_data) { - MAYBE_PROCMETH (finalize_process_data, (p, for_disksave)); - if (!for_disksave) - xfree (p->process_data); + MAYBE_PROCMETH (finalize_process_data, (p)); + xfree (p->process_data); + p->process_data = 0; } } -DEFINE_LRECORD_IMPLEMENTATION ("process", process, - 0, /*dumpable-flag*/ - mark_process, print_process, finalize_process, - 0, 0, process_description, Lisp_Process); +DEFINE_NODUMP_LISP_OBJECT ("process", process, + mark_process, print_process, finalize_process, + 0, 0, process_description, Lisp_Process); /************************************************************************/ /* basic process accessors */ @@ -468,9 +464,10 @@ Lisp_Object make_process_internal (Lisp_Object name) { - Lisp_Object val, name1; + Lisp_Object name1; int i; - Lisp_Process *p = ALLOC_LCRECORD_TYPE (Lisp_Process, &lrecord_process); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (process); + Lisp_Process *p = XPROCESS (obj); #define MARKED_SLOT(x) p->x = Qnil; #include "process-slots.h" @@ -495,10 +492,8 @@ MAYBE_PROCMETH (alloc_process_data, (p)); - val = wrap_process (p); - - Vprocess_list = Fcons (val, Vprocess_list); - return val; + Vprocess_list = Fcons (obj, Vprocess_list); + return obj; } void @@ -2491,7 +2486,7 @@ void syms_of_process (void) { - INIT_LRECORD_IMPLEMENTATION (process); + INIT_LISP_OBJECT (process); DEFSYMBOL (Qprocessp); DEFSYMBOL (Qprocess_live_p);
--- a/src/process.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/process.h Mon Mar 29 21:28:13 2010 -0500 @@ -27,7 +27,7 @@ /* struct Lisp_Process is defined in procimpl.h; only process-*.c need to know about the guts of it. */ -DECLARE_LRECORD (process, Lisp_Process); +DECLARE_LISP_OBJECT (process, Lisp_Process); #define XPROCESS(x) XRECORD (x, process, Lisp_Process) #define wrap_process(p) wrap_record (p, process) #define PROCESSP(x) RECORDP (x, process)
--- a/src/procimpl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/procimpl.h Mon Mar 29 21:28:13 2010 -0500 @@ -39,7 +39,7 @@ struct process_methods { void (*print_process_data) (Lisp_Process *proc, Lisp_Object printcharfun); - void (*finalize_process_data) (Lisp_Process *proc, int for_disksave); + void (*finalize_process_data) (Lisp_Process *proc); void (*alloc_process_data) (Lisp_Process *p); void (*init_process_io_handles) (Lisp_Process *p, void* in, void* out, void *err, int flags); @@ -94,7 +94,7 @@ struct Lisp_Process { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Exit code if process has terminated, signal which stopped/interrupted process
--- a/src/profile.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/profile.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,5 @@ /* Why the hell is XEmacs so fucking slow? - Copyright (C) 1996, 2002, 2003, 2004 Ben Wing. + Copyright (C) 1996, 2002, 2003, 2004, 2010 Ben Wing. Copyright (C) 1998 Free Software Foundation, Inc. This file is part of XEmacs. @@ -25,6 +25,7 @@ #include "backtrace.h" #include "bytecode.h" #include "elhash.h" +#include "gc.h" #include "hash.h" #include "profile.h" @@ -609,7 +610,7 @@ void *UNUSED (void_closure)) { #ifdef USE_KKCC - kkcc_gc_stack_push_lisp_object (GET_LISP_FROM_VOID (void_key), 0, -1); + kkcc_gc_stack_push_lisp_object_0 (GET_LISP_FROM_VOID (void_key)); #else /* NOT USE_KKCC */ mark_object (GET_LISP_FROM_VOID (void_key)); #endif /* NOT USE_KKCC */
--- a/src/rangetab.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/rangetab.c Mon Mar 29 21:28:13 2010 -0500 @@ -90,8 +90,8 @@ Lisp_Range_Table *rt = XRANGE_TABLE (obj); int i; - for (i = 0; i < Dynarr_length (rt->entries); i++) - mark_object (Dynarr_at (rt->entries, i).val); + for (i = 0; i < gap_array_length (rt->entries); i++) + mark_object (rangetab_gap_array_at (rt->entries, i).val); return Qnil; } @@ -108,9 +108,9 @@ 1, range_table_type_to_symbol (rt->type)); else write_ascstring (printcharfun, "#<range-table "); - for (i = 0; i < Dynarr_length (rt->entries); i++) + for (i = 0; i < gap_array_length (rt->entries); i++) { - struct range_table_entry *rte = Dynarr_atp (rt->entries, i); + struct range_table_entry rte = rangetab_gap_array_at (rt->entries, i); int so, ec; if (i > 0) write_ascstring (printcharfun, " "); @@ -124,16 +124,16 @@ } write_fmt_string (printcharfun, "%c%ld %ld%c ", print_readably ? '(' : so ? '(' : '[', - (long) (rte->first - so), - (long) (rte->last - ec), + (long) (rte.first - so), + (long) (rte.last - ec), print_readably ? ')' : ec ? ']' : ')' ); - print_internal (rte->val, printcharfun, 1); + print_internal (rte.val, printcharfun, 1); } if (print_readably) write_ascstring (printcharfun, "))"); else - write_fmt_string (printcharfun, " 0x%x>", rt->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static int @@ -143,13 +143,15 @@ Lisp_Range_Table *rt2 = XRANGE_TABLE (obj2); int i; - if (Dynarr_length (rt1->entries) != Dynarr_length (rt2->entries)) + if (gap_array_length (rt1->entries) != gap_array_length (rt2->entries)) return 0; - for (i = 0; i < Dynarr_length (rt1->entries); i++) + for (i = 0; i < gap_array_length (rt1->entries); i++) { - struct range_table_entry *rte1 = Dynarr_atp (rt1->entries, i); - struct range_table_entry *rte2 = Dynarr_atp (rt2->entries, i); + struct range_table_entry *rte1 = + rangetab_gap_array_atp (rt1->entries, i); + struct range_table_entry *rte2 = + rangetab_gap_array_atp (rt2->entries, i); if (rte1->first != rte2->first || rte1->last != rte2->last @@ -171,7 +173,7 @@ { Lisp_Range_Table *rt = XRANGE_TABLE (obj); int i; - int size = Dynarr_length (rt->entries); + int size = gap_array_length (rt->entries); Hashcode hash = size; /* approach based on internal_array_hash(). */ @@ -179,8 +181,8 @@ { for (i = 0; i < size; i++) hash = HASH2 (hash, - range_table_entry_hash (Dynarr_atp (rt->entries, i), - depth)); + range_table_entry_hash + (rangetab_gap_array_atp (rt->entries, i), depth)); return hash; } @@ -188,12 +190,31 @@ A slightly better approach would be to offset by some noise factor from the points chosen below. */ for (i = 0; i < 5; i++) - hash = HASH2 (hash, range_table_entry_hash (Dynarr_atp (rt->entries, - i*size/5), - depth)); + hash = HASH2 (hash, + range_table_entry_hash + (rangetab_gap_array_atp (rt->entries, i*size/5), depth)); return hash; } +#ifndef NEW_GC + +/* #### This leaks memory under NEW_GC. To fix this, convert to Lisp object + gap array. */ + +static void +finalize_range_table (Lisp_Object obj) +{ + Lisp_Range_Table *rt = XRANGE_TABLE (obj); + if (rt->entries) + { + if (!DUMPEDP (rt->entries)) + free_gap_array (rt->entries); + rt->entries = 0; + } +} + +#endif /* not NEW_GC */ + static const struct memory_description rte_description_1[] = { { XD_LISP_OBJECT, offsetof (range_table_entry, val) }, { XD_END } @@ -204,28 +225,27 @@ rte_description_1 }; -static const struct memory_description rted_description_1[] = { - XD_DYNARR_DESC (range_table_entry_dynarr, &rte_description), +static const struct memory_description rtega_description_1[] = { + XD_GAP_ARRAY_DESC (&rte_description), { XD_END } }; -static const struct sized_memory_description rted_description = { - sizeof (range_table_entry_dynarr), - rted_description_1 +static const struct sized_memory_description rtega_description = { + 0, rtega_description_1 }; static const struct memory_description range_table_description[] = { { XD_BLOCK_PTR, offsetof (Lisp_Range_Table, entries), 1, - { &rted_description } }, + { &rtega_description } }, { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("range-table", range_table, - 1, /*dumpable-flag*/ - mark_range_table, print_range_table, 0, - range_table_equal, range_table_hash, - range_table_description, - Lisp_Range_Table); +DEFINE_DUMPABLE_LISP_OBJECT ("range-table", range_table, + mark_range_table, print_range_table, + IF_OLD_GC (finalize_range_table), + range_table_equal, range_table_hash, + range_table_description, + Lisp_Range_Table); /************************************************************************/ /* Range table operations */ @@ -238,12 +258,12 @@ { int i; - for (i = 0; i < Dynarr_length (rt->entries); i++) + for (i = 0; i < gap_array_length (rt->entries); i++) { - struct range_table_entry *rte = Dynarr_atp (rt->entries, i); + struct range_table_entry *rte = rangetab_gap_array_atp (rt->entries, i); assert (rte->last >= rte->first); if (i > 0) - assert (Dynarr_at (rt->entries, i - 1).last <= rte->first); + assert (rangetab_gap_array_at (rt->entries, i - 1).last <= rte->first); } } @@ -253,14 +273,18 @@ #endif -/* Look up in a range table without the Dynarr wrapper. - Used also by the unified range table format. */ +/* Locate the range table entry corresponding to the value POS, and return + it. If found, FOUNDP is set to 1 and the return value specifies an entry + that encloses POS. Otherwise, FOUNDP is set to 0 and the return value + specifies where an entry that encloses POS would be inserted. */ -static Lisp_Object -get_range_table (EMACS_INT pos, int nentries, struct range_table_entry *tab, - Lisp_Object default_) +static Elemcount +get_range_table_pos (Elemcount pos, Elemcount nentries, + struct range_table_entry *tab, + Elemcount gappos, Elemcount gapsize, + int *foundp) { - int left = 0, right = nentries; + Elemcount left = 0, right = nentries; /* binary search for the entry. Based on similar code in extent_list_locate(). */ @@ -268,14 +292,41 @@ { /* RIGHT might not point to a valid entry (i.e. it's at the end of the list), so NEWPOS must round down. */ - int newpos = (left + right) >> 1; - struct range_table_entry *entry = tab + newpos; + Elemcount newpos = (left + right) >> 1; + struct range_table_entry *entry = + tab + GAP_ARRAY_ARRAY_TO_MEMORY_POS_1 (newpos, gappos, gapsize); if (pos >= entry->last) left = newpos + 1; else if (pos < entry->first) right = newpos; else - return entry->val; + { + *foundp = 1; + return newpos; + } + } + + *foundp = 0; + return left; +} + +/* Look up in a range table without the gap array wrapper. + Used also by the unified range table format. */ + +static Lisp_Object +get_range_table (Elemcount pos, Elemcount nentries, + struct range_table_entry *tab, + Elemcount gappos, Elemcount gapsize, + Lisp_Object default_) +{ + int foundp; + Elemcount entrypos = get_range_table_pos (pos, nentries, tab, gappos, + gapsize, &foundp); + if (foundp) + { + struct range_table_entry *entry = + tab + GAP_ARRAY_ARRAY_TO_MEMORY_POS_1 (entrypos, gappos, gapsize); + return entry->val; } return default_; @@ -332,11 +383,11 @@ */ (type)) { - Lisp_Range_Table *rt = ALLOC_LCRECORD_TYPE (Lisp_Range_Table, - &lrecord_range_table); - rt->entries = Dynarr_new (range_table_entry); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (range_table); + Lisp_Range_Table *rt = XRANGE_TABLE (obj); + rt->entries = make_gap_array (sizeof (struct range_table_entry), 0); rt->type = range_table_symbol_to_type (type); - return wrap_range_table (rt); + return obj; } DEFUN ("copy-range-table", Fcopy_range_table, 1, 1, 0, /* @@ -347,17 +398,22 @@ (range_table)) { Lisp_Range_Table *rt, *rtnew; + Lisp_Object obj; + Elemcount i; CHECK_RANGE_TABLE (range_table); rt = XRANGE_TABLE (range_table); - rtnew = ALLOC_LCRECORD_TYPE (Lisp_Range_Table, &lrecord_range_table); - rtnew->entries = Dynarr_new (range_table_entry); + obj = ALLOC_NORMAL_LISP_OBJECT (range_table); + rtnew = XRANGE_TABLE (obj); + rtnew->entries = make_gap_array (sizeof (struct range_table_entry), 0); rtnew->type = rt->type; - Dynarr_add_many (rtnew->entries, Dynarr_begin (rt->entries), - Dynarr_length (rt->entries)); - return wrap_range_table (rtnew); + for (i = 0; i < gap_array_length (rt->entries); i++) + rtnew->entries = + gap_array_insert_els (rtnew->entries, i, + rangetab_gap_array_atp (rt->entries, i), 1); + return obj; } DEFUN ("get-range-table", Fget_range_table, 2, 3, 0, /* @@ -373,8 +429,12 @@ CHECK_INT_COERCE_CHAR (pos); - return get_range_table (XINT (pos), Dynarr_length (rt->entries), - Dynarr_begin (rt->entries), default_); + return get_range_table (XINT (pos), gap_array_length (rt->entries), + gap_array_begin (rt->entries, + struct range_table_entry), + gap_array_gappos (rt->entries), + gap_array_gapsize (rt->entries), + default_); } static void @@ -414,6 +474,7 @@ int i; int insert_me_here = -1; Lisp_Range_Table *rt = XRANGE_TABLE (table); + int foundp; external_to_internal_adjust_ends (rt->type, &first, &last); if (first == last) @@ -423,15 +484,59 @@ open. #### Should we signal an error? */ return; + if (DUMPEDP (rt->entries)) + rt->entries = gap_array_clone (rt->entries); + + i = get_range_table_pos (first, gap_array_length (rt->entries), + gap_array_begin (rt->entries, + struct range_table_entry), + gap_array_gappos (rt->entries), + gap_array_gapsize (rt->entries), &foundp); + +#ifdef ERROR_CHECK_TYPES + if (foundp) + { + if (i < gap_array_length (rt->entries)) + { + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, i); + assert (first >= entry->first && first < entry->last); + } + } + else + { + if (i < gap_array_length (rt->entries)) + { + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, i); + assert (first < entry->first); + } + if (i > 0) + { + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, i - 1); + assert (first >= entry->last); + } + } +#endif /* ERROR_CHECK_TYPES */ + + /* If the beginning of the new range isn't within any existing range, + it might still be just grazing the end of an end-open range (remember, + internally all ranges are start-close end-open); so back up one + so we consider this range. */ + if (!foundp && i > 0) + i--; + /* Now insert in the proper place. This gets tricky because we may be overlapping one or more existing ranges and need to fix them up. */ /* First delete all sections of any existing ranges that overlap the new range. */ - for (i = 0; i < Dynarr_length (rt->entries); i++) + for (; i < gap_array_length (rt->entries); i++) { - struct range_table_entry *entry = Dynarr_atp (rt->entries, i); + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, i); /* We insert before the first range that begins at or after the new range. */ if (entry->first >= first && insert_me_here < 0) @@ -475,7 +580,8 @@ insert_me_too.last = entry->last; insert_me_too.val = entry->val; entry->last = first; - Dynarr_insert_many (rt->entries, &insert_me_too, 1, i + 1); + rt->entries = + gap_array_insert_els (rt->entries, i + 1, &insert_me_too, 1); } else if (entry->last >= last) { @@ -496,7 +602,7 @@ else { /* existing is entirely within new. */ - Dynarr_delete_many (rt->entries, i, 1); + gap_array_delete_els (rt->entries, i, 1); i--; /* back up since everything shifted one to the left. */ } } @@ -517,7 +623,8 @@ insert_me.last = last; insert_me.val = val; - Dynarr_insert_many (rt->entries, &insert_me, 1, insert_me_here); + rt->entries = + gap_array_insert_els (rt->entries, insert_me_here, &insert_me, 1); } /* Now see if we can combine this entry with adjacent ones just @@ -525,12 +632,12 @@ if (insert_me_here > 0) { - struct range_table_entry *entry = Dynarr_atp (rt->entries, - insert_me_here - 1); + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, insert_me_here - 1); if (EQ (val, entry->val) && entry->last == first) { entry->last = last; - Dynarr_delete_many (rt->entries, insert_me_here, 1); + gap_array_delete_els (rt->entries, insert_me_here, 1); insert_me_here--; /* We have morphed into a larger range. Update our records in case we also combine with the one after. */ @@ -538,14 +645,14 @@ } } - if (insert_me_here < Dynarr_length (rt->entries) - 1) + if (insert_me_here < gap_array_length (rt->entries) - 1) { - struct range_table_entry *entry = Dynarr_atp (rt->entries, - insert_me_here + 1); + struct range_table_entry *entry = + rangetab_gap_array_atp (rt->entries, insert_me_here + 1); if (EQ (val, entry->val) && entry->first == last) { entry->first = first; - Dynarr_delete_many (rt->entries, insert_me_here, 1); + gap_array_delete_els (rt->entries, insert_me_here, 1); } } } @@ -584,7 +691,7 @@ (range_table)) { CHECK_RANGE_TABLE (range_table); - Dynarr_reset (XRANGE_TABLE (range_table)->entries); + gap_array_delete_all_els (XRANGE_TABLE (range_table)->entries); return Qnil; } @@ -610,17 +717,18 @@ /* Do not "optimize" by pulling out the length computation below! FUNCTION may have changed the table. */ - for (i = 0; i < Dynarr_length (rt->entries); i++) + for (i = 0; i < gap_array_length (rt->entries); i++) { - struct range_table_entry *entry = Dynarr_atp (rt->entries, i); + struct range_table_entry entry = + rangetab_gap_array_at (rt->entries, i); EMACS_INT first, last; Lisp_Object args[4]; int oldlen; again: - first = entry->first; - last = entry->last; - oldlen = Dynarr_length (rt->entries); + first = entry.first; + last = entry.last; + oldlen = gap_array_length (rt->entries); args[0] = function; /* Fix up the numbers in accordance with the open/closedness of the table. */ @@ -630,12 +738,12 @@ args[1] = make_int (premier); args[2] = make_int (dernier); } - args[3] = entry->val; + args[3] = entry.val; Ffuncall (countof (args), args); /* Has FUNCTION removed the entry? */ - if (oldlen > Dynarr_length (rt->entries) - && i < Dynarr_length (rt->entries) - && (first != entry->first || last != entry->last)) + if (oldlen > gap_array_length (rt->entries) + && i < gap_array_length (rt->entries) + && (first != entry.first || last != entry.last)) goto again; } @@ -777,7 +885,7 @@ unified_range_table_bytes_needed (Lisp_Object rangetab) { return (sizeof (struct range_table_entry) * - (Dynarr_length (XRANGE_TABLE (rangetab)->entries) - 1) + + (gap_array_length (XRANGE_TABLE (rangetab)->entries) - 1) + sizeof (struct unified_range_table) + /* ALIGNOF a struct may be too big. */ /* We have four bytes for the size numbers, and an extra @@ -797,9 +905,10 @@ char * and adding sizeof(int), because that will lead to mis-aligned data on the Alpha machines. */ struct unified_range_table *un; - range_table_entry_dynarr *rted = XRANGE_TABLE (rangetab)->entries; + Gap_Array *rtega = XRANGE_TABLE (rangetab)->entries; int total_needed = unified_range_table_bytes_needed (rangetab); void *new_dest = ALIGN_PTR ((char *) dest + 4, EMACS_INT); + Elemcount i; * (char *) dest = (char) ((char *) new_dest - (char *) dest); * ((unsigned char *) dest + 1) = total_needed & 0xFF; @@ -808,10 +917,10 @@ total_needed >>= 8; * ((unsigned char *) dest + 3) = total_needed & 0xFF; un = (struct unified_range_table *) new_dest; - un->nentries = Dynarr_length (rted); + un->nentries = gap_array_length (rtega); un->type = XRANGE_TABLE (rangetab)->type; - memcpy (&un->first, Dynarr_begin (rted), - sizeof (struct range_table_entry) * Dynarr_length (rted)); + for (i = 0; i < gap_array_length (rtega); i++) + (&un->first)[i] = rangetab_gap_array_at (rtega, i); } /* Return number of bytes actually used by a unified range table. */ @@ -854,7 +963,7 @@ new_dest = (char *) unrangetab + * (char *) unrangetab; un = (struct unified_range_table *) new_dest; - return get_range_table (pos, un->nentries, &un->first, default_); + return get_range_table (pos, un->nentries, &un->first, 0, 0, default_); } /* Return number of entries in a unified range table. */ @@ -902,7 +1011,7 @@ void syms_of_rangetab (void) { - INIT_LRECORD_IMPLEMENTATION (range_table); + INIT_LISP_OBJECT (range_table); DEFSYMBOL_MULTIWORD_PREDICATE (Qrange_tablep); DEFSYMBOL (Qrange_table);
--- a/src/rangetab.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/rangetab.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* XEmacs routines to deal with range tables. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 2004 Ben Wing. + Copyright (C) 1995, 2004, 2010 Ben Wing. This file is part of XEmacs. @@ -29,6 +29,9 @@ typedef struct range_table_entry range_table_entry; struct range_table_entry { +#ifdef NEW_GC + NORMAL_LISP_OBJECT_HEADER header; +#endif /* NEW_GC */ EMACS_INT first; EMACS_INT last; Lisp_Object val; @@ -49,16 +52,20 @@ struct Lisp_Range_Table { - struct LCRECORD_HEADER header; - range_table_entry_dynarr *entries; + NORMAL_LISP_OBJECT_HEADER header; + Gap_Array *entries; enum range_table_type type; }; typedef struct Lisp_Range_Table Lisp_Range_Table; -DECLARE_LRECORD (range_table, Lisp_Range_Table); +DECLARE_LISP_OBJECT (range_table, Lisp_Range_Table); #define XRANGE_TABLE(x) XRECORD (x, range_table, Lisp_Range_Table) #define wrap_range_table(p) wrap_record (p, range_table) #define RANGE_TABLEP(x) RECORDP (x, range_table) #define CHECK_RANGE_TABLE(x) CHECK_RECORD (x, range_table) +#define rangetab_gap_array_at(ga, pos) \ + gap_array_at (ga, pos, struct range_table_entry) +#define rangetab_gap_array_atp(ga, pos) \ + gap_array_atp (ga, pos, struct range_table_entry) #endif /* INCLUDED_rangetab_h_ */
--- a/src/redisplay-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -633,6 +633,17 @@ SelectObject (hcompdc, old); } +/* Return x MOD y, but the result is guaranteed positive */ + +static int +posmod (int x, int y) +{ + int retval = x % y; + if (retval < 0) + retval += y; + return retval; +} + /* X gc's have this nice property that setting the bg pixmap will * output it offset relative to the window. Windows doesn't have this * feature so we have to emulate this by outputting multiple pixmaps. @@ -642,13 +653,15 @@ mswindows_output_dibitmap_region (struct frame *f, Lisp_Image_Instance *p, struct display_box *db, - struct display_glyph_area *dga) + struct display_glyph_area *dga, + int absolute) { struct display_box xdb = { db->xpos, db->ypos, db->width, db->height }; struct display_glyph_area xdga = { 0, 0, IMAGE_INSTANCE_PIXMAP_WIDTH (p), IMAGE_INSTANCE_PIXMAP_HEIGHT (p) }; int pxoffset = 0, pyoffset = 0; + int absolute_pxoffset = 0, absolute_pyoffset = 0; if (dga) { @@ -658,16 +671,30 @@ else if (!redisplay_normalize_glyph_area (&xdb, &xdga)) return; + if (absolute) + { + POINT point; + point.x = 0; + point.y = 0; + if (ScreenToClient (FRAME_MSWINDOWS_HANDLE (f), &point)) + { + absolute_pxoffset = point.x; + absolute_pyoffset = point.y; + } + } + /* when doing a bg pixmap do a partial pixmap first so that we blt whole pixmaps thereafter */ xdga.height = min (xdga.height, IMAGE_INSTANCE_PIXMAP_HEIGHT (p) - - db->ypos % IMAGE_INSTANCE_PIXMAP_HEIGHT (p)); + posmod (db->ypos - absolute_pyoffset, + IMAGE_INSTANCE_PIXMAP_HEIGHT (p))); while (xdga.height > 0) { xdga.width = min (min (db->width, IMAGE_INSTANCE_PIXMAP_WIDTH (p)), IMAGE_INSTANCE_PIXMAP_WIDTH (p) - - db->xpos % IMAGE_INSTANCE_PIXMAP_WIDTH (p)); + posmod (db->xpos - absolute_pxoffset, + IMAGE_INSTANCE_PIXMAP_WIDTH (p))); pxoffset = 0; while (xdga.width > 0) { @@ -675,9 +702,13 @@ xdb.ypos = db->ypos + pyoffset; /* do we need to offset the pixmap vertically? this is necessary for background pixmaps. */ - xdga.yoffset = xdb.ypos % IMAGE_INSTANCE_PIXMAP_HEIGHT (p); - xdga.xoffset = xdb.xpos % IMAGE_INSTANCE_PIXMAP_WIDTH (p); - /* the width is handled by mswindows_output_pixmap_region */ + xdga.xoffset = posmod (xdb.xpos - absolute_pxoffset, + IMAGE_INSTANCE_PIXMAP_WIDTH (p)); + xdga.yoffset = posmod (xdb.ypos - absolute_pyoffset, + IMAGE_INSTANCE_PIXMAP_HEIGHT (p)); + /* [[ the width is handled by mswindows_output_pixmap_region ]] + #### -- What is the correct meaning of this comment? There is + no mswindows_output_pixmap_region(). --ben*/ mswindows_output_dibitmap (f, p, &xdb, &xdga); pxoffset += xdga.width; xdga.width = min ((db->width - pxoffset), @@ -711,7 +742,9 @@ WINDOW_FACE_CACHEL_BACKGROUND (w, findex), Qnil); if (bg_pixmap) - mswindows_output_dibitmap_region (f, p, db, dga); + mswindows_output_dibitmap_region + (f, p, db, dga, + EQ (WINDOW_FACE_CACHEL_BACKGROUND_PLACEMENT (w, findex), Qabsolute)); else mswindows_output_dibitmap (f, p, db, dga); } @@ -1212,7 +1245,9 @@ struct device *UNUSED (d), struct frame *f, face_index UNUSED (findex), int x, int y, int width, int height, Lisp_Object fcolor, - Lisp_Object bcolor, Lisp_Object background_pixmap) + Lisp_Object bcolor, + Lisp_Object background_pixmap, + Lisp_Object background_placement) { RECT rect = { x, y, x+width, y+height }; HDC hdc = get_frame_dc (f, 1); @@ -1223,7 +1258,8 @@ mswindows_update_dc (hdc, fcolor, bcolor, background_pixmap); mswindows_output_dibitmap_region - ( f, XIMAGE_INSTANCE (background_pixmap), &db, 0); + (f, XIMAGE_INSTANCE (background_pixmap), &db, 0, + EQ (background_placement, Qabsolute)); } else {
--- a/src/redisplay-output.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay-output.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ Copyright (C) 1995, 1996, 2002, 2003 Ben Wing. Copyright (C) 1996 Chuck Thompson. Copyright (C) 1999, 2002 Andy Piper. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -637,8 +638,8 @@ Lisp_Object window = wrap_window (w); redisplay_clear_region (window, DEFAULT_INDEX, - FRAME_LEFT_BORDER_START (f), y, - FRAME_INTERNAL_BORDER_WIDTH (f), height); + FRAME_LEFT_INTERNAL_BORDER_START (f), y, + FRAME_INTERNAL_BORDER_WIDTH (f), height); } /***************************************************************************** @@ -653,8 +654,8 @@ Lisp_Object window = wrap_window (w); redisplay_clear_region (window, DEFAULT_INDEX, - FRAME_RIGHT_BORDER_START (f), - y, FRAME_INTERNAL_BORDER_WIDTH (f), height); + FRAME_RIGHT_INTERNAL_BORDER_START (f), + y, FRAME_INTERNAL_BORDER_WIDTH (f), height); } /***************************************************************************** @@ -1662,8 +1663,7 @@ dga->width = IMAGE_INSTANCE_PIXMAP_WIDTH (p); #ifdef DEBUG_REDISPLAY - printf ("redisplay_output_pixmap(request) \ -[%dx%d@%d+%d] in [%dx%d@%d+%d]\n", + printf ("redisplay_output_pixmap(request) [%dx%d@%d+%d] in [%dx%d@%d+%d]\n", db->width, db->height, db->xpos, db->ypos, dga->width, dga->height, dga->xoffset, dga->yoffset); #endif @@ -1673,8 +1673,7 @@ return; #ifdef DEBUG_REDISPLAY - printf ("redisplay_output_pixmap(normalized) \ -[%dx%d@%d+%d] in [%dx%d@%d+%d]\n", + printf ("redisplay_output_pixmap(normalized) [%dx%d@%d+%d] in [%dx%d@%d+%d]\n", db->width, db->height, db->xpos, db->ypos, dga->width, dga->height, dga->xoffset, dga->yoffset); #endif @@ -1721,6 +1720,7 @@ struct frame *f = NULL; struct device *d; Lisp_Object background_pixmap = Qunbound; + Lisp_Object background_placement = Qunbound; Lisp_Object fcolor = Qnil, bcolor = Qnil; if (!width || !height) @@ -1747,11 +1747,12 @@ /* #### This isn't quite right for when this function is called from the toolbar code. */ + /* #### GEOM! This uses a backing pixmap in the gutter. Correct? */ /* Don't use a backing pixmap in the border area */ - if (x >= FRAME_LEFT_BORDER_END (f) - && x < FRAME_RIGHT_BORDER_START (f) - && y >= FRAME_TOP_BORDER_END (f) - && y < FRAME_BOTTOM_BORDER_START (f)) + if (x >= FRAME_LEFT_INTERNAL_BORDER_END (f) + && x < FRAME_RIGHT_INTERNAL_BORDER_START (f) + && y >= FRAME_TOP_INTERNAL_BORDER_END (f) + && y < FRAME_BOTTOM_INTERNAL_BORDER_START (f)) { Lisp_Object temp; @@ -1765,22 +1766,26 @@ /* #### maybe we could implement such that a string can be a background pixmap? */ background_pixmap = temp; + background_placement + = WINDOW_FACE_CACHEL_BACKGROUND_PLACEMENT (w, findex); } } else { temp = FACE_BACKGROUND_PIXMAP (Vdefault_face, locale); - + if (IMAGE_INSTANCEP (temp) && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (temp))) { background_pixmap = temp; + background_placement + = FACE_BACKGROUND_PLACEMENT (Vdefault_face, locale); } } } - if (!UNBOUNDP (background_pixmap) && - XIMAGE_INSTANCE_PIXMAP_DEPTH (background_pixmap) == 0) + if (!UNBOUNDP (background_pixmap) + && XIMAGE_INSTANCE_PIXMAP_DEPTH (background_pixmap) == 0) { if (w) { @@ -1804,8 +1809,9 @@ if (UNBOUNDP (background_pixmap)) background_pixmap = Qnil; - DEVMETH (d, clear_region, - (locale, d, f, findex, x, y, width, height, fcolor, bcolor, background_pixmap)); + DEVMETH (d, clear_region, (locale, d, f, findex, x, y, width, height, + fcolor, bcolor, + background_pixmap, background_placement)); } /**************************************************************************** @@ -2091,7 +2097,10 @@ { Lisp_Object window = wrap_window (w); - + /* #### GEOM! FIXME #### This is definitely wrong. It was clearly not + fixed up to accommodate the gutter. The internal border width is now + no longer adjacent to the leftmost window, since the gutter + intervenes. */ if (!NILP (Fwindow_highest_p (window))) { struct frame *f = XFRAME (w->frame); @@ -2108,7 +2117,8 @@ if (window_is_rightmost (w)) width += FRAME_INTERNAL_BORDER_WIDTH (f); - y = FRAME_TOP_BORDER_START (f) - 1; + /* #### This off-by-one stuff also occurs in XLIKE_clear_frame(). */ + y = FRAME_TOP_INTERNAL_BORDER_START (f) - 1; height = FRAME_INTERNAL_BORDER_HEIGHT (f) + 1; redisplay_clear_region (window, DEFAULT_INDEX, x, y, width, height); @@ -2144,12 +2154,15 @@ window = wrap_window (w); if (window_is_leftmost (w)) - redisplay_clear_region (window, DEFAULT_INDEX, FRAME_LEFT_BORDER_START (f), - ypos1, FRAME_INTERNAL_BORDER_WIDTH (f), height); + redisplay_clear_region (window, DEFAULT_INDEX, + FRAME_LEFT_INTERNAL_BORDER_START (f), + ypos1, FRAME_INTERNAL_BORDER_WIDTH (f), + height); if (bounds.left_in - bounds.left_out > 0) redisplay_clear_region (window, - get_builtin_face_cache_index (w, Vleft_margin_face), + get_builtin_face_cache_index + (w, Vleft_margin_face), bounds.left_out, ypos1, bounds.left_in - bounds.left_out, height); @@ -2161,13 +2174,17 @@ if (bounds.right_out - bounds.right_in > 0) redisplay_clear_region (window, - get_builtin_face_cache_index (w, Vright_margin_face), + get_builtin_face_cache_index + (w, Vright_margin_face), bounds.right_in, ypos1, - bounds.right_out - bounds.right_in, height); + bounds.right_out - bounds.right_in, + height); if (window_is_rightmost (w)) - redisplay_clear_region (window, DEFAULT_INDEX, FRAME_RIGHT_BORDER_START (f), - ypos1, FRAME_INTERNAL_BORDER_WIDTH (f), height); + redisplay_clear_region (window, DEFAULT_INDEX, + FRAME_RIGHT_INTERNAL_BORDER_START (f), + ypos1, FRAME_INTERNAL_BORDER_WIDTH (f), + height); } } }
--- a/src/redisplay-tty.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay-tty.c Mon Mar 29 21:28:13 2010 -0500 @@ -428,7 +428,8 @@ struct frame * f, face_index findex, int x, int y, int width, int height, Lisp_Object UNUSED (fcolor), Lisp_Object UNUSED (bcolor), - Lisp_Object UNUSED (background_pixmap)) + Lisp_Object UNUSED (background_pixmap), + Lisp_Object UNUSED (background_placement)) { struct console *c = XCONSOLE (FRAME_CONSOLE (f)); int line;
--- a/src/redisplay-xlike-inc.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay-xlike-inc.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ Copyright (C) 1994 Lucid, Inc. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 2002, 2003, 2005, 2009, 2010 Ben Wing. + Copyright (C) 2010 Didier Verna This file is part of XEmacs. @@ -812,8 +813,9 @@ /* Called as gtk_get_gc from gtk-glue.c */ -XLIKE_GC XLIKE_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, - Lisp_Object bg, Lisp_Object bg_pmap, +XLIKE_GC XLIKE_get_gc (struct frame *f, Lisp_Object font, + Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pixmap, Lisp_Object bg_placement, Lisp_Object lwidth); /***************************************************************************** @@ -822,9 +824,12 @@ Given a number of parameters return a GC with those properties. ****************************************************************************/ XLIKE_GC -XLIKE_get_gc (struct device *d, Lisp_Object font, Lisp_Object fg, - Lisp_Object bg, Lisp_Object bg_pmap, Lisp_Object lwidth) +XLIKE_get_gc (struct frame *f, Lisp_Object font, + Lisp_Object fg, Lisp_Object bg, + Lisp_Object bg_pixmap, Lisp_Object bg_placement, + Lisp_Object lwidth) { + struct device *d = XDEVICE (f->device); XLIKE_GCVALUES gcv; unsigned long mask; @@ -836,7 +841,8 @@ gcv.clip_x_origin = 0; gcv.clip_y_origin = 0; XLIKE_SET_GC_FILL (gcv, XLIKE_FILL_SOLID); - mask = XLIKE_GC_EXPOSURES | XLIKE_GC_CLIP_MASK | XLIKE_GC_CLIP_X_ORIGIN | XLIKE_GC_CLIP_Y_ORIGIN; + mask = XLIKE_GC_EXPOSURES + | XLIKE_GC_CLIP_MASK | XLIKE_GC_CLIP_X_ORIGIN | XLIKE_GC_CLIP_Y_ORIGIN; mask |= XLIKE_GC_FILL; if (!NILP (font) @@ -882,7 +888,7 @@ /* This special case comes from a request to draw text with a face which has the dim property. We'll use a stippled foreground GC. */ - if (EQ (bg_pmap, Qdim)) + if (EQ (bg_pixmap, Qdim)) { assert (DEVICE_XLIKE_GRAY_PIXMAP (d) != XLIKE_NONE); @@ -890,21 +896,35 @@ gcv.stipple = DEVICE_XLIKE_GRAY_PIXMAP (d); mask |= (XLIKE_GC_FILL | XLIKE_GC_STIPPLE); } - else if (IMAGE_INSTANCEP (bg_pmap) - && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pmap))) + else if (IMAGE_INSTANCEP (bg_pixmap) + && IMAGE_INSTANCE_PIXMAP_TYPE_P (XIMAGE_INSTANCE (bg_pixmap))) { - if (XIMAGE_INSTANCE_PIXMAP_DEPTH (bg_pmap) == 0) + if (XIMAGE_INSTANCE_PIXMAP_DEPTH (bg_pixmap) == 0) { XLIKE_SET_GC_FILL (gcv, XLIKE_FILL_OPAQUE_STIPPLED); - gcv.stipple = XIMAGE_INSTANCE_XLIKE_PIXMAP (bg_pmap); + gcv.stipple = XIMAGE_INSTANCE_XLIKE_PIXMAP (bg_pixmap); mask |= (XLIKE_GC_STIPPLE | XLIKE_GC_FILL); } else { XLIKE_SET_GC_FILL (gcv, XLIKE_FILL_TILED); - gcv.tile = XIMAGE_INSTANCE_XLIKE_PIXMAP (bg_pmap); + gcv.tile = XIMAGE_INSTANCE_XLIKE_PIXMAP (bg_pixmap); mask |= (XLIKE_GC_TILE | XLIKE_GC_FILL); } + if (EQ (bg_placement, Qabsolute)) + { +#ifdef THIS_IS_GTK + /* #### WARNING: this does not currently work. -- dvl + gcv.ts_x_origin = - FRAME_GTK_X (f); + gcv.ts_y_origin = - FRAME_GTK_Y (f); + mask |= (XLIKE_GC_TS_X_ORIGIN | XLIKE_GC_TS_Y_ORIGIN); + */ +#else + gcv.ts_x_origin = - FRAME_X_X (f); + gcv.ts_y_origin = - FRAME_X_Y (f); + mask |= (XLIKE_GC_TS_X_ORIGIN | XLIKE_GC_TS_Y_ORIGIN); +#endif + } } if (!NILP (lwidth)) @@ -1076,8 +1096,8 @@ && !NILP (w->text_cursor_visible_p)) || NILP (bg_pmap)) bgc = 0; else - bgc = XLIKE_get_gc (d, Qnil, cachel->foreground, cachel->background, - bg_pmap, Qnil); + bgc = XLIKE_get_gc (f, Qnil, cachel->foreground, cachel->background, + bg_pmap, cachel->background_placement, Qnil); if (bgc) { @@ -1157,8 +1177,8 @@ fg = XFT_FROB_LISP_COLOR (cursor_cachel->foreground, 0); bg = XFT_FROB_LISP_COLOR (cursor_cachel->background, 0); #endif - gc = XLIKE_get_gc (d, font, cursor_cachel->foreground, - cursor_cachel->background, Qnil, Qnil); + gc = XLIKE_get_gc (f, font, cursor_cachel->foreground, + cursor_cachel->background, Qnil, Qnil, Qnil); } else if (cachel->dim) { @@ -1179,8 +1199,8 @@ fg = XFT_FROB_LISP_COLOR (cachel->foreground, 1); bg = XFT_FROB_LISP_COLOR (cachel->background, 0); #endif - gc = XLIKE_get_gc (d, font, cachel->foreground, cachel->background, - Qdim, Qnil); + gc = XLIKE_get_gc (f, font, cachel->foreground, cachel->background, + Qdim, Qnil, Qnil); } else { @@ -1188,8 +1208,8 @@ fg = XFT_FROB_LISP_COLOR (cachel->foreground, 0); bg = XFT_FROB_LISP_COLOR (cachel->background, 0); #endif - gc = XLIKE_get_gc (d, font, cachel->foreground, cachel->background, - Qnil, Qnil); + gc = XLIKE_get_gc (f, font, cachel->foreground, cachel->background, + Qnil, Qnil, Qnil); } #ifdef USE_XFT { @@ -1462,8 +1482,8 @@ { XLIKE_RECTANGLE clip_box; XLIKE_GC cgc; - cgc = XLIKE_get_gc (d, font, cursor_cachel->foreground, - cursor_cachel->background, Qnil, Qnil); + cgc = XLIKE_get_gc (f, font, cursor_cachel->foreground, + cursor_cachel->background, Qnil, Qnil, Qnil); clip_box.x = 0; clip_box.y = 0; @@ -1534,13 +1554,14 @@ if (!NILP (bar_cursor_value)) { - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, Qnil, + Qnil, Qnil, make_int (bar_width)); } else { - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, - Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, + Qnil, Qnil, Qnil, Qnil); } tmp_y = dl->ypos - bogusly_obtained_ascent_value; @@ -1728,7 +1749,8 @@ get_builtin_face_cache_index (w, Vtext_cursor_face)); - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil, + Qnil); if (cursor_width > db->xpos + dga->width - cursor_start) cursor_width = db->xpos + dga->width - cursor_start; @@ -1872,11 +1894,13 @@ bg_pmap = Qnil; if (NILP (bg_pmap)) - gc = XLIKE_get_gc (d, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), - Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), + Qnil, Qnil, Qnil, Qnil); else - gc = XLIKE_get_gc (d, Qnil, WINDOW_FACE_CACHEL_FOREGROUND (w, rb->findex), - WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), bg_pmap, + gc = XLIKE_get_gc (f, Qnil, WINDOW_FACE_CACHEL_FOREGROUND (w, rb->findex), + WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), + bg_pmap, + WINDOW_FACE_CACHEL_BACKGROUND_PLACEMENT (w, rb->findex), Qnil); XLIKE_FILL_RECTANGLE (dpy, x_win, gc, x, y, width, height); @@ -1897,7 +1921,8 @@ (WINDOW_FACE_CACHEL (w, rb->findex), Vcharset_ascii)); - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, Qnil, + Qnil, Qnil, Qnil); cursor_y = dl->ypos - fi->ascent; cursor_height = fi->height; @@ -1915,8 +1940,9 @@ { int bar_width = EQ (bar_cursor_value, Qt) ? 1 : 2; - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, - Qnil, Qnil, make_int (bar_width)); + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, + Qnil, Qnil, Qnil, + make_int (bar_width)); XLIKE_DRAW_LINE (dpy, x_win, gc, cursor_start + bar_width - 1, cursor_y, cursor_start + bar_width - 1, cursor_y + cursor_height - 1); @@ -1959,9 +1985,9 @@ /* First clear the area not covered by the line. */ if (height - rb->object.hline.thickness > 0) { - gc = XLIKE_get_gc (d, Qnil, + gc = XLIKE_get_gc (f, Qnil, WINDOW_FACE_CACHEL_FOREGROUND (w, rb->findex), - Qnil, Qnil, Qnil); + Qnil, Qnil, Qnil, Qnil); if (ypos2 - ypos1 > 0) XLIKE_FILL_RECTANGLE (dpy, x_win, gc, x, ypos1, width, ypos2 - ypos1); @@ -1977,8 +2003,8 @@ } #else /* THIS_IS_X */ /* Now draw the line. */ - gc = XLIKE_get_gc (d, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), - Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, WINDOW_FACE_CACHEL_BACKGROUND (w, rb->findex), + Qnil, Qnil, Qnil, Qnil); if (ypos2 < ypos1) ypos2 = ypos1; @@ -1999,8 +2025,10 @@ static void XLIKE_clear_region (Lisp_Object UNUSED (locale), struct device* d, struct frame* f, face_index UNUSED (findex), int x, int y, - int width, int height, Lisp_Object fcolor, - Lisp_Object bcolor, Lisp_Object background_pixmap) + int width, int height, + Lisp_Object fcolor, Lisp_Object bcolor, + Lisp_Object background_pixmap, + Lisp_Object background_placement) { XLIKE_DISPLAY dpy = GET_XLIKE_DISPLAY (d); XLIKE_WINDOW x_win = GET_XLIKE_WINDOW (f); @@ -2008,7 +2036,8 @@ if (!UNBOUNDP (background_pixmap)) { - gc = XLIKE_get_gc (d, Qnil, fcolor, bcolor, background_pixmap, Qnil); + gc = XLIKE_get_gc (f, Qnil, fcolor, bcolor, + background_pixmap, background_placement, Qnil); } if (gc) @@ -2054,7 +2083,8 @@ if (NILP (w->text_cursor_visible_p)) return; - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, Qnil); + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, Qnil, + Qnil, Qnil, Qnil); default_face_font_info (window, &defascent, 0, 0, &defheight, 0); @@ -2078,7 +2108,8 @@ { int bar_width = EQ (bar_cursor_value, Qt) ? 1 : 2; - gc = XLIKE_get_gc (d, Qnil, cursor_cachel->background, Qnil, Qnil, + gc = XLIKE_get_gc (f, Qnil, cursor_cachel->background, Qnil, + Qnil, Qnil, make_int (bar_width)); XLIKE_DRAW_LINE (dpy, x_win, gc, x + bar_width - 1, cursor_y, x + bar_width - 1, cursor_y + cursor_height - 1); @@ -2127,19 +2158,16 @@ int x, y, width, height; Lisp_Object frame; - x = FRAME_LEFT_BORDER_START (f); - width = (FRAME_PIXWIDTH (f) - FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) - - FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f) - - 2 * FRAME_REAL_LEFT_TOOLBAR_BORDER_WIDTH (f) - - 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f)); + /* #### GEOM! This clears the internal border and gutter (and scrollbars) + but not the toolbar. Correct? */ + x = FRAME_LEFT_INTERNAL_BORDER_START (f); + width = (FRAME_RIGHT_INTERNAL_BORDER_END (f) - x); /* #### This adjustment by 1 should be being done in the macros. There is some small differences between when the menubar is on - and off that we still need to deal with. */ - y = FRAME_TOP_BORDER_START (f) - 1; - height = (FRAME_PIXHEIGHT (f) - FRAME_REAL_TOP_TOOLBAR_HEIGHT (f) - - FRAME_REAL_BOTTOM_TOOLBAR_HEIGHT (f) - - 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f) - - 2 * FRAME_REAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f)) + 1; + and off that we still need to deal with. The adjustment also occurs in + redisplay_clear_top_of_window(). */ + y = FRAME_TOP_INTERNAL_BORDER_START (f) - 1; + height = (FRAME_BOTTOM_INTERNAL_BORDER_END (f) - y); XLIKE_CLEAR_AREA (dpy, x_win, x, y, width, height);
--- a/src/redisplay.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay.c Mon Mar 29 21:28:13 2010 -0500 @@ -1686,7 +1686,10 @@ break; case PROP_STRING: if (pb->data.p_string.str) - xfree (pb->data.p_string.str); + { + xfree (pb->data.p_string.str); + pb->data.p_string.str = 0; + } /* #### bogus bogus -- this doesn't do anything! Should probably call add_ibyte_string_runes(), once that function is fixed. */ @@ -8768,7 +8771,7 @@ d->pixel_to_glyph_cache.obj_x = *obj_x; \ d->pixel_to_glyph_cache.obj_y = *obj_y; \ d->pixel_to_glyph_cache.w = *w; \ - d->pixel_to_glyph_cache.charpos = *charpos; \ + d->pixel_to_glyph_cache.charpos = *charpos; \ d->pixel_to_glyph_cache.closest = *closest; \ d->pixel_to_glyph_cache.modeline_closest = *modeline_closest; \ d->pixel_to_glyph_cache.obj1 = *obj1; \ @@ -8785,10 +8788,15 @@ OVER_TOOLBAR: over one of the 4 frame toolbars OVER_MODELINE: over a modeline OVER_BORDER: over an internal border + OVER_V_DIVIDER: over a vertical divider between windows (used as a + grab bar for resizing) OVER_NOTHING: over the text area, but not over text OVER_OUTSIDE: outside of the frame border OVER_TEXT: over text in the text area + #### GEOM! We need to also have an OVER_GUTTER, OVER_SCROLLBAR and + OVER_DEAD_BOX. + OBJ1 is one of -- a toolbar button @@ -8881,25 +8889,28 @@ if (device_check_failed) return OVER_NOTHING; - frm_left = FRAME_LEFT_BORDER_END (f); - frm_right = FRAME_RIGHT_BORDER_START (f); - frm_top = FRAME_TOP_BORDER_END (f); - frm_bottom = FRAME_BOTTOM_BORDER_START (f); + /* #### GEOM! The gutter is just inside of this. We should also have an + OVER_GUTTER return value to indicate that we're over a gutter. See + above. */ + frm_left = FRAME_LEFT_INTERNAL_BORDER_END (f); + frm_right = FRAME_RIGHT_INTERNAL_BORDER_START (f); + frm_top = FRAME_TOP_INTERNAL_BORDER_END (f); + frm_bottom = FRAME_BOTTOM_INTERNAL_BORDER_START (f); /* Check if the mouse is outside of the text area actually used by redisplay. */ if (y_coord < frm_top) { - if (y_coord >= FRAME_TOP_BORDER_START (f)) - { - low_y_coord = FRAME_TOP_BORDER_START (f); + if (y_coord >= FRAME_TOP_INTERNAL_BORDER_START (f)) + { + low_y_coord = FRAME_TOP_INTERNAL_BORDER_START (f); high_y_coord = frm_top; position = OVER_BORDER; } else if (y_coord >= 0) { low_y_coord = 0; - high_y_coord = FRAME_TOP_BORDER_START (f); + high_y_coord = FRAME_TOP_INTERNAL_BORDER_START (f); position = OVER_TOOLBAR; } else @@ -8911,15 +8922,15 @@ } else if (y_coord >= frm_bottom) { - if (y_coord < FRAME_BOTTOM_BORDER_END (f)) + if (y_coord < FRAME_BOTTOM_INTERNAL_BORDER_END (f)) { low_y_coord = frm_bottom; - high_y_coord = FRAME_BOTTOM_BORDER_END (f); + high_y_coord = FRAME_BOTTOM_INTERNAL_BORDER_END (f); position = OVER_BORDER; } else if (y_coord < FRAME_PIXHEIGHT (f)) { - low_y_coord = FRAME_BOTTOM_BORDER_END (f); + low_y_coord = FRAME_BOTTOM_INTERNAL_BORDER_END (f); high_y_coord = FRAME_PIXHEIGHT (f); position = OVER_TOOLBAR; } @@ -8935,16 +8946,16 @@ { if (x_coord < frm_left) { - if (x_coord >= FRAME_LEFT_BORDER_START (f)) - { - low_x_coord = FRAME_LEFT_BORDER_START (f); + if (x_coord >= FRAME_LEFT_INTERNAL_BORDER_START (f)) + { + low_x_coord = FRAME_LEFT_INTERNAL_BORDER_START (f); high_x_coord = frm_left; position = OVER_BORDER; } else if (x_coord >= 0) { low_x_coord = 0; - high_x_coord = FRAME_LEFT_BORDER_START (f); + high_x_coord = FRAME_LEFT_INTERNAL_BORDER_START (f); position = OVER_TOOLBAR; } else @@ -8956,15 +8967,15 @@ } else if (x_coord >= frm_right) { - if (x_coord < FRAME_RIGHT_BORDER_END (f)) + if (x_coord < FRAME_RIGHT_INTERNAL_BORDER_END (f)) { low_x_coord = frm_right; - high_x_coord = FRAME_RIGHT_BORDER_END (f); + high_x_coord = FRAME_RIGHT_INTERNAL_BORDER_END (f); position = OVER_BORDER; } else if (x_coord < FRAME_PIXWIDTH (f)) { - low_x_coord = FRAME_RIGHT_BORDER_END (f); + low_x_coord = FRAME_RIGHT_INTERNAL_BORDER_END (f); high_x_coord = FRAME_PIXWIDTH (f); position = OVER_TOOLBAR; } @@ -9657,50 +9668,50 @@ /***************************************************************************/ static int -compute_rune_dynarr_usage (rune_dynarr *dyn, struct overhead_stats *ovstats) -{ - return dyn ? Dynarr_memory_usage (dyn, ovstats) : 0; +compute_rune_dynarr_usage (rune_dynarr *dyn, struct usage_stats *ustats) +{ + return dyn ? Dynarr_memory_usage (dyn, ustats) : 0; } static int compute_display_block_dynarr_usage (display_block_dynarr *dyn, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { int total, i; if (!dyn) return 0; - total = Dynarr_memory_usage (dyn, ovstats); + total = Dynarr_memory_usage (dyn, ustats); for (i = 0; i < Dynarr_largest (dyn); i++) - total += compute_rune_dynarr_usage (Dynarr_at (dyn, i).runes, ovstats); + total += compute_rune_dynarr_usage (Dynarr_at (dyn, i).runes, ustats); return total; } static int compute_glyph_block_dynarr_usage (glyph_block_dynarr *dyn, - struct overhead_stats *ovstats) -{ - return dyn ? Dynarr_memory_usage (dyn, ovstats) : 0; + struct usage_stats *ustats) +{ + return dyn ? Dynarr_memory_usage (dyn, ustats) : 0; } int compute_display_line_dynarr_usage (display_line_dynarr *dyn, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { int total, i; if (!dyn) return 0; - total = Dynarr_memory_usage (dyn, ovstats); + total = Dynarr_memory_usage (dyn, ustats); for (i = 0; i < Dynarr_largest (dyn); i++) { struct display_line *dl = &Dynarr_at (dyn, i); - total += compute_display_block_dynarr_usage(dl->display_blocks, ovstats); - total += compute_glyph_block_dynarr_usage (dl->left_glyphs, ovstats); - total += compute_glyph_block_dynarr_usage (dl->right_glyphs, ovstats); + total += compute_display_block_dynarr_usage(dl->display_blocks, ustats); + total += compute_glyph_block_dynarr_usage (dl->left_glyphs, ustats); + total += compute_glyph_block_dynarr_usage (dl->right_glyphs, ustats); } return total; @@ -9708,9 +9719,9 @@ int compute_line_start_cache_dynarr_usage (line_start_cache_dynarr *dyn, - struct overhead_stats *ovstats) -{ - return dyn ? Dynarr_memory_usage (dyn, ovstats) : 0; + struct usage_stats *ustats) +{ + return dyn ? Dynarr_memory_usage (dyn, ustats) : 0; } #endif /* MEMORY_USAGE_STATS */
--- a/src/redisplay.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/redisplay.h Mon Mar 29 21:28:13 2010 -0500 @@ -777,9 +777,9 @@ #ifdef MEMORY_USAGE_STATS int compute_display_line_dynarr_usage (display_line_dynarr *dyn, - struct overhead_stats *ovstats); + struct usage_stats *ustats); int compute_line_start_cache_dynarr_usage (line_start_cache_dynarr *dyn, - struct overhead_stats *ovstats); + struct usage_stats *ustats); #endif
--- a/src/scrollbar-gtk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/scrollbar-gtk.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,6 +3,7 @@ Copyright (C) 1994 Amdhal Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred <dkindred+@cmu.edu>. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -65,6 +66,7 @@ } xfree (instance->scrollbar_data); + instance->scrollbar_data = 0; } } @@ -474,23 +476,15 @@ } #ifdef MEMORY_USAGE_STATS -static int +static Bytecount gtk_compute_scrollbar_instance_usage (struct device *UNUSED (d), struct scrollbar_instance *inst, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { - int total = 0; + struct gtk_scrollbar_data *data = + (struct gtk_scrollbar_data *) inst->scrollbar_data; - while (inst) - { - struct gtk_scrollbar_data *data = - (struct gtk_scrollbar_data *) inst->scrollbar_data; - - total += malloced_storage_size (data, sizeof (*data), ovstats); - inst = inst->next; - } - - return total; + return malloced_storage_size (data, sizeof (*data), ustats); } #endif /* MEMORY_USAGE_STATS */
--- a/src/scrollbar-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/scrollbar-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,7 +3,7 @@ Copyright (C) 1994 Amdahl Corporation. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred <dkindred+@cmu.edu>. - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -102,6 +102,7 @@ assert (!NILP (ptr)); DestroyWindow (SCROLLBAR_MSW_HANDLE (sb)); xfree (sb->scrollbar_data); + sb->scrollbar_data = 0; } } @@ -423,23 +424,15 @@ #ifdef MEMORY_USAGE_STATS -static int +static Bytecount mswindows_compute_scrollbar_instance_usage (struct device *UNUSED (d), struct scrollbar_instance *inst, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { - int total = 0; + struct mswindows_scrollbar_data *data = + (struct mswindows_scrollbar_data *) inst->scrollbar_data; - while (inst) - { - struct mswindows_scrollbar_data *data = - (struct mswindows_scrollbar_data *) inst->scrollbar_data; - - total += malloced_storage_size (data, sizeof (*data), ovstats); - inst = inst->next; - } - - return total; + return malloced_storage_size (data, sizeof (*data), ustats); } #endif /* MEMORY_USAGE_STATS */
--- a/src/scrollbar-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/scrollbar-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -76,7 +76,10 @@ if (instance->scrollbar_data) { if (SCROLLBAR_X_NAME (instance)) - xfree (SCROLLBAR_X_NAME (instance)); + { + xfree (SCROLLBAR_X_NAME (instance)); + SCROLLBAR_X_NAME (instance) = 0; + } if (SCROLLBAR_X_WIDGET (instance)) { @@ -87,6 +90,7 @@ } xfree (instance->scrollbar_data); + instance->scrollbar_data = 0; } } @@ -694,23 +698,18 @@ #ifdef MEMORY_USAGE_STATS -static int +static Bytecount x_compute_scrollbar_instance_usage (struct device *UNUSED (d), struct scrollbar_instance *inst, - struct overhead_stats *ovstats) + struct usage_stats *ustats) { - int total = 0; + Bytecount total = 0; + struct x_scrollbar_data *data = + (struct x_scrollbar_data *) inst->scrollbar_data; - while (inst) - { - struct x_scrollbar_data *data = - (struct x_scrollbar_data *) inst->scrollbar_data; - - total += malloced_storage_size (data, sizeof (*data), ovstats); - total += malloced_storage_size (data->name, 1 + strlen (data->name), - ovstats); - inst = inst->next; - } + total += malloced_storage_size (data, sizeof (*data), ustats); + total += malloced_storage_size (data->name, 1 + strlen (data->name), + ustats); return total; }
--- a/src/scrollbar.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/scrollbar.c Mon Mar 29 21:28:13 2010 -0500 @@ -3,7 +3,7 @@ Copyright (C) 1995 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. Copyright (C) 1995 Darrell Kindred <dkindred+@cmu.edu>. - Copyright (C) 2003 Ben Wing. + Copyright (C) 2003, 2010 Ben Wing. This file is part of XEmacs. @@ -96,12 +96,10 @@ return Qnil; } -DEFINE_LRECORD_IMPLEMENTATION ("scrollbar-instance", scrollbar_instance, - 0, /*dumpable-flag*/ - mark_scrollbar_instance, - internal_object_printer, 0, 0, 0, - scrollbar_instance_description, - struct scrollbar_instance); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("scrollbar-instance", scrollbar_instance, + mark_scrollbar_instance, + scrollbar_instance_description, + struct scrollbar_instance); static void free_scrollbar_instance (struct scrollbar_instance *instance, @@ -114,7 +112,7 @@ struct device *d = XDEVICE (frame->device); MAYBE_DEVMETH (d, free_scrollbar_instance, (instance)); - /* not worth calling free_managed_lcrecord() -- scrollbar instances + /* not worth calling free_normal_lisp_object() -- scrollbar instances are not created that frequently and it's dangerous. */ } } @@ -198,9 +196,8 @@ create_scrollbar_instance (struct frame *f, int vertical) { struct device *d = XDEVICE (f->device); - struct scrollbar_instance *instance = - ALLOC_LCRECORD_TYPE (struct scrollbar_instance, - &lrecord_scrollbar_instance); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (scrollbar_instance); + struct scrollbar_instance *instance = XSCROLLBAR_INSTANCE (obj); MAYBE_DEVMETH (d, create_scrollbar_instance, (f, vertical, instance)); @@ -260,25 +257,43 @@ #ifdef MEMORY_USAGE_STATS -int -compute_scrollbar_instance_usage (struct device *d, - struct scrollbar_instance *inst, - struct overhead_stats *ovstats) +struct scrollbar_instance_stats { - int total = 0; + struct usage_stats u; + Bytecount device_data; +}; - if (HAS_DEVMETH_P(d, compute_scrollbar_instance_usage)) - total += DEVMETH (d, compute_scrollbar_instance_usage, (d, inst, ovstats)); +Bytecount +compute_all_scrollbar_instance_usage (struct scrollbar_instance *inst) +{ + Bytecount total = 0; while (inst) { - total += LISPOBJ_STORAGE_SIZE (inst, sizeof (*inst), ovstats); + total += lisp_object_memory_usage (wrap_scrollbar_instance (inst)); inst = inst->next; } return total; } +static void +scrollbar_instance_memory_usage (Lisp_Object scrollbar_instance, + struct generic_usage_stats *gustats) +{ + struct scrollbar_instance_stats *stats = + (struct scrollbar_instance_stats *) gustats; + struct scrollbar_instance *inst = XSCROLLBAR_INSTANCE (scrollbar_instance); + struct device *d = FRAME_XDEVICE (inst->mirror->frame); + Bytecount total = 0; + + if (HAS_DEVMETH_P (d, compute_scrollbar_instance_usage)) + total += DEVMETH (d, compute_scrollbar_instance_usage, (d, inst, + &gustats->u)); + + stats->device_data = total; +} + #endif /* MEMORY_USAGE_STATS */ void @@ -926,9 +941,16 @@ /************************************************************************/ void +scrollbar_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (scrollbar_instance, memory_usage); +#endif +} +void syms_of_scrollbar (void) { - INIT_LRECORD_IMPLEMENTATION (scrollbar_instance); + INIT_LISP_OBJECT (scrollbar_instance); DEFSYMBOL (Qscrollbar_line_up); DEFSYMBOL (Qscrollbar_line_down); @@ -964,6 +986,12 @@ void vars_of_scrollbar (void) { +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_PROPERTY + (scrollbar_instance, memusage_stats_list, + list1 (intern ("device-data"))); +#endif /* MEMORY_USAGE_STATS */ + DEFVAR_LISP ("scrollbar-pointer-glyph", &Vscrollbar_pointer_glyph /* *The shape of the mouse-pointer when over a scrollbar. This is a glyph; use `set-glyph-image' to change it.
--- a/src/scrollbar.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/scrollbar.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,5 +1,6 @@ /* Define scrollbar instance. Copyright (C) 1994, 1995 Board of Trustees, University of Illinois. + Copyright (C) 2010 Ben Wing. This file is part of XEmacs. @@ -27,7 +28,7 @@ struct scrollbar_instance { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Used by the frame caches. */ struct scrollbar_instance *next; @@ -47,7 +48,7 @@ void *scrollbar_data; }; -DECLARE_LRECORD (scrollbar_instance, struct scrollbar_instance); +DECLARE_LISP_OBJECT (scrollbar_instance, struct scrollbar_instance); #define XSCROLLBAR_INSTANCE(x) XRECORD (x, scrollbar_instance, struct scrollbar_instance) #define wrap_scrollbar_instance(p) wrap_record (p, scrollbar_instance) #define SCROLLBAR_INSTANCEP(x) RECORDP (x, scrollbar_instance) @@ -65,9 +66,8 @@ struct window_mirror *mirror, int active, int horiz_only); #ifdef MEMORY_USAGE_STATS -int compute_scrollbar_instance_usage (struct device *d, - struct scrollbar_instance *inst, - struct overhead_stats *ovstats); +Bytecount compute_all_scrollbar_instance_usage (struct scrollbar_instance * + inst); #endif extern Lisp_Object Vscrollbar_width, Vscrollbar_height;
--- a/src/search.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/search.c Mon Mar 29 21:28:13 2010 -0500 @@ -2801,8 +2801,8 @@ Lisp_Object before, after; speccount = specpdl_depth (); - before = Fsubstring (string, Qzero, make_int (search_regs.start[sub])); - after = Fsubstring (string, make_int (search_regs.end[sub]), Qnil); + before = Fsubseq (string, Qzero, make_int (search_regs.start[sub])); + after = Fsubseq (string, make_int (search_regs.end[sub]), Qnil); /* Do case substitution into REPLACEMENT if desired. */ if (NILP (literal)) @@ -2888,13 +2888,12 @@ Lisp_Object literal_text = Qnil; Lisp_Object substring = Qnil; if (literal_end != literal_start) - literal_text = Fsubstring (replacement, - make_int (literal_start), - make_int (literal_end)); + literal_text = Fsubseq (replacement, + make_int (literal_start), + make_int (literal_end)); if (substart >= 0 && subend != substart) - substring = Fsubstring (string, - make_int (substart), - make_int (subend)); + substring = Fsubseq (string, make_int (substart), + make_int (subend)); if (!NILP (literal_text) || !NILP (substring)) accum = concat3 (accum, literal_text, substring); literal_start = strpos + 1; @@ -2903,9 +2902,9 @@ if (strpos != literal_start) /* some literal text at end to be inserted */ - replacement = concat2 (accum, Fsubstring (replacement, - make_int (literal_start), - make_int (strpos))); + replacement = concat2 (accum, Fsubseq (replacement, + make_int (literal_start), + make_int (strpos))); else replacement = accum; }
--- a/src/select-x.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/select-x.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* X Selection processing for XEmacs Copyright (C) 1990, 1991, 1992, 1993, 1994 Free Software Foundation, Inc. - Copyright (C) 2001, 2002 Ben Wing. + Copyright (C) 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -691,10 +691,8 @@ event->type = 0; /* Data need not have been allocated; cf. select-convert-to-delete in lisp/select.el . */ - if ((Rawbyte *)0 != data) - { + if (data) xfree (data); - } } unbind_to (count);
--- a/src/specifier.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/specifier.c Mon Mar 29 21:28:13 2010 -0500 @@ -280,8 +280,8 @@ Lisp_Object the_specs; if (print_readably) - printing_unreadable_object ("#<%s-specifier 0x%x>", - sp->methods->name, sp->header.uid); + printing_unreadable_object_fmt ("#<%s-specifier 0x%x>", + sp->methods->name, LISP_OBJECT_UID (obj)); write_fmt_string (printcharfun, "#<%s-specifier global=", sp->methods->name); #if 0 @@ -302,16 +302,15 @@ write_fmt_string_lisp (printcharfun, " fallback=%S", 1, sp->fallback); } unbind_to (count); - write_fmt_string (printcharfun, " 0x%x>", sp->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } #ifndef NEW_GC static void -finalize_specifier (void *header, int for_disksave) +finalize_specifier (Lisp_Object obj) { - Lisp_Specifier *sp = (Lisp_Specifier *) header; - /* don't be snafued by the disksave finalization. */ - if (!for_disksave && !GHOST_SPECIFIER_P(sp) && sp->caching) + Lisp_Specifier *sp = XSPECIFIER (obj); + if (!GHOST_SPECIFIER_P(sp) && sp->caching) { xfree (sp->caching); sp->caching = 0; @@ -372,9 +371,9 @@ } static Bytecount -sizeof_specifier (const void *header) +sizeof_specifier (Lisp_Object obj) { - const Lisp_Specifier *p = (const Lisp_Specifier *) header; + const Lisp_Specifier *p = XSPECIFIER (obj); return aligned_sizeof_specifier (GHOST_SPECIFIER_P (p) ? 0 : p->methods->extra_data_size); @@ -395,12 +394,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("specifier-caching", - specifier_caching, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - specifier_caching_description_1, - struct specifier_caching); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("specifier-caching", specifier_caching, + 0, specifier_caching_description_1, + struct specifier_caching); #else /* not NEW_GC */ static const struct sized_memory_description specifier_caching_description = { sizeof (struct specifier_caching), @@ -446,24 +442,13 @@ 0, specifier_empty_extra_description_1 }; -#ifdef NEW_GC -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier, - 1, /*dumpable-flag*/ - mark_specifier, print_specifier, - 0, specifier_equal, specifier_hash, - specifier_description, - sizeof_specifier, - Lisp_Specifier); -#else /* not NEW_GC */ -DEFINE_LRECORD_SEQUENCE_IMPLEMENTATION ("specifier", specifier, - 1, /*dumpable-flag*/ - mark_specifier, print_specifier, - finalize_specifier, - specifier_equal, specifier_hash, - specifier_description, - sizeof_specifier, - Lisp_Specifier); -#endif /* not NEW_GC */ +DEFINE_DUMPABLE_SIZABLE_LISP_OBJECT ("specifier", specifier, + mark_specifier, print_specifier, + IF_OLD_GC (finalize_specifier), + specifier_equal, specifier_hash, + specifier_description, + sizeof_specifier, + Lisp_Specifier); /************************************************************************/ /* Creating specifiers */ @@ -526,10 +511,9 @@ make_specifier_internal (struct specifier_methods *spec_meths, Bytecount data_size, int call_create_meth) { - Lisp_Object specifier; - Lisp_Specifier *sp = (Lisp_Specifier *) - BASIC_ALLOC_LCRECORD (aligned_sizeof_specifier (data_size), - &lrecord_specifier); + Lisp_Object specifier = + ALLOC_SIZED_LISP_OBJECT (aligned_sizeof_specifier (data_size), specifier); + Lisp_Specifier *sp = XSPECIFIER (specifier); sp->methods = spec_meths; sp->global_specs = Qnil; @@ -542,7 +526,6 @@ sp->caching = 0; sp->next_specifier = Vall_specifiers; - specifier = wrap_specifier (sp); Vall_specifiers = specifier; if (call_create_meth) @@ -3394,8 +3377,7 @@ if (!sp->caching) #ifdef NEW_GC - sp->caching = alloc_lrecord_type (struct specifier_caching, - &lrecord_specifier_caching); + sp->caching = XSPECIFIER_CACHING (ALLOC_NORMAL_LISP_OBJECT (specifier_caching)); #else /* not NEW_GC */ sp->caching = xnew_and_zero (struct specifier_caching); #endif /* not NEW_GC */ @@ -3750,9 +3732,9 @@ void syms_of_specifier (void) { - INIT_LRECORD_IMPLEMENTATION (specifier); + INIT_LISP_OBJECT (specifier); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (specifier_caching); + INIT_LISP_OBJECT (specifier_caching); #endif /* NEW_GC */ DEFSYMBOL (Qspecifierp);
--- a/src/specifier.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/specifier.h Mon Mar 29 21:28:13 2010 -0500 @@ -220,7 +220,7 @@ struct Lisp_Specifier { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; struct specifier_methods *methods; /* we keep a chained list of all current specifiers, for GC cleanup @@ -259,7 +259,7 @@ }; typedef struct Lisp_Specifier Lisp_Specifier; -DECLARE_LRECORD (specifier, Lisp_Specifier); +DECLARE_LISP_OBJECT (specifier, Lisp_Specifier); #define XSPECIFIER(x) XRECORD (x, specifier, Lisp_Specifier) #define wrap_specifier(p) wrap_record (p, specifier) #define SPECIFIERP(x) RECORDP (x, specifier) @@ -428,7 +428,7 @@ struct specifier_caching { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ int offset_into_struct_window; void (*value_changed_in_window) (Lisp_Object specifier, struct window *w, @@ -440,7 +440,7 @@ }; #ifdef NEW_GC -DECLARE_LRECORD (specifier_caching, struct specifier_caching); +DECLARE_LISP_OBJECT (specifier_caching, struct specifier_caching); #define XSPECIFIER_CACHING(x) \ XRECORD (x, specifier_caching, struct specifier_caching) #define wrap_specifier_caching(p) \
--- a/src/symbols.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/symbols.c Mon Mar 29 21:28:13 2010 -0500 @@ -141,15 +141,10 @@ return external_remprop (&XSYMBOL (symbol)->plist, property, 0, ERROR_ME); } -DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS ("symbol", symbol, - 1, /*dumpable-flag*/ - mark_symbol, print_symbol, - 0, 0, 0, symbol_description, - symbol_getprop, - symbol_putprop, - symbol_remprop, - Fsymbol_plist, - Lisp_Symbol); +DEFINE_DUMPABLE_FROB_BLOCK_LISP_OBJECT ("symbol", symbol, + mark_symbol, print_symbol, + 0, 0, 0, symbol_description, + Lisp_Symbol); /**********************************************************************/ /* Intern */ @@ -1105,47 +1100,43 @@ int UNUSED (escapeflag)) { write_fmt_string (printcharfun, - "#<INTERNAL OBJECT (XEmacs bug?) (%s type %d) 0x%lx>", + "#<INTERNAL OBJECT (XEmacs bug?) (%s type %d) 0x%x>", XRECORD_LHEADER_IMPLEMENTATION (obj)->name, XSYMBOL_VALUE_MAGIC_TYPE (obj), - (long) XPNTR (obj)); + LISP_OBJECT_UID (obj)); } static const struct memory_description symbol_value_forward_description[] = { { XD_END } }; -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-forward", - symbol_value_forward, - 1, /*dumpable-flag*/ - 0, - print_symbol_value_magic, 0, 0, 0, - symbol_value_forward_description, - struct symbol_value_forward); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-buffer-local", - symbol_value_buffer_local, - 1, /*dumpable-flag*/ - mark_symbol_value_buffer_local, - print_symbol_value_magic, 0, 0, 0, - symbol_value_buffer_local_description, - struct symbol_value_buffer_local); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-lisp-magic", - symbol_value_lisp_magic, - 1, /*dumpable-flag*/ - mark_symbol_value_lisp_magic, - print_symbol_value_magic, 0, 0, 0, - symbol_value_lisp_magic_description, - struct symbol_value_lisp_magic); - -DEFINE_LRECORD_IMPLEMENTATION ("symbol-value-varalias", - symbol_value_varalias, - 1, /*dumpable-flag*/ - mark_symbol_value_varalias, - print_symbol_value_magic, 0, 0, 0, - symbol_value_varalias_description, - struct symbol_value_varalias); +DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-forward", + symbol_value_forward, + 0, + print_symbol_value_magic, 0, 0, 0, + symbol_value_forward_description, + struct symbol_value_forward); + +DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-buffer-local", + symbol_value_buffer_local, + mark_symbol_value_buffer_local, + print_symbol_value_magic, 0, 0, 0, + symbol_value_buffer_local_description, + struct symbol_value_buffer_local); + +DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-lisp-magic", + symbol_value_lisp_magic, + mark_symbol_value_lisp_magic, + print_symbol_value_magic, 0, 0, 0, + symbol_value_lisp_magic_description, + struct symbol_value_lisp_magic); + +DEFINE_DUMPABLE_LISP_OBJECT ("symbol-value-varalias", + symbol_value_varalias, + mark_symbol_value_varalias, + print_symbol_value_magic, 0, 0, 0, + symbol_value_varalias_description, + struct symbol_value_varalias); /* Getting and setting values of symbols */ @@ -2293,8 +2284,8 @@ { struct symbol_value_buffer_local *bfwd - = ALLOC_LCRECORD_TYPE (struct symbol_value_buffer_local, - &lrecord_symbol_value_buffer_local); + = XSYMBOL_VALUE_BUFFER_LOCAL + (ALLOC_NORMAL_LISP_OBJECT (symbol_value_buffer_local)); Lisp_Object foo; bfwd->magic.type = SYMVAL_BUFFER_LOCAL; @@ -2401,8 +2392,8 @@ } /* Make sure variable is set up to hold per-buffer values */ - bfwd = ALLOC_LCRECORD_TYPE (struct symbol_value_buffer_local, - &lrecord_symbol_value_buffer_local); + bfwd = XSYMBOL_VALUE_BUFFER_LOCAL + (ALLOC_NORMAL_LISP_OBJECT (symbol_value_buffer_local)); bfwd->magic.type = SYMVAL_SOME_BUFFER_LOCAL; bfwd->current_buffer = Qnil; @@ -3193,8 +3184,9 @@ valcontents = XSYMBOL (variable)->value; if (!SYMBOL_VALUE_LISP_MAGIC_P (valcontents)) { - bfwd = ALLOC_LCRECORD_TYPE (struct symbol_value_lisp_magic, - &lrecord_symbol_value_lisp_magic); + bfwd = + XSYMBOL_VALUE_LISP_MAGIC + (ALLOC_NORMAL_LISP_OBJECT (symbol_value_lisp_magic)); bfwd->magic.type = SYMVAL_LISP_MAGIC; for (i = 0; i < MAGIC_HANDLER_MAX; i++) { @@ -3411,8 +3403,8 @@ invalid_change ("Variable is magic and cannot be aliased", variable); reject_constant_symbols (variable, Qunbound, 0, Qt); - bfwd = ALLOC_LCRECORD_TYPE (struct symbol_value_varalias, - &lrecord_symbol_value_varalias); + bfwd = + XSYMBOL_VALUE_VARALIAS (ALLOC_NORMAL_LISP_OBJECT (symbol_value_varalias)); bfwd->magic.type = SYMVAL_VARALIAS; bfwd->aliasee = aliased; bfwd->shadowed = valcontents; @@ -3524,30 +3516,37 @@ 1, /* lisp_readonly bit */ }, 0, /* next */ - 0, /* uid */ - 0, /* free */ }, 0, /* value */ SYMVAL_UNBOUND_MARKER }; #endif /* not NEW_GC */ +static void +reinit_symbol_objects_early (void) +{ + OBJECT_HAS_METHOD (symbol, getprop); + OBJECT_HAS_METHOD (symbol, putprop); + OBJECT_HAS_METHOD (symbol, remprop); + OBJECT_HAS_NAMED_METHOD (symbol, plist, Fsymbol_plist); +} + void init_symbols_once_early (void) { - INIT_LRECORD_IMPLEMENTATION (symbol); - INIT_LRECORD_IMPLEMENTATION (symbol_value_forward); - INIT_LRECORD_IMPLEMENTATION (symbol_value_buffer_local); - INIT_LRECORD_IMPLEMENTATION (symbol_value_lisp_magic); - INIT_LRECORD_IMPLEMENTATION (symbol_value_varalias); - - reinit_symbols_early (); + INIT_LISP_OBJECT (symbol); + INIT_LISP_OBJECT (symbol_value_forward); + INIT_LISP_OBJECT (symbol_value_buffer_local); + INIT_LISP_OBJECT (symbol_value_lisp_magic); + INIT_LISP_OBJECT (symbol_value_varalias); + + reinit_symbol_objects_early (); /* Bootstrapping problem: Qnil isn't set when make_string_nocopy is called the first time. */ Qnil = Fmake_symbol (make_string_nocopy ((const Ibyte *) "nil", 3)); XSTRING_PLIST (XSYMBOL (Qnil)->name) = Qnil; - XSYMBOL (Qnil)->value = Qnil; /* Nihil ex nihil */ + XSYMBOL (Qnil)->value = Qnil; /* Nihil ex nihilo */ XSYMBOL (Qnil)->plist = Qnil; Vobarray = make_vector (OBARRAY_SIZE, Qzero); @@ -3596,6 +3595,7 @@ void reinit_symbols_early (void) { + reinit_symbol_objects_early (); } static void
--- a/src/symeval.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/symeval.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Definitions of symbol-value forwarding for XEmacs Lisp interpreter. Copyright (C) 1985, 1986, 1987, 1992, 1993 Free Software Foundation, Inc. - Copyright (C) 2000, 2001, 2002 Ben Wing. + Copyright (C) 2000, 2001, 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -77,7 +77,7 @@ struct symbol_value_magic { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; void *value; enum symbol_value_type type; }; @@ -141,7 +141,7 @@ int (*magicfun) (Lisp_Object sym, Lisp_Object *val, Lisp_Object in_object, int flags); }; -DECLARE_LRECORD (symbol_value_forward, struct symbol_value_forward); +DECLARE_LISP_OBJECT (symbol_value_forward, struct symbol_value_forward); #define XSYMBOL_VALUE_FORWARD(x) \ XRECORD (x, symbol_value_forward, struct symbol_value_forward) #define symbol_value_forward_forward(m) ((void *)((m)->magic.value)) @@ -228,7 +228,7 @@ Lisp_Object current_buffer; Lisp_Object current_alist_element; }; -DECLARE_LRECORD (symbol_value_buffer_local, struct symbol_value_buffer_local); +DECLARE_LISP_OBJECT (symbol_value_buffer_local, struct symbol_value_buffer_local); #define XSYMBOL_VALUE_BUFFER_LOCAL(x) \ XRECORD (x, symbol_value_buffer_local, struct symbol_value_buffer_local) #define SYMBOL_VALUE_BUFFER_LOCAL_P(x) RECORDP (x, symbol_value_buffer_local) @@ -253,7 +253,7 @@ Lisp_Object harg[MAGIC_HANDLER_MAX]; Lisp_Object shadowed; }; -DECLARE_LRECORD (symbol_value_lisp_magic, struct symbol_value_lisp_magic); +DECLARE_LISP_OBJECT (symbol_value_lisp_magic, struct symbol_value_lisp_magic); #define XSYMBOL_VALUE_LISP_MAGIC(x) \ XRECORD (x, symbol_value_lisp_magic, struct symbol_value_lisp_magic) #define SYMBOL_VALUE_LISP_MAGIC_P(x) RECORDP (x, symbol_value_lisp_magic) @@ -266,7 +266,7 @@ Lisp_Object aliasee; Lisp_Object shadowed; }; -DECLARE_LRECORD (symbol_value_varalias, struct symbol_value_varalias); +DECLARE_LISP_OBJECT (symbol_value_varalias, struct symbol_value_varalias); #define XSYMBOL_VALUE_VARALIAS(x) \ XRECORD (x, symbol_value_varalias, struct symbol_value_varalias) #define SYMBOL_VALUE_VARALIAS_P(x) RECORDP (x, symbol_value_varalias) @@ -401,8 +401,7 @@ do \ { \ struct symbol_value_forward *I_hate_C = \ - alloc_lrecord_type (struct symbol_value_forward, \ - &lrecord_symbol_value_forward); \ + XSYMBOL_VALUE_FORWARD (ALLOC_NORMAL_LISP_OBJECT (symbol_value_forward)); \ /* mcpro ((Lisp_Object) I_hate_C);*/ \ \ MARK_LRECORD_AS_LISP_READONLY (I_hate_C); \ @@ -426,11 +425,8 @@ 1, /* mark bit */ \ 1, /* c_readonly bit */ \ 1, /* lisp_readonly bit */ \ - 0 /* unused */ \ }, \ 0, /* next */ \ - 0, /* uid */ \ - 0 /* free */ \ }, \ c_location, \ forward_type \ @@ -489,7 +485,7 @@ void flush_all_buffer_local_cache (void); struct multiple_value { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Elemcount count; Elemcount allocated_count; Elemcount first_desired; @@ -497,7 +493,7 @@ }; typedef struct multiple_value multiple_value; -DECLARE_LRECORD (multiple_value, multiple_value); +DECLARE_LISP_OBJECT (multiple_value, multiple_value); #define MULTIPLE_VALUEP(x) RECORDP (x, multiple_value) #define XMULTIPLE_VALUE(x) XRECORD (x, multiple_value, multiple_value)
--- a/src/symsinit.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/symsinit.h Mon Mar 29 21:28:13 2010 -0500 @@ -72,6 +72,7 @@ void syms_of_abbrev (void); void syms_of_alloc (void); +void syms_of_array (void); void syms_of_balloon_x (void); void syms_of_buffer (void); void syms_of_bytecode (void); @@ -147,6 +148,7 @@ void syms_of_intl_x (void); void syms_of_keymap (void); void syms_of_lread (void); +void syms_of_lstream (void); void syms_of_macros (void); void syms_of_marker (void); void syms_of_mc_alloc (void); @@ -202,6 +204,23 @@ void syms_of_win32 (void); void syms_of_window (void); +/* Initialize dynamic properties of objects (i.e. those properties not + initialized statically through a DEFINE_*_LISP_OBJECT declaration). + Dump time and post-pdump-load-time. */ + +void buffer_objects_create (void); +void casetab_objects_create (void); +void extent_objects_create (void); +void face_objects_create (void); +void frame_objects_create (void); +void glyph_objects_create (void); +void hash_table_objects_create (void); +void lstream_objects_create (void); +void mule_charset_objects_create (void); +void scrollbar_objects_create (void); +void ui_gtk_objects_create (void); +void window_objects_create (void); + /* Initialize the console types (dump-time only for console_type_(), post-pdump-load-time only for reinit_). */ @@ -329,6 +348,7 @@ void vars_of_abbrev (void); void vars_of_alloc (void); +void reinit_vars_of_alloc (void); void vars_of_balloon_x (void); void vars_of_buffer (void); void reinit_vars_of_buffer (void); @@ -336,6 +356,7 @@ void reinit_vars_of_bytecode (void); void vars_of_callint (void); EXTERN_C void vars_of_canna_api (void); +void vars_of_casetab (void); void vars_of_chartab (void); void vars_of_cmdloop (void); void vars_of_cmds (void); @@ -366,6 +387,7 @@ void vars_of_dragdrop (void); void vars_of_editfns (void); EXTERN_C void vars_of_eldap (void); +void vars_of_elhash (void); void vars_of_emacs (void); void vars_of_eval (void); void reinit_vars_of_eval (void); @@ -382,7 +404,6 @@ void vars_of_events (void); void reinit_vars_of_events (void); void vars_of_extents (void); -void reinit_vars_of_extents (void); void vars_of_faces (void); void vars_of_file_coding (void); void reinit_vars_of_file_coding (void);
--- a/src/syntax.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/syntax.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* XEmacs routines to deal with syntax tables; also word and list parsing. Copyright (C) 1985-1994 Free Software Foundation, Inc. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 2001, 2002, 2003 Ben Wing. + Copyright (C) 2001, 2002, 2003, 2010 Ben Wing. This file is part of XEmacs. @@ -259,11 +259,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("syntax-cache", syntax_cache, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - syntax_cache_description_1, - Lisp_Syntax_Cache); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("syntax-cache", syntax_cache, + 0, syntax_cache_description_1, + Lisp_Syntax_Cache); #else /* not NEW_GC */ const struct sized_memory_description syntax_cache_description = { @@ -523,8 +521,7 @@ { struct syntax_cache *cache; #ifdef NEW_GC - buf->syntax_cache = alloc_lrecord_type (struct syntax_cache, - &lrecord_syntax_cache); + buf->syntax_cache = XSYNTAX_CACHE (ALLOC_NORMAL_LISP_OBJECT (syntax_cache)); #else /* not NEW_GC */ buf->syntax_cache = xnew_and_zero (struct syntax_cache); #endif /* not NEW_GC */ @@ -545,8 +542,11 @@ uninit_buffer_syntax_cache (struct buffer *UNUSED_IF_NEW_GC (buf)) { #ifndef NEW_GC - xfree (buf->syntax_cache); - buf->syntax_cache = 0; + if (buf->syntax_cache) + { + xfree (buf->syntax_cache); + buf->syntax_cache = 0; + } #endif /* not NEW_GC */ } @@ -2393,7 +2393,7 @@ syms_of_syntax (void) { #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (syntax_cache); + INIT_LISP_OBJECT (syntax_cache); #endif /* NEW_GC */ DEFSYMBOL (Qsyntax_table_p); DEFSYMBOL (Qsyntax_table);
--- a/src/syntax.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/syntax.h Mon Mar 29 21:28:13 2010 -0500 @@ -296,7 +296,7 @@ struct syntax_cache { #ifdef NEW_GC - struct lrecord_header header; + NORMAL_LISP_OBJECT_HEADER header; #endif /* NEW_GC */ int use_code; /* Whether to use syntax_code or syntax_table. This is set @@ -339,7 +339,7 @@ #ifdef NEW_GC typedef struct syntax_cache Lisp_Syntax_Cache; -DECLARE_LRECORD (syntax_cache, Lisp_Syntax_Cache); +DECLARE_LISP_OBJECT (syntax_cache, Lisp_Syntax_Cache); #define XSYNTAX_CACHE(x) \ XRECORD (x, syntax_cache, Lisp_Syntax_Cache)
--- a/src/tests.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/tests.c Mon Mar 29 21:28:13 2010 -0500 @@ -49,7 +49,7 @@ ()) { void *ptr; Bytecount len; - Lisp_Object string, opaque, conversion_result = Qnil; + Lisp_Object string = Qnil, opaque = Qnil, conversion_result = Qnil; Ibyte int_foo[] = "\n\nfoo\nbar"; Extbyte ext_unix[]= "\n\nfoo\nbar"; @@ -72,6 +72,20 @@ Lisp_Object string_latin1 = make_string (int_latin1, sizeof (int_latin1) - 1); int autodetect_eol_p = !NILP (Fsymbol_value (intern ("eol-detection-enabled-p"))); + struct gcpro gcpro1, gcpro2, gcpro3, gcpro4, gcpro5; + struct gcpro ngcpro1, ngcpro2, ngcpro3; +#ifdef MULE + struct gcpro ngcpro4; +#endif + + /* DFC conversion inhibits GC, but we have a call2() below which calls + Lisp, which can trigger GC, so we need to GC-protect everything here. */ + GCPRO5 (string, opaque, conversion_result, opaque_dos, string_foo); +#ifdef MULE + NGCPRO4 (string_latin2, opaque_latin, opaque0_latin, string_latin1); +#else + NGCPRO3 (opaque_latin, opaque0_latin, string_latin1); +#endif /* Check for expected strings before and after conversion. Conversions depend on whether MULE is defined. */ @@ -541,6 +555,8 @@ Qbinary); DFC_CHECK_DATA (ptr, len, ext_dos, "DOS Lisp opaque, ALLOCA, binary"); + NUNGCPRO; + UNGCPRO; return conversion_result; }
--- a/src/text.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/text.h Mon Mar 29 21:28:13 2010 -0500 @@ -47,6 +47,33 @@ BEGIN_C_DECLS +/************************************************************************/ +/* A short intro to the format of text and of characters */ +/************************************************************************/ + +/* + "internally formatted text" and the term "internal format" in + general are likely to refer to the format of text in buffers and + strings; "externally formatted text" and the term "external format" + refer to any text format used in the O.S. or elsewhere outside of + XEmacs. The format of text and of a character are related and + there must be a one-to-one relationship (hopefully through a + relatively simple algorithmic means of conversion) between a string + of text and an equivalent array of characters, but the conversion + between the two is NOT necessarily trivial. + + In a non-Mule XEmacs, allowed characters are numbered 0 through + 255, where no fixed meaning is assigned to them, but (when + representing text, rather than bytes in a binary file) in practice + the lower half represents ASCII and the upper half some other 8-bit + character set (chosen by setting the font, case tables, syntax + tables, etc. appropriately for the character set through ad-hoc + means such as the `iso-8859-1' file and the + `standard-display-european' function). + + For more info, see `text.c' and the Internals Manual. +*/ + /* ---------------------------------------------------------------------- */ /* Super-basic character properties */ /* ---------------------------------------------------------------------- */ @@ -166,6 +193,29 @@ #endif /* not MULE */ +#ifdef MULE + +MODULE_API int non_ascii_valid_ichar_p (Ichar ch); + +/* Return whether the given Ichar is valid. + */ + +DECLARE_INLINE_HEADER ( +int +valid_ichar_p (Ichar ch) +) +{ + return (! (ch & ~0xFF)) || non_ascii_valid_ichar_p (ch); +} + +#else /* not MULE */ + +/* This works when CH is negative, and correctly returns non-zero only when CH + is in the range [0, 255], inclusive. */ +#define valid_ichar_p(ch) (! (ch & ~0xFF)) + +#endif /* not MULE */ + /* For more discussion, see text.c, "handling non-default formats" */ typedef enum internal_format @@ -2010,9 +2060,15 @@ if ((ei)->mallocp_) \ { \ if ((ei)->data_) \ - xfree ((ei)->data_); \ + { \ + xfree ((ei)->data_); \ + (ei)->data_ = 0; \ + } \ if ((ei)->extdata_) \ - xfree ((ei)->extdata_); \ + { \ + xfree ((ei)->extdata_); \ + (ei)->extdata_ = 0; \ + } \ eiinit_malloc (ei); \ } \ else \
--- a/src/toolbar-msw.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/toolbar-msw.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* toolbar implementation -- mswindows interface. Copyright (C) 1995 Board of Trustees, University of Illinois. Copyright (C) 1995 Sun Microsystems, Inc. - Copyright (C) 1995, 1996, 2002 Ben Wing. + Copyright (C) 1995, 1996, 2002, 2010 Ben Wing. Copyright (C) 1996 Chuck Thompson. Copyright (C) 1998 Andy Piper. @@ -52,39 +52,18 @@ #define TOOLBAR_ITEM_ID_BITS(x) (((x) & 0x3FFF) | 0x4000) #define TOOLBAR_ID_BIAS 16 #define TOOLBAR_HANDLE(f,p) \ -GetDlgItem(FRAME_MSWINDOWS_HANDLE(f), TOOLBAR_ID_BIAS + p) +GetDlgItem (FRAME_MSWINDOWS_HANDLE (f), TOOLBAR_ID_BIAS + p) #define MSWINDOWS_BUTTON_SHADOW_THICKNESS 2 #define MSWINDOWS_BLANK_SIZE 5 #define MSWINDOWS_MINIMUM_TOOLBAR_SIZE 8 static void -mswindows_move_toolbar (struct frame *f, enum toolbar_pos pos); - -#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ - do { \ - switch (pos) \ - { \ - case TOP_TOOLBAR: \ - (frame)->top_toolbar_was_visible = flag; \ - break; \ - case BOTTOM_TOOLBAR: \ - (frame)->bottom_toolbar_was_visible = flag; \ - break; \ - case LEFT_TOOLBAR: \ - (frame)->left_toolbar_was_visible = flag; \ - break; \ - case RIGHT_TOOLBAR: \ - (frame)->right_toolbar_was_visible = flag; \ - break; \ - default: \ - ABORT (); \ - } \ - } while (0) +mswindows_move_toolbar (struct frame *f, enum edge_pos pos); static int allocate_toolbar_item_id (struct frame *f, struct toolbar_button *button, - enum toolbar_pos UNUSED (pos)) + enum edge_pos UNUSED (pos)) { /* hmm what do we generate an id based on */ int id = TOOLBAR_ITEM_ID_BITS (internal_hash (button->callback, 0)); @@ -97,7 +76,7 @@ } static void -mswindows_clear_toolbar (struct frame *f, enum toolbar_pos pos, +mswindows_clear_toolbar (struct frame *f, enum edge_pos pos, int UNUSED (thickness_change)) { HIMAGELIST ilist = NULL; @@ -123,11 +102,11 @@ qxeSendMessage (toolbarwnd, TB_GETIMAGELIST, 0, (LONG) &ilist); if (ilist) { - ImageList_Destroy(ilist); + ImageList_Destroy (ilist); } qxeSendMessage (toolbarwnd, TB_SETIMAGELIST, 0, (LPARAM)NULL); - ShowWindow(toolbarwnd, SW_HIDE); + ShowWindow (toolbarwnd, SW_HIDE); } FRAME_MSWINDOWS_TOOLBAR_CHECKSUM (f, pos) = 0; @@ -135,7 +114,7 @@ } static void -mswindows_output_toolbar (struct frame *f, enum toolbar_pos pos) +mswindows_output_toolbar (struct frame *f, enum edge_pos pos) { int x, y, bar_width, bar_height, vert; int width=-1, height=-1, bmwidth=0, bmheight=0, maxbmwidth, maxbmheight; @@ -208,7 +187,7 @@ struct toolbar_button *tb = XTOOLBAR_BUTTON (button); checksum = HASH5 (checksum, - internal_hash (get_toolbar_button_glyph(w, tb), 0), + internal_hash (get_toolbar_button_glyph (w, tb), 0), internal_hash (tb->callback, 0), width, LISP_HASH (w->toolbar_buttons_captioned_p)); @@ -217,7 +196,7 @@ } /* only rebuild if something has changed */ - if (!toolbarwnd || FRAME_MSWINDOWS_TOOLBAR_CHECKSUM(f,pos)!=checksum) + if (!toolbarwnd || FRAME_MSWINDOWS_TOOLBAR_CHECKSUM (f,pos)!=checksum) { /* remove the old one */ mswindows_clear_toolbar (f, pos, 0); @@ -401,7 +380,7 @@ /* finally populate with images */ if (qxeSendMessage (toolbarwnd, TB_BUTTONSTRUCTSIZE, - (WPARAM)sizeof(TBBUTTON), (LPARAM)0) == -1) + (WPARAM)sizeof (TBBUTTON), (LPARAM)0) == -1) { mswindows_clear_toolbar (f, pos, 0); gui_error ("couldn't set button structure size", Qunbound); @@ -446,7 +425,7 @@ else { RECT tmp; - qxeSendMessage (toolbarwnd, TB_SETROWS, MAKEWPARAM(1, FALSE), + qxeSendMessage (toolbarwnd, TB_SETROWS, MAKEWPARAM (1, FALSE), (LPARAM)&tmp); } @@ -475,10 +454,10 @@ } static void -mswindows_move_toolbar (struct frame *f, enum toolbar_pos pos) +mswindows_move_toolbar (struct frame *f, enum edge_pos pos) { int bar_x, bar_y, bar_width, bar_height, vert; - HWND toolbarwnd = TOOLBAR_HANDLE(f,pos); + HWND toolbarwnd = TOOLBAR_HANDLE (f,pos); if (toolbarwnd) { @@ -490,19 +469,19 @@ by Windows and by XEmacs. */ switch (pos) { - case TOP_TOOLBAR: + case TOP_EDGE: bar_x--; bar_y-=2; bar_width+=3; bar_height+=3; break; - case LEFT_TOOLBAR: + case LEFT_EDGE: bar_x--; bar_y-=2; bar_height++; bar_width++; break; - case BOTTOM_TOOLBAR: + case BOTTOM_EDGE: bar_y-=2; bar_width+=4; bar_height+=4; break; - case RIGHT_TOOLBAR: + case RIGHT_EDGE: bar_y-=2; bar_x++; bar_width++; bar_height++; break; @@ -517,19 +496,14 @@ int UNUSED (x), int UNUSED (y), int UNUSED (width), int UNUSED (height)) { + enum edge_pos pos; assert (FRAME_MSWINDOWS_P (f)); - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - mswindows_move_toolbar (f, TOP_TOOLBAR); - - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - mswindows_move_toolbar (f, BOTTOM_TOOLBAR); - - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - mswindows_move_toolbar (f, LEFT_TOOLBAR); - - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - mswindows_move_toolbar (f, RIGHT_TOOLBAR); + EDGE_POS_LOOP (pos) + { + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + mswindows_move_toolbar (f, pos); + } } static void @@ -542,41 +516,33 @@ static void mswindows_initialize_frame_toolbars (struct frame *UNUSED (f)) { - } static void mswindows_output_frame_toolbars (struct frame *f) { + enum edge_pos pos; assert (FRAME_MSWINDOWS_P (f)); - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - mswindows_output_toolbar (f, TOP_TOOLBAR); - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - mswindows_output_toolbar (f, BOTTOM_TOOLBAR); - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - mswindows_output_toolbar (f, LEFT_TOOLBAR); - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - mswindows_output_toolbar (f, RIGHT_TOOLBAR); + EDGE_POS_LOOP (pos) + { + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + mswindows_output_toolbar (f, pos); + } } static void mswindows_clear_frame_toolbars (struct frame *f) { + enum edge_pos pos; assert (FRAME_MSWINDOWS_P (f)); - if (f->top_toolbar_was_visible - && !FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - mswindows_clear_toolbar (f, TOP_TOOLBAR, 0); - if (f->bottom_toolbar_was_visible - && !FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - mswindows_clear_toolbar (f, BOTTOM_TOOLBAR, 0); - if (f->left_toolbar_was_visible - && !FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - mswindows_clear_toolbar (f, LEFT_TOOLBAR, 0); - if (f->right_toolbar_was_visible - && !FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - mswindows_clear_toolbar (f, RIGHT_TOOLBAR, 0); + EDGE_POS_LOOP (pos) + { + if (f->toolbar_was_visible[pos] + && !FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + mswindows_clear_toolbar (f, pos, 0); + } } static void @@ -584,15 +550,15 @@ { HWND twnd=NULL; #define DELETE_TOOLBAR(pos) \ - mswindows_clear_toolbar(f, pos, 0); \ - if ((twnd=GetDlgItem(FRAME_MSWINDOWS_HANDLE(f), \ + mswindows_clear_toolbar (f, pos, 0); \ + if ((twnd=GetDlgItem (FRAME_MSWINDOWS_HANDLE (f), \ TOOLBAR_ID_BIAS + pos))) \ - DestroyWindow(twnd) + DestroyWindow (twnd) - DELETE_TOOLBAR(TOP_TOOLBAR); - DELETE_TOOLBAR(BOTTOM_TOOLBAR); - DELETE_TOOLBAR(LEFT_TOOLBAR); - DELETE_TOOLBAR(RIGHT_TOOLBAR); + DELETE_TOOLBAR (TOP_EDGE); + DELETE_TOOLBAR (BOTTOM_EDGE); + DELETE_TOOLBAR (LEFT_EDGE); + DELETE_TOOLBAR (RIGHT_EDGE); #undef DELETE_TOOLBAR }
--- a/src/toolbar-xlike.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/toolbar-xlike.c Mon Mar 29 21:28:13 2010 -0500 @@ -38,14 +38,14 @@ /* Only a very few things need to differ based on the toolkit used. ** -** Some of the routines used assert(FRAME_yyy_P(f)) checks, this is +** Some of the routines used assert (FRAME_yyy_P(f)) checks, this is ** now abstracted into __INTERNAL_APPROPRIATENESS_CHECK(). When we ** add new window systems that use this code, we should either add a ** new case here, or just remove the checks completely. ** ** At least for X & GTK redraw_frame_toolbars() might end up getting ** called before we are completely initialized. To avoid this, we use -** the __INTERNAL_MAPPED_P(f) macro, that should return 0 if we should +** the __INTERNAL_MAPPED_P (f) macro, that should return 0 if we should ** not draw the toolbars yet. When we add new window systems that use ** this code, we should add a new case here, if they need it. ** @@ -85,7 +85,7 @@ Lisp_Object window = FRAME_LAST_NONMINIBUF_WINDOW (f); struct window *w = XWINDOW (window); int shadow_thickness; - int def_shadow_thickness = XINT (Fspecifier_instance(Vtoolbar_shadow_thickness, window, Qnil, Qnil)); + int def_shadow_thickness = XINT (Fspecifier_instance (Vtoolbar_shadow_thickness, window, Qnil, Qnil)); face_index toolbar_findex; if (tb->vertical) @@ -103,7 +103,7 @@ toolbar_findex = get_builtin_face_cache_index (w, Vtoolbar_face); - /* Blank toolbar buttons that should be 3d will have EQ(tb->up_glyph, Qt) + /* Blank toolbar buttons that should be 3d will have EQ (tb->up_glyph, Qt) ** Blank toolbar buttons that should be flat will have NILP (tb->up_glyph) ** ** Real toolbar buttons will check tb->enabled && tb->down @@ -143,7 +143,7 @@ MAYBE_DEVMETH (d, bevel_area, (w, toolbar_findex, sx + x_adj, sy + y_adj, swidth + width_adj, - sheight + height_adj, abs(shadow_thickness), + sheight + height_adj, abs (shadow_thickness), EDGE_ALL, (shadow_thickness < 0) ? EDGE_BEVEL_IN : EDGE_BEVEL_OUT)); } @@ -370,7 +370,7 @@ return (size); } -#define XLIKE_OUTPUT_BUTTONS_LOOP(left) \ +#define XLIKE_OUTPUT_BUTTONS_LOOP(left) \ do { \ while (!NILP (button)) \ { \ @@ -436,29 +436,8 @@ } \ } while (0) -#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ - do { \ - switch (pos) \ - { \ - case TOP_TOOLBAR: \ - (frame)->top_toolbar_was_visible = flag; \ - break; \ - case BOTTOM_TOOLBAR: \ - (frame)->bottom_toolbar_was_visible = flag; \ - break; \ - case LEFT_TOOLBAR: \ - (frame)->left_toolbar_was_visible = flag; \ - break; \ - case RIGHT_TOOLBAR: \ - (frame)->right_toolbar_was_visible = flag; \ - break; \ - default: \ - ABORT (); \ - } \ - } while (0) - static void -xlike_output_toolbar (struct frame *f, enum toolbar_pos pos) +xlike_output_toolbar (struct frame *f, enum edge_pos pos) { int x, y, bar_width, bar_height, vert; int max_pixpos, right_size, right_start, blank_size; @@ -582,7 +561,7 @@ } static void -xlike_clear_toolbar (struct frame *f, enum toolbar_pos pos, int thickness_change) +xlike_clear_toolbar (struct frame *f, enum edge_pos pos, int thickness_change) { Lisp_Object frame; int x, y, width, height, vert; @@ -594,7 +573,7 @@ to clear any excess toolbar if the size shrinks. */ if (thickness_change < 0) { - if (pos == LEFT_TOOLBAR || pos == RIGHT_TOOLBAR) + if (pos == LEFT_EDGE || pos == RIGHT_EDGE) { x = x + width + thickness_change; width = -thickness_change; @@ -616,42 +595,32 @@ void xlike_output_frame_toolbars (struct frame *f) { - __INTERNAL_APPROPRIATENESS_CHECK(f); - - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - xlike_output_toolbar (f, TOP_TOOLBAR); + enum edge_pos pos; + __INTERNAL_APPROPRIATENESS_CHECK (f); - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - xlike_output_toolbar (f, BOTTOM_TOOLBAR); - - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - xlike_output_toolbar (f, LEFT_TOOLBAR); - - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - xlike_output_toolbar (f, RIGHT_TOOLBAR); + EDGE_POS_LOOP (pos) + { + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + xlike_output_toolbar (f, pos); + } } void xlike_clear_frame_toolbars (struct frame *f) { - __INTERNAL_APPROPRIATENESS_CHECK(f); + enum edge_pos pos; + __INTERNAL_APPROPRIATENESS_CHECK (f); - if (f->top_toolbar_was_visible - && !FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - xlike_clear_toolbar (f, TOP_TOOLBAR, 0); - if (f->bottom_toolbar_was_visible - && !FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - xlike_clear_toolbar (f, BOTTOM_TOOLBAR, 0); - if (f->left_toolbar_was_visible - && !FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - xlike_clear_toolbar (f, LEFT_TOOLBAR, 0); - if (f->right_toolbar_was_visible - && !FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - xlike_clear_toolbar (f, RIGHT_TOOLBAR, 0); + EDGE_POS_LOOP (pos) + { + if (f->toolbar_was_visible[pos] + && !FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + xlike_clear_toolbar (f, pos, 0); + } } static void -xlike_redraw_exposed_toolbar (struct frame *f, enum toolbar_pos pos, int x, int y, +xlike_redraw_exposed_toolbar (struct frame *f, enum edge_pos pos, int x, int y, int width, int height) { int bar_x, bar_y, bar_width, bar_height, vert; @@ -701,19 +670,14 @@ xlike_redraw_exposed_toolbars (struct frame *f, int x, int y, int width, int height) { - __INTERNAL_APPROPRIATENESS_CHECK(f); - - if (FRAME_REAL_TOP_TOOLBAR_VISIBLE (f)) - xlike_redraw_exposed_toolbar (f, TOP_TOOLBAR, x, y, width, height); + enum edge_pos pos; + __INTERNAL_APPROPRIATENESS_CHECK (f); - if (FRAME_REAL_BOTTOM_TOOLBAR_VISIBLE (f)) - xlike_redraw_exposed_toolbar (f, BOTTOM_TOOLBAR, x, y, width, height); - - if (FRAME_REAL_LEFT_TOOLBAR_VISIBLE (f)) - xlike_redraw_exposed_toolbar (f, LEFT_TOOLBAR, x, y, width, height); - - if (FRAME_REAL_RIGHT_TOOLBAR_VISIBLE (f)) - xlike_redraw_exposed_toolbar (f, RIGHT_TOOLBAR, x, y, width, height); + EDGE_POS_LOOP (pos) + { + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) + xlike_redraw_exposed_toolbar (f, pos, x, y, width, height); + } } void @@ -724,7 +688,7 @@ particular before we have actually mapped it. That routine can call this one. So, we need to make sure that the frame is actually ready before we try and draw all over it. */ - if (__INTERNAL_MAPPED_P(f)) + if (__INTERNAL_MAPPED_P (f)) xlike_redraw_exposed_toolbars (f, 0, 0, FRAME_PIXWIDTH (f), FRAME_PIXHEIGHT (f)); }
--- a/src/toolbar.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/toolbar.c Mon Mar 29 21:28:13 2010 -0500 @@ -37,10 +37,10 @@ #include "toolbar.h" #include "window.h" -Lisp_Object Vtoolbar[4]; -Lisp_Object Vtoolbar_size[4]; -Lisp_Object Vtoolbar_visible_p[4]; -Lisp_Object Vtoolbar_border_width[4]; +Lisp_Object Vtoolbar[NUM_EDGES]; +Lisp_Object Vtoolbar_size[NUM_EDGES]; +Lisp_Object Vtoolbar_visible_p[NUM_EDGES]; +Lisp_Object Vtoolbar_border_width[NUM_EDGES]; Lisp_Object Vdefault_toolbar, Vdefault_toolbar_visible_p; Lisp_Object Vdefault_toolbar_width, Vdefault_toolbar_height; @@ -71,6 +71,33 @@ { XD_END } }; + +static Lisp_Object +allocate_toolbar_button (struct frame *f, int pushright) +{ + struct toolbar_button *tb; + + tb = XTOOLBAR_BUTTON (ALLOC_NORMAL_LISP_OBJECT (toolbar_button)); + tb->next = Qnil; + tb->frame = wrap_frame (f); + tb->up_glyph = Qnil; + tb->down_glyph = Qnil; + tb->disabled_glyph = Qnil; + tb->cap_up_glyph = Qnil; + tb->cap_down_glyph = Qnil; + tb->cap_disabled_glyph = Qnil; + tb->callback = Qnil; + tb->enabled_p = Qnil; + tb->help_string = Qnil; + + tb->pushright = pushright; + tb->x = tb->y = tb->width = tb->height = -1; + tb->dirty = 1; + + return wrap_toolbar_button (tb); +} + + static Lisp_Object mark_toolbar_button (Lisp_Object obj) { @@ -88,13 +115,10 @@ return data->help_string; } -DEFINE_LRECORD_IMPLEMENTATION ("toolbar-button", toolbar_button, - 0, /*dumpable-flag*/ - mark_toolbar_button, - default_object_printer, - 0, 0, 0, - toolbar_button_description, - struct toolbar_button); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("toolbar-button", toolbar_button, + mark_toolbar_button, + toolbar_button_description, + struct toolbar_button); DEFUN ("toolbar-button-p", Ftoolbar_button_p, 1, 1, 0, /* Return non-nil if OBJECT is a toolbar button. @@ -232,16 +256,16 @@ } -static enum toolbar_pos +static enum edge_pos decode_toolbar_position (Lisp_Object position) { - if (EQ (position, Qtop)) return TOP_TOOLBAR; - if (EQ (position, Qbottom)) return BOTTOM_TOOLBAR; - if (EQ (position, Qleft)) return LEFT_TOOLBAR; - if (EQ (position, Qright)) return RIGHT_TOOLBAR; + if (EQ (position, Qtop)) return TOP_EDGE; + if (EQ (position, Qbottom)) return BOTTOM_EDGE; + if (EQ (position, Qleft)) return LEFT_EDGE; + if (EQ (position, Qright)) return RIGHT_EDGE; invalid_constant ("Invalid toolbar position", position); - RETURN_NOT_REACHED (TOP_TOOLBAR); + RETURN_NOT_REACHED (TOP_EDGE); } DEFUN ("set-default-toolbar-position", Fset_default_toolbar_position, 1, 1, 0, /* @@ -251,8 +275,8 @@ */ (position)) { - enum toolbar_pos cur = decode_toolbar_position (Vdefault_toolbar_position); - enum toolbar_pos new_ = decode_toolbar_position (position); + enum edge_pos cur = decode_toolbar_position (Vdefault_toolbar_position); + enum edge_pos new_ = decode_toolbar_position (position); if (cur != new_) { @@ -264,7 +288,7 @@ set_specifier_fallback (Vtoolbar[new_], Vdefault_toolbar); set_specifier_fallback (Vtoolbar_size[cur], list1 (Fcons (Qnil, Qzero))); set_specifier_fallback (Vtoolbar_size[new_], - new_ == TOP_TOOLBAR || new_ == BOTTOM_TOOLBAR + new_ == TOP_EDGE || new_ == BOTTOM_EDGE ? Vdefault_toolbar_height : Vdefault_toolbar_width); set_specifier_fallback (Vtoolbar_border_width[cur], @@ -304,27 +328,7 @@ buffer = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f))->buffer; if (!tb) - { - tb = ALLOC_LCRECORD_TYPE (struct toolbar_button, &lrecord_toolbar_button); - tb->next = Qnil; - tb->frame = wrap_frame (f); - tb->up_glyph = Qnil; - tb->down_glyph = Qnil; - tb->disabled_glyph = Qnil; - tb->cap_up_glyph = Qnil; - tb->cap_down_glyph = Qnil; - tb->cap_disabled_glyph = Qnil; - tb->callback = Qnil; - tb->enabled_p = Qnil; - tb->help_string = Qnil; - - tb->enabled = 0; - tb->down = 0; - tb->pushright = pushright; - tb->blank = 0; - tb->x = tb->y = tb->width = tb->height = -1; - tb->dirty = 1; - } + tb = XTOOLBAR_BUTTON (allocate_toolbar_button (f, pushright)); retval = wrap_toolbar_button (tb); /* Let's make sure nothing gets mucked up by the potential call to @@ -590,7 +594,7 @@ } void -mark_frame_toolbar_buttons_dirty (struct frame *f, enum toolbar_pos pos) +mark_frame_toolbar_buttons_dirty (struct frame *f, enum edge_pos pos) { Lisp_Object button = FRAME_TOOLBAR_BUTTONS (f, pos); @@ -604,7 +608,7 @@ } static Lisp_Object -compute_frame_toolbar_buttons (struct frame *f, enum toolbar_pos pos, +compute_frame_toolbar_buttons (struct frame *f, enum edge_pos pos, Lisp_Object toolbar) { Lisp_Object buttons, prev_button, first_button; @@ -713,7 +717,7 @@ } static void -set_frame_toolbar (struct frame *f, enum toolbar_pos pos) +set_frame_toolbar (struct frame *f, enum edge_pos pos) { struct window *w = XWINDOW (FRAME_LAST_NONMINIBUF_WINDOW (f)); Lisp_Object toolbar = w->toolbar[pos]; @@ -725,10 +729,10 @@ static void compute_frame_toolbars_data (struct frame *f) { - set_frame_toolbar (f, TOP_TOOLBAR); - set_frame_toolbar (f, BOTTOM_TOOLBAR); - set_frame_toolbar (f, LEFT_TOOLBAR); - set_frame_toolbar (f, RIGHT_TOOLBAR); + set_frame_toolbar (f, TOP_EDGE); + set_frame_toolbar (f, BOTTOM_EDGE); + set_frame_toolbar (f, LEFT_EDGE); + set_frame_toolbar (f, RIGHT_EDGE); } /* Update the toolbar geometry separately from actually displaying the @@ -762,14 +766,15 @@ unchanged, as it will hose windows whose pixsizes are not multiple of character sizes. */ - for (pos = 0; pos < 4; pos++) + EDGE_POS_LOOP (pos) if (FRAME_REAL_TOOLBAR_SIZE (f, pos) != FRAME_CURRENT_TOOLBAR_SIZE (f, pos)) frame_size_changed = 1; - for (pos = 0; pos < 4; pos++) { - f->current_toolbar_size[pos] = FRAME_REAL_TOOLBAR_SIZE (f, pos); - } + EDGE_POS_LOOP (pos) + { + f->current_toolbar_size[pos] = FRAME_REAL_TOOLBAR_SIZE (f, pos); + } /* Removed the check for the minibuffer here. We handle this more correctly now by consistently using @@ -777,6 +782,17 @@ throughout the toolbar code. */ compute_frame_toolbars_data (f); + /* #### GEOM! Turning the toolbar on and off repeatedly causes the + frame to steadily shrink. Basically, turning it on doesn't + increase the frame size, while turning it off does reduce the + frame size. The cause has something to do with the combination + of this maybe questionable code here, plus the fact that toolbars + are included in the displayable area, and the difference between + real and theoretical toolbar sizes, and exactly when the various + computations happen w.r.t. the specifiers or whatever that control + whether toolbars are visible and hence whether their thickness is + greater than zero. --ben */ + if (frame_size_changed) { int width, height; @@ -833,7 +849,7 @@ already recomputed, and possibly modified by resource initialization. Remember current toolbar geometry so next redisplay will not needlessly relayout toolbars. */ - for (pos = 0; pos < 4; pos++) + EDGE_POS_LOOP (pos) f->current_toolbar_size[pos] = FRAME_REAL_TOOLBAR_SIZE (f, pos); } } @@ -868,7 +884,7 @@ } void -get_toolbar_coords (struct frame *f, enum toolbar_pos pos, int *x, int *y, +get_toolbar_coords (struct frame *f, enum edge_pos pos, int *x, int *y, int *width, int *height, int *vert, int for_layout) { int visible_top_toolbar_height, visible_bottom_toolbar_height; @@ -892,7 +908,7 @@ switch (pos) { - case TOP_TOOLBAR: + case TOP_EDGE: *x = 1; *y = 0; /* #### should be 1 if no menubar */ *width = FRAME_PIXWIDTH (f) - 2; @@ -900,7 +916,7 @@ 2 * FRAME_REAL_TOP_TOOLBAR_BORDER_WIDTH (f) - adjust; *vert = 0; break; - case BOTTOM_TOOLBAR: + case BOTTOM_EDGE: *x = 1; *y = FRAME_PIXHEIGHT (f) - FRAME_REAL_BOTTOM_TOOLBAR_HEIGHT (f) - 2 * FRAME_REAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f); @@ -909,7 +925,7 @@ 2 * FRAME_REAL_BOTTOM_TOOLBAR_BORDER_WIDTH (f) - adjust; *vert = 0; break; - case LEFT_TOOLBAR: + case LEFT_EDGE: *x = 1; *y = visible_top_toolbar_height; *width = FRAME_REAL_LEFT_TOOLBAR_WIDTH (f) + @@ -918,7 +934,7 @@ visible_bottom_toolbar_height - 1); *vert = 1; break; - case RIGHT_TOOLBAR: + case RIGHT_EDGE: *x = FRAME_PIXWIDTH (f) - FRAME_REAL_RIGHT_TOOLBAR_WIDTH (f) - 2 * FRAME_REAL_RIGHT_TOOLBAR_BORDER_WIDTH (f); *y = visible_top_toolbar_height; @@ -934,7 +950,7 @@ } #define CHECK_TOOLBAR(pos) do { \ - if (FRAME_REAL_##pos##_VISIBLE (f)) \ + if (FRAME_REAL_TOOLBAR_VISIBLE (f, pos)) \ { \ int x, y, width, height, vert; \ \ @@ -950,10 +966,10 @@ static Lisp_Object toolbar_buttons_at_pixpos (struct frame *f, int x_coord, int y_coord) { - CHECK_TOOLBAR (TOP_TOOLBAR); - CHECK_TOOLBAR (BOTTOM_TOOLBAR); - CHECK_TOOLBAR (LEFT_TOOLBAR); - CHECK_TOOLBAR (RIGHT_TOOLBAR); + CHECK_TOOLBAR (TOP_EDGE); + CHECK_TOOLBAR (BOTTOM_EDGE); + CHECK_TOOLBAR (LEFT_EDGE); + CHECK_TOOLBAR (RIGHT_EDGE); return Qnil; } @@ -997,9 +1013,9 @@ DEFINE_SPECIFIER_TYPE (toolbar); -#define CTB_ERROR(msg) do { \ - maybe_signal_error (Qinvalid_argument, msg, button, Qtoolbar, errb); \ - RETURN_SANS_WARNINGS Qnil; \ +#define CTB_ERROR(msg) do { \ + maybe_signal_error (Qinvalid_argument, msg, button, Qtoolbar, errb); \ + RETURN_SANS_WARNINGS Qnil; \ } while (0) /* Returns Q_style if key was :style, Qt if ok otherwise, Qnil if error. */ @@ -1216,9 +1232,9 @@ specifier caching changes */ static void -recompute_overlaying_specifier (Lisp_Object real_one[4]) +recompute_overlaying_specifier (Lisp_Object real_one[NUM_EDGES]) { - enum toolbar_pos pos = decode_toolbar_position (Vdefault_toolbar_position); + enum edge_pos pos = decode_toolbar_position (Vdefault_toolbar_position); Fset_specifier_dirty_flag (real_one[pos]); } @@ -1332,7 +1348,7 @@ void syms_of_toolbar (void) { - INIT_LRECORD_IMPLEMENTATION (toolbar_button); + INIT_LISP_OBJECT (toolbar_button); DEFSYMBOL_MULTIWORD_PREDICATE (Qtoolbar_buttonp); DEFSYMBOL (Q2D); @@ -1501,19 +1517,19 @@ 0, 0, 0); DEFVAR_SPECIFIER ("top-toolbar", - &Vtoolbar[TOP_TOOLBAR] /* + &Vtoolbar[TOP_EDGE] /* Specifier for the toolbar at the top of the frame. Use `set-specifier' to change this. See `default-toolbar' for a description of a valid toolbar instantiator. */ ); - Vtoolbar[TOP_TOOLBAR] = Fmake_specifier (Qtoolbar); - set_specifier_caching (Vtoolbar[TOP_TOOLBAR], - offsetof (struct window, toolbar[TOP_TOOLBAR]), + Vtoolbar[TOP_EDGE] = Fmake_specifier (Qtoolbar); + set_specifier_caching (Vtoolbar[TOP_EDGE], + offsetof (struct window, toolbar[TOP_EDGE]), toolbar_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("bottom-toolbar", - &Vtoolbar[BOTTOM_TOOLBAR] /* + &Vtoolbar[BOTTOM_EDGE] /* Specifier for the toolbar at the bottom of the frame. Use `set-specifier' to change this. See `default-toolbar' for a description of a valid toolbar instantiator. @@ -1523,14 +1539,14 @@ `bottom-toolbar-height') is 0; thus, a bottom toolbar will not be displayed even if you provide a value for `bottom-toolbar'. */ ); - Vtoolbar[BOTTOM_TOOLBAR] = Fmake_specifier (Qtoolbar); - set_specifier_caching (Vtoolbar[BOTTOM_TOOLBAR], - offsetof (struct window, toolbar[BOTTOM_TOOLBAR]), + Vtoolbar[BOTTOM_EDGE] = Fmake_specifier (Qtoolbar); + set_specifier_caching (Vtoolbar[BOTTOM_EDGE], + offsetof (struct window, toolbar[BOTTOM_EDGE]), toolbar_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("left-toolbar", - &Vtoolbar[LEFT_TOOLBAR] /* + &Vtoolbar[LEFT_EDGE] /* Specifier for the toolbar at the left edge of the frame. Use `set-specifier' to change this. See `default-toolbar' for a description of a valid toolbar instantiator. @@ -1540,14 +1556,14 @@ `left-toolbar-width') is 0; thus, a left toolbar will not be displayed even if you provide a value for `left-toolbar'. */ ); - Vtoolbar[LEFT_TOOLBAR] = Fmake_specifier (Qtoolbar); - set_specifier_caching (Vtoolbar[LEFT_TOOLBAR], - offsetof (struct window, toolbar[LEFT_TOOLBAR]), + Vtoolbar[LEFT_EDGE] = Fmake_specifier (Qtoolbar); + set_specifier_caching (Vtoolbar[LEFT_EDGE], + offsetof (struct window, toolbar[LEFT_EDGE]), toolbar_specs_changed, 0, 0, 0); DEFVAR_SPECIFIER ("right-toolbar", - &Vtoolbar[RIGHT_TOOLBAR] /* + &Vtoolbar[RIGHT_EDGE] /* Specifier for the toolbar at the right edge of the frame. Use `set-specifier' to change this. See `default-toolbar' for a description of a valid toolbar instantiator. @@ -1557,9 +1573,9 @@ `right-toolbar-width') is 0; thus, a right toolbar will not be displayed even if you provide a value for `right-toolbar'. */ ); - Vtoolbar[RIGHT_TOOLBAR] = Fmake_specifier (Qtoolbar); - set_specifier_caching (Vtoolbar[RIGHT_TOOLBAR], - offsetof (struct window, toolbar[RIGHT_TOOLBAR]), + Vtoolbar[RIGHT_EDGE] = Fmake_specifier (Qtoolbar); + set_specifier_caching (Vtoolbar[RIGHT_EDGE], + offsetof (struct window, toolbar[RIGHT_EDGE]), toolbar_specs_changed, 0, 0, 0); @@ -1567,10 +1583,10 @@ changed with `set-default-toolbar-position'. */ fb = list1 (Fcons (Qnil, Qnil)); set_specifier_fallback (Vdefault_toolbar, fb); - set_specifier_fallback (Vtoolbar[TOP_TOOLBAR], Vdefault_toolbar); - set_specifier_fallback (Vtoolbar[BOTTOM_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar[LEFT_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar[RIGHT_TOOLBAR], fb); + set_specifier_fallback (Vtoolbar[TOP_EDGE], Vdefault_toolbar); + set_specifier_fallback (Vtoolbar[BOTTOM_EDGE], fb); + set_specifier_fallback (Vtoolbar[LEFT_EDGE], fb); + set_specifier_fallback (Vtoolbar[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-toolbar-height", &Vdefault_toolbar_height /* *Height of the default toolbar, if it's oriented horizontally. @@ -1632,59 +1648,59 @@ default_toolbar_size_changed_in_frame, 0); DEFVAR_SPECIFIER ("top-toolbar-height", - &Vtoolbar_size[TOP_TOOLBAR] /* + &Vtoolbar_size[TOP_EDGE] /* *Height of the top toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_size[TOP_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_size[TOP_TOOLBAR], - offsetof (struct window, toolbar_size[TOP_TOOLBAR]), + Vtoolbar_size[TOP_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_size[TOP_EDGE], + offsetof (struct window, toolbar_size[TOP_EDGE]), toolbar_geometry_changed_in_window, - offsetof (struct frame, toolbar_size[TOP_TOOLBAR]), + offsetof (struct frame, toolbar_size[TOP_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("bottom-toolbar-height", - &Vtoolbar_size[BOTTOM_TOOLBAR] /* + &Vtoolbar_size[BOTTOM_EDGE] /* *Height of the bottom toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_size[BOTTOM_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_size[BOTTOM_TOOLBAR], - offsetof (struct window, toolbar_size[BOTTOM_TOOLBAR]), + Vtoolbar_size[BOTTOM_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_size[BOTTOM_EDGE], + offsetof (struct window, toolbar_size[BOTTOM_EDGE]), toolbar_geometry_changed_in_window, - offsetof (struct frame, toolbar_size[BOTTOM_TOOLBAR]), + offsetof (struct frame, toolbar_size[BOTTOM_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("left-toolbar-width", - &Vtoolbar_size[LEFT_TOOLBAR] /* + &Vtoolbar_size[LEFT_EDGE] /* *Width of left toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_size[LEFT_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_size[LEFT_TOOLBAR], - offsetof (struct window, toolbar_size[LEFT_TOOLBAR]), + Vtoolbar_size[LEFT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_size[LEFT_EDGE], + offsetof (struct window, toolbar_size[LEFT_EDGE]), toolbar_geometry_changed_in_window, - offsetof (struct frame, toolbar_size[LEFT_TOOLBAR]), + offsetof (struct frame, toolbar_size[LEFT_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("right-toolbar-width", - &Vtoolbar_size[RIGHT_TOOLBAR] /* + &Vtoolbar_size[RIGHT_EDGE] /* *Width of right toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_size[RIGHT_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_size[RIGHT_TOOLBAR], - offsetof (struct window, toolbar_size[RIGHT_TOOLBAR]), + Vtoolbar_size[RIGHT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_size[RIGHT_EDGE], + offsetof (struct window, toolbar_size[RIGHT_EDGE]), toolbar_geometry_changed_in_window, - offsetof (struct frame, toolbar_size[RIGHT_TOOLBAR]), + offsetof (struct frame, toolbar_size[RIGHT_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("toolbar-shadow-thickness", @@ -1750,11 +1766,11 @@ if (!NILP (fb)) set_specifier_fallback (Vdefault_toolbar_width, fb); - set_specifier_fallback (Vtoolbar_size[TOP_TOOLBAR], Vdefault_toolbar_height); + set_specifier_fallback (Vtoolbar_size[TOP_EDGE], Vdefault_toolbar_height); fb = list1 (Fcons (Qnil, Qzero)); - set_specifier_fallback (Vtoolbar_size[BOTTOM_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_size[LEFT_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_size[RIGHT_TOOLBAR], fb); + set_specifier_fallback (Vtoolbar_size[BOTTOM_EDGE], fb); + set_specifier_fallback (Vtoolbar_size[LEFT_EDGE], fb); + set_specifier_fallback (Vtoolbar_size[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-toolbar-border-width", &Vdefault_toolbar_border_width /* @@ -1786,67 +1802,67 @@ default_toolbar_border_width_changed_in_frame, 0); DEFVAR_SPECIFIER ("top-toolbar-border-width", - &Vtoolbar_border_width[TOP_TOOLBAR] /* + &Vtoolbar_border_width[TOP_EDGE] /* *Border width of the top toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_border_width[TOP_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_border_width[TOP_TOOLBAR], + Vtoolbar_border_width[TOP_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_border_width[TOP_EDGE], offsetof (struct window, - toolbar_border_width[TOP_TOOLBAR]), + toolbar_border_width[TOP_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_border_width[TOP_TOOLBAR]), + toolbar_border_width[TOP_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("bottom-toolbar-border-width", - &Vtoolbar_border_width[BOTTOM_TOOLBAR] /* + &Vtoolbar_border_width[BOTTOM_EDGE] /* *Border width of the bottom toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_border_width[BOTTOM_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_border_width[BOTTOM_TOOLBAR], + Vtoolbar_border_width[BOTTOM_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_border_width[BOTTOM_EDGE], offsetof (struct window, - toolbar_border_width[BOTTOM_TOOLBAR]), + toolbar_border_width[BOTTOM_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_border_width[BOTTOM_TOOLBAR]), + toolbar_border_width[BOTTOM_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("left-toolbar-border-width", - &Vtoolbar_border_width[LEFT_TOOLBAR] /* + &Vtoolbar_border_width[LEFT_EDGE] /* *Border width of left toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_border_width[LEFT_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_border_width[LEFT_TOOLBAR], + Vtoolbar_border_width[LEFT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_border_width[LEFT_EDGE], offsetof (struct window, - toolbar_border_width[LEFT_TOOLBAR]), + toolbar_border_width[LEFT_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_border_width[LEFT_TOOLBAR]), + toolbar_border_width[LEFT_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("right-toolbar-border-width", - &Vtoolbar_border_width[RIGHT_TOOLBAR] /* + &Vtoolbar_border_width[RIGHT_EDGE] /* *Border width of right toolbar. This is a specifier; use `set-specifier' to change it. See `default-toolbar-height' for more information. */ ); - Vtoolbar_border_width[RIGHT_TOOLBAR] = Fmake_specifier (Qnatnum); - set_specifier_caching (Vtoolbar_border_width[RIGHT_TOOLBAR], + Vtoolbar_border_width[RIGHT_EDGE] = Fmake_specifier (Qnatnum); + set_specifier_caching (Vtoolbar_border_width[RIGHT_EDGE], offsetof (struct window, - toolbar_border_width[RIGHT_TOOLBAR]), + toolbar_border_width[RIGHT_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_border_width[RIGHT_TOOLBAR]), + toolbar_border_width[RIGHT_EDGE]), frame_size_slipped, 0); fb = Qnil; @@ -1865,11 +1881,11 @@ if (!NILP (fb)) set_specifier_fallback (Vdefault_toolbar_border_width, fb); - set_specifier_fallback (Vtoolbar_border_width[TOP_TOOLBAR], Vdefault_toolbar_border_width); + set_specifier_fallback (Vtoolbar_border_width[TOP_EDGE], Vdefault_toolbar_border_width); fb = list1 (Fcons (Qnil, Qzero)); - set_specifier_fallback (Vtoolbar_border_width[BOTTOM_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_border_width[LEFT_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_border_width[RIGHT_TOOLBAR], fb); + set_specifier_fallback (Vtoolbar_border_width[BOTTOM_EDGE], fb); + set_specifier_fallback (Vtoolbar_border_width[LEFT_EDGE], fb); + set_specifier_fallback (Vtoolbar_border_width[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("default-toolbar-visible-p", &Vdefault_toolbar_visible_p /* *Whether the default toolbar is visible. @@ -1899,78 +1915,78 @@ default_toolbar_visible_p_changed_in_frame, 0); DEFVAR_SPECIFIER ("top-toolbar-visible-p", - &Vtoolbar_visible_p[TOP_TOOLBAR] /* + &Vtoolbar_visible_p[TOP_EDGE] /* *Whether the top toolbar is visible. This is a specifier; use `set-specifier' to change it. See `default-toolbar-visible-p' for more information. */ ); - Vtoolbar_visible_p[TOP_TOOLBAR] = Fmake_specifier (Qboolean); - set_specifier_caching (Vtoolbar_visible_p[TOP_TOOLBAR], + Vtoolbar_visible_p[TOP_EDGE] = Fmake_specifier (Qboolean); + set_specifier_caching (Vtoolbar_visible_p[TOP_EDGE], offsetof (struct window, - toolbar_visible_p[TOP_TOOLBAR]), + toolbar_visible_p[TOP_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_visible_p[TOP_TOOLBAR]), + toolbar_visible_p[TOP_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("bottom-toolbar-visible-p", - &Vtoolbar_visible_p[BOTTOM_TOOLBAR] /* + &Vtoolbar_visible_p[BOTTOM_EDGE] /* *Whether the bottom toolbar is visible. This is a specifier; use `set-specifier' to change it. See `default-toolbar-visible-p' for more information. */ ); - Vtoolbar_visible_p[BOTTOM_TOOLBAR] = Fmake_specifier (Qboolean); - set_specifier_caching (Vtoolbar_visible_p[BOTTOM_TOOLBAR], + Vtoolbar_visible_p[BOTTOM_EDGE] = Fmake_specifier (Qboolean); + set_specifier_caching (Vtoolbar_visible_p[BOTTOM_EDGE], offsetof (struct window, - toolbar_visible_p[BOTTOM_TOOLBAR]), + toolbar_visible_p[BOTTOM_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_visible_p[BOTTOM_TOOLBAR]), + toolbar_visible_p[BOTTOM_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("left-toolbar-visible-p", - &Vtoolbar_visible_p[LEFT_TOOLBAR] /* + &Vtoolbar_visible_p[LEFT_EDGE] /* *Whether the left toolbar is visible. This is a specifier; use `set-specifier' to change it. See `default-toolbar-visible-p' for more information. */ ); - Vtoolbar_visible_p[LEFT_TOOLBAR] = Fmake_specifier (Qboolean); - set_specifier_caching (Vtoolbar_visible_p[LEFT_TOOLBAR], + Vtoolbar_visible_p[LEFT_EDGE] = Fmake_specifier (Qboolean); + set_specifier_caching (Vtoolbar_visible_p[LEFT_EDGE], offsetof (struct window, - toolbar_visible_p[LEFT_TOOLBAR]), + toolbar_visible_p[LEFT_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_visible_p[LEFT_TOOLBAR]), + toolbar_visible_p[LEFT_EDGE]), frame_size_slipped, 0); DEFVAR_SPECIFIER ("right-toolbar-visible-p", - &Vtoolbar_visible_p[RIGHT_TOOLBAR] /* + &Vtoolbar_visible_p[RIGHT_EDGE] /* *Whether the right toolbar is visible. This is a specifier; use `set-specifier' to change it. See `default-toolbar-visible-p' for more information. */ ); - Vtoolbar_visible_p[RIGHT_TOOLBAR] = Fmake_specifier (Qboolean); - set_specifier_caching (Vtoolbar_visible_p[RIGHT_TOOLBAR], + Vtoolbar_visible_p[RIGHT_EDGE] = Fmake_specifier (Qboolean); + set_specifier_caching (Vtoolbar_visible_p[RIGHT_EDGE], offsetof (struct window, - toolbar_visible_p[RIGHT_TOOLBAR]), + toolbar_visible_p[RIGHT_EDGE]), toolbar_geometry_changed_in_window, offsetof (struct frame, - toolbar_visible_p[RIGHT_TOOLBAR]), + toolbar_visible_p[RIGHT_EDGE]), frame_size_slipped, 0); /* initially, top inherits from default; this can be changed with `set-default-toolbar-position'. */ fb = list1 (Fcons (Qnil, Qt)); set_specifier_fallback (Vdefault_toolbar_visible_p, fb); - set_specifier_fallback (Vtoolbar_visible_p[TOP_TOOLBAR], + set_specifier_fallback (Vtoolbar_visible_p[TOP_EDGE], Vdefault_toolbar_visible_p); - set_specifier_fallback (Vtoolbar_visible_p[BOTTOM_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_visible_p[LEFT_TOOLBAR], fb); - set_specifier_fallback (Vtoolbar_visible_p[RIGHT_TOOLBAR], fb); + set_specifier_fallback (Vtoolbar_visible_p[BOTTOM_EDGE], fb); + set_specifier_fallback (Vtoolbar_visible_p[LEFT_EDGE], fb); + set_specifier_fallback (Vtoolbar_visible_p[RIGHT_EDGE], fb); DEFVAR_SPECIFIER ("toolbar-buttons-captioned-p", &Vtoolbar_buttons_captioned_p /*
--- a/src/toolbar.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/toolbar.h Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,6 @@ /* Define general toolbar support. Copyright (C) 1995 Board of Trustees, University of Illinois. - Copyright (C) 1995, 1996 Ben Wing. + Copyright (C) 1995, 1996, 2010 Ben Wing. Copyright (C) 1996 Chuck Thompson. This file is part of XEmacs. @@ -33,12 +33,17 @@ ((frame)->toolbar_buttons[pos]) #define FRAME_CURRENT_TOOLBAR_SIZE(frame, pos) \ ((frame)->current_toolbar_size[pos]) +#define SET_TOOLBAR_WAS_VISIBLE_FLAG(frame, pos, flag) \ + do { \ + (frame)->toolbar_was_visible[pos] = flag; \ + } while (0) + #define DEVICE_SUPPORTS_TOOLBARS_P(d) \ HAS_DEVMETH_P (d, output_frame_toolbars) struct toolbar_button { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object next; Lisp_Object frame; @@ -69,14 +74,14 @@ int border_width; }; -DECLARE_LRECORD (toolbar_button, struct toolbar_button); +DECLARE_LISP_OBJECT (toolbar_button, struct toolbar_button); #define XTOOLBAR_BUTTON(x) XRECORD (x, toolbar_button, struct toolbar_button) #define wrap_toolbar_button(p) wrap_record (p, toolbar_button) #define TOOLBAR_BUTTONP(x) RECORDP (x, toolbar_button) #define CHECK_TOOLBAR_BUTTON(x) CHECK_RECORD (x, toolbar_button) #define CONCHECK_TOOLBAR_BUTTON(x) CONCHECK_RECORD (x, toolbar_button) -void get_toolbar_coords (struct frame *f, enum toolbar_pos pos, int *x, +void get_toolbar_coords (struct frame *f, enum edge_pos pos, int *x, int *y, int *width, int *height, int *vert, int for_layout); Lisp_Object toolbar_button_at_pixpos (struct frame *f, int x_coord, @@ -106,7 +111,7 @@ void free_frame_toolbars (struct frame *f); Lisp_Object get_toolbar_button_glyph (struct window *w, struct toolbar_button *tb); -void mark_frame_toolbar_buttons_dirty (struct frame *f, enum toolbar_pos pos); +void mark_frame_toolbar_buttons_dirty (struct frame *f, enum edge_pos pos); #endif /* HAVE_TOOLBARS */
--- a/src/tooltalk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/tooltalk.c Mon Mar 29 21:28:13 2010 -0500 @@ -1,7 +1,7 @@ /* Tooltalk support for Emacs. Copyright (C) 1993, 1994 Sun Microsystems, Inc. Copyright (C) 1995 Free Software Foundation, Inc. - Copyright (C) 2002 Ben Wing. + Copyright (C) 2002, 2010 Ben Wing. This file is part of XEmacs. @@ -147,7 +147,7 @@ struct Lisp_Tooltalk_Message { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object plist_sym, callback; Tt_message m; }; @@ -172,30 +172,28 @@ Lisp_Tooltalk_Message *p = XTOOLTALK_MESSAGE (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<tooltalk-message id:0x%lx 0x%x>", - (long) (p->m), p->header.uid); + (long) (p->m), LISP_OBJECT_UID (obj)); } -DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-message", tooltalk_message, - 0, /*dumpable-flag*/ - mark_tooltalk_message, print_tooltalk_message, - 0, 0, 0, - tooltalk_message_description, - Lisp_Tooltalk_Message); +DEFINE_NODUMP_LISP_OBJECT ("tooltalk-message", tooltalk_message, + mark_tooltalk_message, print_tooltalk_message, + 0, 0, 0, + tooltalk_message_description, + Lisp_Tooltalk_Message); static Lisp_Object make_tooltalk_message (Tt_message m) { - Lisp_Object val; - Lisp_Tooltalk_Message *msg = - ALLOC_LCRECORD_TYPE (Lisp_Tooltalk_Message, &lrecord_tooltalk_message); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (tooltalk_message); + Lisp_Tooltalk_Message *msg = XTOOLTALK_MESSAGE (obj); msg->m = m; msg->callback = Qnil; msg->plist_sym = Fmake_symbol (Tooltalk_Message_plist_str); - return wrap_tooltalk_message (msg); + return obj; } Tt_message @@ -224,7 +222,7 @@ struct Lisp_Tooltalk_Pattern { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; Lisp_Object plist_sym, callback; Tt_pattern p; }; @@ -249,31 +247,29 @@ Lisp_Tooltalk_Pattern *p = XTOOLTALK_PATTERN (obj); if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string (printcharfun, "#<tooltalk-pattern id:0x%lx 0x%x>", - (long) (p->p), p->header.uid); + (long) (p->p), LISP_OBJECT_UID (obj)); } -DEFINE_LRECORD_IMPLEMENTATION ("tooltalk-pattern", tooltalk_pattern, - 0, /*dumpable-flag*/ - mark_tooltalk_pattern, print_tooltalk_pattern, - 0, 0, 0, - tooltalk_pattern_description, - Lisp_Tooltalk_Pattern); +DEFINE_NODUMP_LISP_OBJECT ("tooltalk-pattern", tooltalk_pattern, + mark_tooltalk_pattern, print_tooltalk_pattern, + 0, 0, 0, + tooltalk_pattern_description, + Lisp_Tooltalk_Pattern); static Lisp_Object make_tooltalk_pattern (Tt_pattern p) { - Lisp_Tooltalk_Pattern *pat = - ALLOC_LCRECORD_TYPE (Lisp_Tooltalk_Pattern, &lrecord_tooltalk_pattern); - Lisp_Object val; + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (tooltalk_pattern); + Lisp_Tooltalk_Pattern *pat = XTOOLTALK_PATTERN (obj); pat->p = p; pat->callback = Qnil; pat->plist_sym = Fmake_symbol (Tooltalk_Pattern_plist_str); - return wrap_tooltalk_pattern (pat); + return obj; } static Tt_pattern @@ -1314,8 +1310,8 @@ void syms_of_tooltalk (void) { - INIT_LRECORD_IMPLEMENTATION (tooltalk_message); - INIT_LRECORD_IMPLEMENTATION (tooltalk_pattern); + INIT_LISP_OBJECT (tooltalk_message); + INIT_LISP_OBJECT (tooltalk_pattern); DEFSYMBOL_MULTIWORD_PREDICATE (Qtooltalk_messagep); DEFSUBR (Ftooltalk_message_p);
--- a/src/tooltalk.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/tooltalk.h Mon Mar 29 21:28:13 2010 -0500 @@ -27,14 +27,14 @@ #include TT_C_H_FILE typedef struct Lisp_Tooltalk_Message Lisp_Tooltalk_Message; -DECLARE_LRECORD (tooltalk_message, Lisp_Tooltalk_Message); +DECLARE_LISP_OBJECT (tooltalk_message, Lisp_Tooltalk_Message); #define XTOOLTALK_MESSAGE(x) XRECORD (x, tooltalk_message, Lisp_Tooltalk_Message) #define wrap_tooltalk_message(p) wrap_record (p, tooltalk_message) #define TOOLTALK_MESSAGEP(x) RECORDP (x, tooltalk_message) #define CHECK_TOOLTALK_MESSAGE(x) CHECK_RECORD (x, tooltalk_message) typedef struct Lisp_Tooltalk_Pattern Lisp_Tooltalk_Pattern; -DECLARE_LRECORD (tooltalk_pattern, Lisp_Tooltalk_Pattern); +DECLARE_LISP_OBJECT (tooltalk_pattern, Lisp_Tooltalk_Pattern); #define XTOOLTALK_PATTERN(x) XRECORD (x, tooltalk_pattern, Lisp_Tooltalk_Pattern) #define wrap_tooltalk_pattern(p) wrap_record (p, tooltalk_pattern) #define TOOLTALK_PATTERNP(x) RECORDP (x, tooltalk_pattern)
--- a/src/ui-gtk.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/ui-gtk.c Mon Mar 29 21:28:13 2010 -0500 @@ -4,6 +4,7 @@ ** ** Created by: William M. Perry <wmperry@gnu.org> ** Copyright (c) 2000 William M. Perry <wmperry@gnu.org> +** Copyright (C) 2010 Ben Wing. ** ** This file is part of XEmacs. ** @@ -295,7 +296,8 @@ static emacs_ffi_data * allocate_ffi_data (void) { - emacs_ffi_data *data = ALLOC_LCRECORD_TYPE (emacs_ffi_data, &lrecord_emacs_ffi); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_ffi); + emacs_ffi_data *data = XFFI (obj); data->return_type = GTK_TYPE_NONE; data->n_args = 0; @@ -325,7 +327,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_fmt_string_lisp (printcharfun, "#<ffi %S", 1, XFFI (obj)->function_name); if (XFFI (obj)->n_args) @@ -333,11 +335,10 @@ write_fmt_string (printcharfun, " %p>", (void *)XFFI (obj)->function_ptr); } -DEFINE_LRECORD_IMPLEMENTATION ("ffi", emacs_ffi, - 0, /*dumpable-flag*/ - mark_ffi_data, ffi_object_printer, - 0, 0, 0, - ffi_data_description, emacs_ffi_data); +DEFINE_NODUMP_LISP_OBJECT ("ffi", emacs_ffi, + mark_ffi_data, ffi_object_printer, + 0, 0, 0, + ffi_data_description, emacs_ffi_data); #if defined (__cplusplus) #define MANY_ARGS ... @@ -795,7 +796,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<GtkObject ("); if (XGTK_OBJECT (obj)->alive_p) @@ -806,7 +807,7 @@ } static Lisp_Object -object_getprop (Lisp_Object obj, Lisp_Object prop) +emacs_gtk_object_getprop (Lisp_Object obj, Lisp_Object prop) { Lisp_Object rval = Qnil; Lisp_Object prop_name = Qnil; @@ -870,7 +871,7 @@ } static int -object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) +emacs_gtk_object_putprop (Lisp_Object obj, Lisp_Object prop, Lisp_Object value) { GtkArgInfo *info = NULL; Lisp_Object prop_name = Qnil; @@ -923,44 +924,28 @@ } static void -emacs_gtk_object_finalizer (void *header, int for_disksave) +emacs_gtk_object_finalizer (Lisp_Object obj) { - emacs_gtk_object_data *data = (emacs_gtk_object_data *) header; - - if (for_disksave) - { - Lisp_Object obj = wrap_emacs_gtk_object (data); - - - invalid_operation - ("Can't dump an emacs containing GtkObject objects", obj); - } + emacs_gtk_object_data *data = XEMACS_GTK_OBJECT_DATA (obj); if (data->alive_p) - { - gtk_object_unref (data->object); - } + gtk_object_unref (data->object); } -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkObject", emacs_gtk_object, - 0, /*dumpable-flag*/ - mark_gtk_object_data, - emacs_gtk_object_printer, - emacs_gtk_object_finalizer, - 0, /* equality */ - 0, /* hash */ - gtk_object_data_description, - object_getprop, - object_putprop, - 0, /* rem prop */ - 0, /* plist */ - emacs_gtk_object_data); +DEFINE_NODUMP_LISP_OBJECT ("GtkObject", emacs_gtk_object, + mark_gtk_object_data, + emacs_gtk_object_printer, + emacs_gtk_object_finalizer, + 0, /* equality */ + 0, /* hash */ + gtk_object_data_description, + emacs_gtk_object_data); static emacs_gtk_object_data * allocate_emacs_gtk_object_data (void) { - emacs_gtk_object_data *data = ALLOC_LCRECORD_TYPE (emacs_gtk_object_data, - &lrecord_emacs_gtk_object); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_gtk_object); + emacs_gtk_object_data *data = XGTK_OBJECT (obj); data->object = NULL; data->alive_p = FALSE; @@ -1114,7 +1099,7 @@ int UNUSED (escapeflag)) { if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<GtkBoxed ("); write_cistring (printcharfun, gtk_type_name (XGTK_BOXED (obj)->object_type)); @@ -1138,19 +1123,14 @@ return (HASH2 ((Hashcode) data->object, data->object_type)); } -DEFINE_LRECORD_IMPLEMENTATION_WITH_PROPS ("GtkBoxed", emacs_gtk_boxed, - 0, /*dumpable-flag*/ - 0, /* marker function */ - emacs_gtk_boxed_printer, - 0, /* nuker */ - emacs_gtk_boxed_equality, - emacs_gtk_boxed_hash, - emacs_gtk_boxed_description, - 0, /* get prop */ - 0, /* put prop */ - 0, /* rem prop */ - 0, /* plist */ - emacs_gtk_boxed_data); +DEFINE_NODUMP_LISP_OBJECT ("GtkBoxed", emacs_gtk_boxed, + 0, /* marker function */ + emacs_gtk_boxed_printer, + 0, /* nuker */ + emacs_gtk_boxed_equality, + emacs_gtk_boxed_hash, + emacs_gtk_boxed_description, + emacs_gtk_boxed_data); /* Currently defined GTK_TYPE_BOXED structures are: GtkAccelGroup - @@ -1168,8 +1148,8 @@ static emacs_gtk_boxed_data * allocate_emacs_gtk_boxed_data (void) { - emacs_gtk_boxed_data *data = ALLOC_LCRECORD_TYPE (emacs_gtk_boxed_data, - &lrecord_emacs_gtk_boxed); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (emacs_gtk_boxed); + emacs_gtk_boxed_data *data = XGTK_BOXED (obj); data->object = NULL; data->object_type = GTK_TYPE_INVALID; @@ -1353,11 +1333,19 @@ void +ui_gtk_objects_create (void) +{ + OBJECT_HAS_METHOD (emacs_gtk_object, getprop); + OBJECT_HAS_METHOD (emacs_gtk_object, putprop); + /* #### No remprop or plist methods */ +} + +void syms_of_ui_gtk (void) { - INIT_LRECORD_IMPLEMENTATION (emacs_ffi); - INIT_LRECORD_IMPLEMENTATION (emacs_gtk_object); - INIT_LRECORD_IMPLEMENTATION (emacs_gtk_boxed); + INIT_LISP_OBJECT (emacs_ffi); + INIT_LISP_OBJECT (emacs_gtk_object); + INIT_LISP_OBJECT (emacs_gtk_boxed); DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_ffip); DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_objectp); DEFSYMBOL_MULTIWORD_PREDICATE (Qemacs_gtk_boxedp);
--- a/src/ui-gtk.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/ui-gtk.h Mon Mar 29 21:28:13 2010 -0500 @@ -36,7 +36,7 @@ #define MAX_GTK_ARGS 100 typedef struct { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; GtkType return_type; GtkType args[MAX_GTK_ARGS]; gint n_args; @@ -45,7 +45,7 @@ ffi_marshalling_function marshal; } emacs_ffi_data; -DECLARE_LRECORD (emacs_ffi, emacs_ffi_data); +DECLARE_LISP_OBJECT (emacs_ffi, emacs_ffi_data); #define XFFI(x) XRECORD (x, emacs_ffi, emacs_ffi_data) #define wrap_emacs_ffi(p) wrap_record (p, emacs_ffi) @@ -54,13 +54,13 @@ /* Encapsulate a GtkObject in Lisp */ typedef struct { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; gboolean alive_p; GtkObject *object; Lisp_Object plist; } emacs_gtk_object_data; -DECLARE_LRECORD (emacs_gtk_object, emacs_gtk_object_data); +DECLARE_LISP_OBJECT (emacs_gtk_object, emacs_gtk_object_data); #define XGTK_OBJECT(x) XRECORD (x, emacs_gtk_object, emacs_gtk_object_data) #define wrap_emacs_gtk_object(p) wrap_record (p, emacs_gtk_object) @@ -71,12 +71,12 @@ /* Encapsulate a GTK_TYPE_BOXED in lisp */ typedef struct { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; GtkType object_type; void *object; } emacs_gtk_boxed_data; -DECLARE_LRECORD (emacs_gtk_boxed, emacs_gtk_boxed_data); +DECLARE_LISP_OBJECT (emacs_gtk_boxed, emacs_gtk_boxed_data); #define XGTK_BOXED(x) XRECORD (x, emacs_gtk_boxed, emacs_gtk_boxed_data) #define wrap_emacs_gtk_boxed(p) wrap_record (p, emacs_gtk_boxed)
--- a/src/unicode.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/unicode.c Mon Mar 29 21:28:13 2010 -0500 @@ -542,7 +542,7 @@ static Bytecount compute_from_unicode_table_size_1 (void *table, int level, - struct overhead_stats *stats) + struct usage_stats *stats) { int i; Bytecount size = 0; @@ -590,7 +590,7 @@ static Bytecount compute_to_unicode_table_size_1 (void *table, int level, - struct overhead_stats *stats) + struct usage_stats *stats) { Bytecount size = 0; @@ -615,7 +615,7 @@ Bytecount compute_from_unicode_table_size (Lisp_Object charset, - struct overhead_stats *stats) + struct usage_stats *stats) { return (compute_from_unicode_table_size_1 (XCHARSET_FROM_UNICODE_TABLE (charset), @@ -625,7 +625,7 @@ Bytecount compute_to_unicode_table_size (Lisp_Object charset, - struct overhead_stats *stats) + struct usage_stats *stats) { return (compute_to_unicode_table_size_1 (XCHARSET_TO_UNICODE_TABLE (charset),
--- a/src/vdb-posix.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/vdb-posix.c Mon Mar 29 21:28:13 2010 -0500 @@ -73,7 +73,7 @@ } else /* default sigsegv handler */ { - char *signal_name = ""; + const Ascbyte *signal_name = ""; if (signum == SIGSEGV) signal_name = "SIGSEGV"; else if (signum == SIGBUS)
--- a/src/window-impl.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/window-impl.h Mon Mar 29 21:28:13 2010 -0500 @@ -84,7 +84,7 @@ struct window { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* The upper left corner coordinates of this window, as integers (pixels) relative to upper left corner of frame = 0, 0 */ @@ -168,7 +168,7 @@ struct window_mirror { - struct LCRECORD_HEADER header; + NORMAL_LISP_OBJECT_HEADER header; /* Frame this mirror is on. */ struct frame *frame;
--- a/src/window.c Tue Feb 23 07:28:35 2010 -0600 +++ b/src/window.c Mon Mar 29 21:28:13 2010 -0500 @@ -55,7 +55,7 @@ Lisp_Object Qdisplay_buffer; #ifdef MEMORY_USAGE_STATS -Lisp_Object Qface_cache, Qglyph_cache, Qline_start_cache, Qother_redisplay; +Lisp_Object Qface_cache, Qglyph_cache, Qline_start_cache, Qredisplay_structs; #ifdef HAVE_SCROLLBARS Lisp_Object Qscrollbar_instances; #endif @@ -182,11 +182,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("face-cachel", face_cachel, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - face_cachel_description_1, - Lisp_Face_Cachel); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("face-cachel", face_cachel, + 0, face_cachel_description_1, + Lisp_Face_Cachel); #endif /* NEW_GC */ static const struct sized_memory_description face_cachel_description = { @@ -204,11 +202,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("face-cachel-dynarr", face_cachel_dynarr, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - face_cachel_dynarr_description_1, - face_cachel_dynarr); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("face-cachel-dynarr", face_cachel_dynarr, + 0, face_cachel_dynarr_description_1, + face_cachel_dynarr); #else /* not NEW_GC */ static const struct sized_memory_description face_cachel_dynarr_description = { sizeof (face_cachel_dynarr), @@ -222,11 +218,9 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("glyph-cachel", glyph_cachel, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - glyph_cachel_description_1, - Lisp_Glyph_Cachel); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("glyph-cachel", glyph_cachel, + 0, glyph_cachel_description_1, + Lisp_Glyph_Cachel); #endif /* NEW_GC */ static const struct sized_memory_description glyph_cachel_description = { @@ -244,11 +238,10 @@ }; #ifdef NEW_GC -DEFINE_LRECORD_IMPLEMENTATION ("glyph-cachel-dynarr", glyph_cachel_dynarr, - 1, /*dumpable-flag*/ - 0, 0, 0, 0, 0, - glyph_cachel_dynarr_description_1, - glyph_cachel_dynarr); +DEFINE_DUMPABLE_INTERNAL_LISP_OBJECT ("glyph-cachel-dynarr", + glyph_cachel_dynarr, 0, + glyph_cachel_dynarr_description_1, + glyph_cachel_dynarr); #else /* not NEW_GC */ static const struct sized_memory_description glyph_cachel_dynarr_description = { sizeof (glyph_cachel_dynarr), @@ -316,7 +309,7 @@ Lisp_Object buf; if (print_readably) - printing_unreadable_lcrecord (obj, 0); + printing_unreadable_lisp_object (obj, 0); write_ascstring (printcharfun, "#<window"); buf = XWINDOW_BUFFER (obj); @@ -328,13 +321,13 @@ Lisp_Object name = XBUFFER (buf)->name; write_fmt_string_lisp (printcharfun, " on %S", 1, name); } - write_fmt_string (printcharfun, " 0x%x>", XWINDOW (obj)->header.uid); + write_fmt_string (printcharfun, " 0x%x>", LISP_OBJECT_UID (obj)); } static void -finalize_window (void *header, int UNUSED (for_disksave)) -{ - struct window *w = (struct window *) header; +finalize_window (Lisp_Object obj) +{ + struct window *w = XWINDOW (obj); if (w->line_start_cache) { @@ -375,10 +368,9 @@ return make_lisp_hash_table (20, HASH_TABLE_KEY_WEAK, HASH_TABLE_EQ); } -DEFINE_LRECORD_IMPLEMENTATION ("window", window, - 0, /*dumpable-flag*/ - mark_window, print_window, finalize_window, - 0, 0, window_description, struct window); +DEFINE_NODUMP_LISP_OBJECT ("window", window, + mark_window, print_window, finalize_window, + 0, 0, window_description, struct window); #define INIT_DISP_VARIABLE(field, initialization) \ p->field[CURRENT_DISP] = initialization; \ @@ -397,8 +389,8 @@ Lisp_Object allocate_window (void) { - struct window *p = ALLOC_LCRECORD_TYPE (struct window, &lrecord_window); - Lisp_Object val = wrap_window (p); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (window); + struct window *p = XWINDOW (obj); #define WINDOW_SLOT(slot) p->slot = Qnil; #include "winslots.h" @@ -432,7 +424,7 @@ p->windows_changed = 1; p->shadow_thickness_changed = 1; - return val; + return obj; } #undef INIT_DISP_VARIABLE @@ -531,19 +523,18 @@ return Qnil; } -DEFINE_LRECORD_IMPLEMENTATION ("window-mirror", window_mirror, - 0, /*dumpable-flag*/ - mark_window_mirror, internal_object_printer, - 0, 0, 0, window_mirror_description, - struct window_mirror); +DEFINE_NODUMP_INTERNAL_LISP_OBJECT ("window-mirror", window_mirror, + mark_window_mirror, + window_mirror_description, + struct window_mirror); /* Create a new window mirror structure and associated redisplay structs. */ static struct window_mirror * new_window_mirror (struct frame *f) { - struct window_mirror *t = - ALLOC_LCRECORD_TYPE (struct window_mirror, &lrecord_window_mirror); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (window_mirror); + struct window_mirror *t = XWINDOW_MIRROR (obj); t->frame = f; t->current_display_lines = Dynarr_new (display_line); @@ -636,7 +627,7 @@ find_window_mirror_internal (Lisp_Object win, struct window_mirror *rmir, struct window *w) { - for (; !NILP (win); win = XWINDOW (win)->next, rmir = rmir->next) + for (; !NILP (win) && rmir; win = XWINDOW (win)->next, rmir = rmir->next) { if (w == XWINDOW (win)) return rmir; @@ -687,7 +678,7 @@ #endif free_display_structs (mir); mir = mir->next; - /* not worth calling free_managed_lcrecord() -- window mirrors + /* not worth calling free_normal_lisp_object() -- window mirrors are not created that frequently and it's dangerous. we don't know for sure that there aren't other pointers around -- e.g. in a scrollbar instance. */ @@ -719,6 +710,18 @@ XWINDOW_MIRROR (f->root_mirror), w); } +/* Given a real window, return its mirror structure, if it exists. + Don't do any updating. */ +static struct window_mirror * +find_window_mirror_maybe (struct window *w) +{ + struct frame *f = XFRAME (w->frame); + if (!WINDOW_MIRRORP (f->root_mirror)) + return 0; + return find_window_mirror_internal (f->root_window, + XWINDOW_MIRROR (f->root_mirror), w); +} + /***************************************************************************** find_window_by_pixel_pos @@ -761,8 +764,6 @@ { struct window_mirror *t; - if (XFRAME (w->frame)->mirror_dirty) - update_frame_window_mirror (XFRAME (w->frame)); t = find_window_mirror (w); assert (t); @@ -784,8 +785,6 @@ { struct window_mirror *t; - if (XFRAME (w->frame)->mirror_dirty) - update_frame_window_mirror (XFRAME (w->frame)); t = find_window_mirror (w); assert (t); @@ -797,8 +796,6 @@ { struct window_mirror *t; - if (XFRAME (w->frame)->mirror_dirty) - update_frame_window_mirror (XFRAME (w->frame)); t = find_window_mirror (w); assert (t); @@ -1813,10 +1810,8 @@ struct window *w = decode_window (window); struct frame *f = XFRAME (w->frame); - int left = - w->pixel_left - FRAME_LEFT_BORDER_END (f) - FRAME_LEFT_GUTTER_BOUNDS (f); - int top = - w->pixel_top - FRAME_TOP_BORDER_END (f) - FRAME_TOP_GUTTER_BOUNDS (f); + int left = w->pixel_left - FRAME_PANED_LEFT_EDGE (f); + int top = w->pixel_top - FRAME_PANED_TOP_EDGE (f); return list4 (make_int (left), make_int (top), @@ -2146,7 +2141,7 @@ /* Free the extra data structures attached to windows immediately so they don't sit around consuming excess space. They will be reinitialized by the window-configuration code as necessary. */ - finalize_window ((void *) w, 0); + finalize_window (wrap_window (w)); /* Nobody should be accessing anything in this object any more, and making them Qnil allows for better GC'ing in case a pointer @@ -3874,12 +3869,11 @@ static void make_dummy_parent (Lisp_Object window) { - Lisp_Object new_; struct window *o = XWINDOW (window); - struct window *p = ALLOC_LCRECORD_TYPE (struct window, &lrecord_window); - - new_ = wrap_window (p); - COPY_LCRECORD (p, o); + Lisp_Object obj = ALLOC_NORMAL_LISP_OBJECT (window); + struct window *p = XWINDOW (obj); + + copy_lisp_object (obj, window); /* Don't copy the pointers to the line start cache or the face instances. */ @@ -3899,13 +3893,13 @@ make_image_instance_cache_hash_table (); /* Put new into window structure in place of window */ - replace_window (window, new_); + replace_window (window, obj); o->next = Qnil; o->prev = Qnil; o->vchild = Qnil; o->hchild = Qnil; - o->parent = new_; + o->parent = obj; p->start[CURRENT_DISP] = Qnil; p->start[DESIRED_DISP] = Qnil; @@ -5168,103 +5162,106 @@ #ifdef MEMORY_USAGE_STATS -struct window_stats -{ - int face; - int glyph; +struct window_mirror_stats +{ + struct usage_stats u; + /* Ancilliary non-lisp */ + Bytecount redisplay_structs; #ifdef HAVE_SCROLLBARS - int scrollbar; + /* Ancilliary Lisp */ + Bytecount scrollbar; #endif - int line_start; - int other_redisplay; - int other; +}; + +struct window_stats +{ + struct usage_stats u; + /* Ancillary non-Lisp */ + Bytecount line_start; + /* The next two: ancillary non-Lisp under old-GC, ancillary Lisp under + NEW_GC */ + Bytecount face; + Bytecount glyph; + /* The next two are copied out of the window mirror, which is an ancillary + Lisp structure; the first is non-Lisp, the second Lisp, but from our + perspective, they are both counted as Lisp */ + Bytecount redisplay_structs; +#ifdef HAVE_SCROLLBARS + Bytecount scrollbar; +#endif + /* Remaining memory associated with window mirror (ancillary Lisp) */ + Bytecount window_mirror; }; static void compute_window_mirror_usage (struct window_mirror *mir, - struct window_stats *stats, - struct overhead_stats *ovstats) -{ - if (!mir) - return; - stats->other += LISPOBJ_STORAGE_SIZE (mir, sizeof (*mir), ovstats); + struct window_mirror_stats *stats) +{ + stats->redisplay_structs = + compute_display_line_dynarr_usage (mir->current_display_lines, &stats->u) + + + compute_display_line_dynarr_usage (mir->desired_display_lines, &stats->u); #ifdef HAVE_SCROLLBARS - { - struct device *d = XDEVICE (FRAME_DEVICE (mir->frame)); - - stats->scrollbar += - compute_scrollbar_instance_usage (d, mir->scrollbar_vertical_instance, - ovstats); - stats->scrollbar += - compute_scrollbar_instance_usage (d, mir->scrollbar_horizontal_instance, - ovstats); - } + stats->scrollbar = + compute_all_scrollbar_instance_usage (mir->scrollbar_vertical_instance) + + compute_all_scrollbar_instance_usage (mir->scrollbar_horizontal_instance); #endif /* HAVE_SCROLLBARS */ - stats->other_redisplay += - compute_display_line_dynarr_usage (mir->current_display_lines, ovstats); - stats->other_redisplay += - compute_display_line_dynarr_usage (mir->desired_display_lines, ovstats); +} + + +static void +window_mirror_memory_usage (Lisp_Object window_mirror, + struct generic_usage_stats *gustats) +{ + struct window_mirror_stats *stats = (struct window_mirror_stats *) gustats; + + compute_window_mirror_usage (XWINDOW_MIRROR (window_mirror), stats); } static void compute_window_usage (struct window *w, struct window_stats *stats, - struct overhead_stats *ovstats) -{ - xzero (*stats); - stats->other += LISPOBJ_STORAGE_SIZE (w, sizeof (*w), ovstats); - stats->face += compute_face_cachel_usage (w->face_cachels, ovstats); - stats->glyph += compute_glyph_cachel_usage (w->glyph_cachels, ovstats); - stats->line_start += - compute_line_start_cache_dynarr_usage (w->line_start_cache, ovstats); - compute_window_mirror_usage (find_window_mirror (w), stats, ovstats); + struct usage_stats *ustats) +{ + stats->line_start = + compute_line_start_cache_dynarr_usage (w->line_start_cache, ustats); + stats->face = compute_face_cachel_usage (w->face_cachels, + IF_OLD_GC (ustats)); + stats->glyph = compute_glyph_cachel_usage (w->glyph_cachels, + IF_OLD_GC (ustats)); + { + struct window_mirror *wm; + + wm = find_window_mirror_maybe (w); + if (wm) + { + struct generic_usage_stats gustats; + struct window_mirror_stats *wmstats; + Bytecount total; + total = lisp_object_memory_usage_full (wrap_window_mirror (wm), + NULL, NULL, NULL, &gustats); + wmstats = (struct window_mirror_stats *) &gustats; + stats->redisplay_structs = wmstats->redisplay_structs; + total -= stats->redisplay_structs; +#ifdef HAVE_SCROLLBARS + stats->scrollbar = wmstats->scrollbar; + total -= stats->scrollbar; +#endif + stats->window_mirror = total; + } + } } -DEFUN ("window-memory-usage", Fwindow_memory_usage, 1, 1, 0, /* -Return stats about the memory usage of window WINDOW. -The values returned are in the form of an alist of usage types and byte -counts. The byte counts attempt to encompass all the memory used -by the window (separate from the memory logically associated with a -buffer or frame), including internal structures and any malloc() -overhead associated with them. In practice, the byte counts are -underestimated because certain memory usage is very hard to determine -\(e.g. the amount of memory used inside the Xt library or inside the -X server) and because there is other stuff that might logically -be associated with a window, buffer, or frame (e.g. window configurations, -glyphs) but should not obviously be included in the usage counts. - -Multiple slices of the total memory usage may be returned, separated -by a nil. Each slice represents a particular view of the memory, a -particular way of partitioning it into groups. Within a slice, there -is no overlap between the groups of memory, and each slice collectively -represents all the memory concerned. -*/ - (window)) -{ - struct window_stats stats; - struct overhead_stats ovstats; - Lisp_Object val = Qnil; - - CHECK_WINDOW (window); /* dead windows should be allowed, no? */ - xzero (ovstats); - compute_window_usage (XWINDOW (window), &stats, &ovstats); - - val = acons (Qface_cache, make_int (stats.face), val); - val = acons (Qglyph_cache, make_int (stats.glyph), val); -#ifdef HAVE_SCROLLBARS - val = acons (Qscrollbar_instances, make_int (stats.scrollbar), val); -#endif - val = acons (Qline_start_cache, make_int (stats.line_start), val); - val = acons (Qother_redisplay, make_int (stats.other_redisplay), val); - val = acons (Qother, make_int (stats.other), val); - val = Fcons (Qnil, val); - val = acons (Qactually_requested, make_int (ovstats.was_requested), val); - val = acons (Qmalloc_overhead, make_int (ovstats.malloc_overhead), val); - val = acons (Qdynarr_overhead, make_int (ovstats.dynarr_overhead), val); - - return Fnreverse (val); +static void +window_memory_usage (Lisp_Object window, struct generic_usage_stats *gustats) +{ + struct window_stats *stats = (struct window_stats *) gustats; + + compute_window_usage (XWINDOW (window), stats, &stats->u); } #endif /* MEMORY_USAGE_STATS */ + + /* Mark all subwindows of a window as deleted. The argument W is actually the subwindow tree of the window in question. */ @@ -5418,7 +5415,7 @@ if (!NILP (buffer) && BUFFERP (buffer)) stderr_out (" on %s", XSTRING_DATA (XBUFFER (buffer)->name)); } - stderr_out (" 0x%x>", XWINDOW (window)->header.uid); + stderr_out (" 0x%x>", LISP_OBJECT_UID (window)); while (!NILP (child)) { @@ -5442,15 +5439,24 @@ /************************************************************************/ void +window_objects_create (void) +{ +#ifdef MEMORY_USAGE_STATS + OBJECT_HAS_METHOD (window, memory_usage); + OBJECT_HAS_METHOD (window_mirror, memory_usage); +#endif +} + +void syms_of_window (void) { - INIT_LRECORD_IMPLEMENTATION (window); - INIT_LRECORD_IMPLEMENTATION (window_mirror); + INIT_LISP_OBJECT (window); + INIT_LISP_OBJECT (window_mirror); #ifdef NEW_GC - INIT_LRECORD_IMPLEMENTATION (face_cachel); - INIT_LRECORD_IMPLEMENTATION (face_cachel_dynarr); - INIT_LRECORD_IMPLEMENTATION (glyph_cachel); - INIT_LRECORD_IMPLEMENTATION (glyph_cachel_dynarr); + INIT_LISP_OBJECT (face_cachel); + INIT_LISP_OBJECT (face_cachel_dynarr); + INIT_LISP_OBJECT (glyph_cachel); + INIT_LISP_OBJECT (glyph_cachel_dynarr); #endif /* NEW_GC */ DEFSYMBOL (Qwindowp); @@ -5464,8 +5470,7 @@ #ifdef HAVE_SCROLLBARS DEFSYMBOL (Qscrollbar_instances); #endif - DEFSYMBOL (Qother_redisplay); - /* Qother in general.c */ + DEFSYMBOL (Qredisplay_structs); #endif DEFSYMBOL (Qtruncate_partial_width_windows); @@ -5543,9 +5548,6 @@ DEFSUBR (Fscroll_other_window); DEFSUBR (Fcenter_to_window_line); DEFSUBR (Fmove_to_window_line); -#ifdef MEMORY_USAGE_STATS - DEFSUBR (Fwindow_memory_usage); -#endif DEFSUBR (Fcurrent_pixel_column); DEFSUBR (Fcurrent_pixel_row); } @@ -5561,6 +5563,34 @@ void vars_of_window (void) { +#ifdef MEMORY_USAGE_STATS + Lisp_Object l; + + l = listu (Qline_start_cache, +#ifdef NEW_GC + Qt, +#endif + Qface_cache, Qglyph_cache, +#ifndef NEW_GC + Qt, +#endif + Qredisplay_structs, +#ifdef HAVE_SCROLLBARS + Qscrollbar_instances, +#endif + intern ("window-mirror"), + Qunbound); + + OBJECT_HAS_PROPERTY (window, memusage_stats_list, l); + + l = listu (Qredisplay_structs, +#ifdef HAVE_SCROLLBARS + Qt, Qscrollbar_instances, +#endif + Qunbound); + OBJECT_HAS_PROPERTY (window_mirror, memusage_stats_list, l); +#endif /* MEMORY_USAGE_STATS */ + DEFVAR_BOOL ("scroll-on-clipped-lines", &scroll_on_clipped_lines /* *Non-nil means to scroll if point lands on a line which is clipped. */ );
--- a/src/window.h Tue Feb 23 07:28:35 2010 -0600 +++ b/src/window.h Mon Mar 29 21:28:13 2010 -0500 @@ -34,7 +34,7 @@ struct window; -DECLARE_LRECORD (window, struct window); +DECLARE_LISP_OBJECT (window, struct window); #define XWINDOW(x) XRECORD (x, window, struct window) #define wrap_window(p) wrap_record (p, window) #define WINDOWP(x) RECORDP (x, window) @@ -81,15 +81,13 @@ struct window_mirror; -DECLARE_LRECORD (window_mirror, struct window_mirror); +DECLARE_LISP_OBJECT (window_mirror, struct window_mirror); #define XWINDOW_MIRROR(x) XRECORD (x, window_mirror, struct window_mirror) #define wrap_window_mirror(p) wrap_record (p, window_mirror) #define WINDOW_MIRRORP(x) RECORDP (x, window_mirror) #define CHECK_WINDOW_MIRROR(x) CHECK_RECORD (x, window_mirror) #define CONCHECK_WINDOW_MIRROR(x) CONCHECK_RECORD (x, window_mirror) -DECLARE_LRECORD (window_configuration, struct window_config); - EXFUN (Fget_buffer_window, 3); EXFUN (Fmove_to_window_line, 2); EXFUN (Frecenter, 2);
--- a/src/xemacs.def.in.in Tue Feb 23 07:28:35 2010 -0600 +++ b/src/xemacs.def.in.in Mon Mar 29 21:28:13 2010 -0500 @@ -36,7 +36,8 @@ /* Exported functions */ acons #ifdef NEW_GC -alloc_lrecord /* alloc_lrecord_type */ +alloc_lrecord /* ALLOC_LISP_OBJECT */ +alloc_sized_lrecord /* ALLOC_SIZED_LISP_OBJECT */ lrecord_subr /* DEFSUBR */ lrecord_symbol_value_forward /* DEFVAR_SYMVAL_FWD */ #ifdef DEBUG_XEMACS @@ -44,7 +45,8 @@ #endif mc_alloc /* DEFSUBR */ #else /* not NEW_GC */ -alloc_automanaged_lcrecord /* old_alloc_lcrecord_type */ +alloc_automanaged_lcrecord /* ALLOC_LISP_OBJECT */ +old_alloc_sized_lcrecord /* ALLOC_SIZED_LISP_OBJECT */ #endif /* not NEW_GC */ apply1 #ifdef USE_ASSERTIONS @@ -128,6 +130,7 @@ error_check_string_direct_data error_check_string_indirect_data #endif +error_check_symbol_value_forward #endif /* XEMACS_DEFS_NEEDS_ERROR_CHECK_TYPES_DECLS */ free_opaque_ptr get_coding_system_for_text_file @@ -161,7 +164,8 @@ non_ascii_valid_ichar_p /* valid_ichar_p */ #endif out_of_memory /* The postgresql module uses this */ -printing_unreadable_object +printing_unreadable_lisp_object +printing_unreadable_object_fmt #ifdef XEMACS_DEFS_NEEDS_INLINE_DECLS qxestrdup qxestrlen
--- a/tests/ChangeLog Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/ChangeLog Mon Mar 29 21:28:13 2010 -0500 @@ -1,3 +1,116 @@ +2010-03-18 Ben Wing <ben@xemacs.org> + + * automated/c-tests.el: + * automated/c-tests.el (when): + Use `with-temp-buffer' so results don't get written into source + file. + +2010-03-12 Ben Wing <ben@xemacs.org> + + * automated/base64-tests.el (bt-base64-encode-string): + * automated/base64-tests.el (bt-base64-decode-string): + * automated/base64-tests.el (for): + * automated/byte-compiler-tests.el: + * automated/byte-compiler-tests.el (before-and-after-compile-equal): + * automated/case-tests.el (downcase-string): + * automated/case-tests.el (uni-mappings): + * automated/ccl-tests.el (ccl-test-normal-expr): + * automated/ccl-tests.el (ccl-test-map-instructions): + * automated/ccl-tests.el (ccl-test-suites): + * automated/database-tests.el (delete-database-files): + * automated/extent-tests.el (let): + * automated/extent-tests.el (insert): + * automated/extent-tests.el (props): + * automated/file-tests.el: + * automated/file-tests.el (for): + * automated/hash-table-tests.el (test): + * automated/hash-table-tests.el (for): + * automated/hash-table-tests.el (ht): + * automated/hash-table-tests.el (iterations): + * automated/hash-table-tests.el (h1): + * automated/hash-table-tests.el (equal): + * automated/hash-table-tests.el (=): + * automated/lisp-tests.el: + * automated/lisp-tests.el (eq): + * automated/lisp-tests.el (test-setq): + * automated/lisp-tests.el (my-vector): + * automated/lisp-tests.el (x): + * automated/lisp-tests.el (equal): + * automated/lisp-tests.el (y): + * automated/lisp-tests.el (featurep): + * automated/lisp-tests.el (=): + * automated/lisp-tests.el (six): + * automated/lisp-tests.el (three): + * automated/lisp-tests.el (one): + * automated/lisp-tests.el (two): + * automated/lisp-tests.el (five): + * automated/lisp-tests.el (test1): + * automated/lisp-tests.el (division-test): + * automated/lisp-tests.el (for): + * automated/lisp-tests.el (check-function-argcounts): + * automated/lisp-tests.el (z): + * automated/lisp-tests.el (eql): + * automated/lisp-tests.el (test-harness-risk-infloops): + * automated/lisp-tests.el (erase-buffer): + * automated/lisp-tests.el (sym): + * automated/lisp-tests.el (new-char): + * automated/lisp-tests.el (new-load-file-name): + * automated/lisp-tests.el (cl-floor): + * automated/lisp-tests.el (foo): + * automated/md5-tests.el (lambda): + * automated/md5-tests.el (large-string): + * automated/md5-tests.el (mapcar): + * automated/md5-tests.el (insert): + * automated/mule-tests.el: + * automated/mule-tests.el (test-chars): + * automated/mule-tests.el (existing-file-name): + * automated/mule-tests.el (featurep): + * automated/query-coding-tests.el (featurep): + * automated/regexp-tests.el: + * automated/regexp-tests.el (insert): + * automated/regexp-tests.el (Assert): + * automated/regexp-tests.el (=): + * automated/regexp-tests.el (featurep): + * automated/regexp-tests.el (text): + * automated/regexp-tests.el (text1): + * automated/regexp-tests.el ("aáa"): + * automated/regexp-tests.el (eql): + * automated/search-tests.el (insert): + * automated/search-tests.el (featurep): + * automated/search-tests.el (let): + * automated/search-tests.el (boundp): + * automated/symbol-tests.el: + * automated/symbol-tests.el (name): + * automated/symbol-tests.el (check-weak-list-unique): + * automated/symbol-tests.el (string): + * automated/symbol-tests.el (list): + * automated/symbol-tests.el (foo): + * automated/symbol-tests.el (eq): + * automated/symbol-tests.el (fresh-keyword-name): + * automated/symbol-tests.el (print-gensym): + * automated/symbol-tests.el (mysym): + * automated/syntax-tests.el (test-forward-word): + * automated/syntax-tests.el (test-backward-word): + * automated/syntax-tests.el (test-syntax-table): + * automated/syntax-tests.el (with-syntax-table): + * automated/syntax-tests.el (Skip-Test-Unless): + * automated/syntax-tests.el (with): + * automated/tag-tests.el (testfile): + * automated/weak-tests.el (w): + * automated/weak-tests.el (p): + * automated/weak-tests.el (a): + Undo change of e.g. (Assert (equalp ...)) to (Assert-equalp ...). + Get rid of `Assert-equalp' and friends, `Assert-test', and + `Assert-test-not'. Instead, make `Assert' smart enough to do the + equivalent functionality when an expression like (Assert (equalp ...)) + is seen. + +2010-03-07 Stephen J. Turnbull <stephen@xemacs.org> + + * automated/mule-tests.el (string character conversion): + Test escape-quoted for the range U+0000 to U+00FF. + Inspired by Ben's patch to fix quoting of specials from C1 controls. + 2010-02-22 Ben Wing <ben@xemacs.org> * reproduce-crashes.el (8):
--- a/tests/automated/base64-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/base64-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -52,8 +52,8 @@ (erase-buffer) (insert string) (setq length (base64-encode-region (point-min) (point-max) no-line-break)) - (Assert-eq length (- (point-max) (point-min))) - (Assert-equal (buffer-string) string-result) + (Assert (eq length (- (point-max) (point-min)))) + (Assert (equal (buffer-string) string-result)) ;; partial (erase-buffer) (insert "random junk........\0\0';'eqwrkw[erpqf") @@ -62,8 +62,8 @@ (setq p2 (point-marker)) (insert "...more random junk.q,f3/.qrm314.r,m2typ' 2436T@W$^@$#^T@") (setq length (base64-encode-region p1 p2 no-line-break)) - (Assert-eq length (- p2 p1)) - (Assert-equal (buffer-substring p1 p2) string-result))) + (Assert (eq length (- p2 p1))) + (Assert (equal (buffer-substring p1 p2) string-result)))) string-result)) (defun bt-base64-decode-string (string) @@ -75,12 +75,12 @@ (insert string) (setq length (base64-decode-region (point-min) (point-max))) (cond (string-result - (Assert-eq length (- (point-max) (point-min))) - (Assert-equal (buffer-string) string-result)) + (Assert (eq length (- (point-max) (point-min)))) + (Assert (equal (buffer-string) string-result))) (t (Assert (null length)) ;; The buffer should not have been modified. - (Assert-equal (buffer-string) string))) + (Assert (equal (buffer-string) string)))) ;; partial (erase-buffer) (insert "random junk........\0\0';'eqwrkw[erpqf") @@ -90,12 +90,12 @@ (insert "...more random junk.q,f3/.qrm314.\0\0r,m2typ' 2436T@W$^@$#T@") (setq length (base64-decode-region p1 p2)) (cond (string-result - (Assert-eq length (- p2 p1)) - (Assert-equal (buffer-substring p1 p2) string-result)) + (Assert (eq length (- p2 p1))) + (Assert (equal (buffer-substring p1 p2) string-result))) (t (Assert (null length)) ;; The buffer should not have been modified. - (Assert-equal (buffer-substring p1 p2) string))))) + (Assert (equal (buffer-substring p1 p2) string)))))) string-result)) (defun bt-remove-newlines (str) @@ -126,9 +126,9 @@ ;;----------------------------------------------------- (loop for (raw encoded) in bt-test-strings do - (Assert-equal (bt-base64-encode-string raw) encoded) + (Assert (equal (bt-base64-encode-string raw) encoded)) ;; test the NO-LINE-BREAK flag - (Assert-equal (bt-base64-encode-string raw t) (bt-remove-newlines encoded))) + (Assert (equal (bt-base64-encode-string raw t) (bt-remove-newlines encoded)))) ;; When Mule is around, Lisp programmers should make sure that the ;; buffer contains only characters whose `char-int' is in the [0, 256) @@ -150,8 +150,8 @@ ;;----------------------------------------------------- (loop for (raw encoded) in bt-test-strings do - (Assert-equal (bt-base64-decode-string encoded) raw) - (Assert-equal (bt-base64-decode-string (bt-remove-newlines encoded)) raw)) + (Assert (equal (bt-base64-decode-string encoded) raw)) + (Assert (equal (bt-base64-decode-string (bt-remove-newlines encoded)) raw))) ;; Test errors (dolist (str `("foo" "AAC" "foo\0bar" "====" "Zm=9v" ,bt-allchars)) @@ -182,7 +182,7 @@ ;; Whitespace at the beginning, end, and middle. (let ((mangled (concat bt-nonbase64-chars left bt-nonbase64-chars right bt-nonbase64-chars))) - (Assert-equal (bt-base64-decode-string mangled) raw)) + (Assert (equal (bt-base64-decode-string mangled) raw))) ;; Whitespace between every char. (let ((mangled (concat bt-nonbase64-chars @@ -191,7 +191,7 @@ (mapconcat #'char-to-string encoded (apply #'string bt-nonbase64-chars)) bt-nonbase64-chars))) - (Assert-equal (bt-base64-decode-string mangled) raw))))) + (Assert (equal (bt-base64-decode-string mangled) raw)))))) ;;----------------------------------------------------- ;; Mixed... @@ -205,22 +205,22 @@ ;; practically all aspects of the encoding and decoding process. (loop for (raw ignored) in bt-test-strings do - (Assert-equal (bt-base64-decode-string + (Assert (equal (bt-base64-decode-string (bt-base64-encode-string raw)) - raw) - (Assert-equal (bt-base64-decode-string + raw)) + (Assert (equal (bt-base64-decode-string (bt-base64-decode-string (bt-base64-encode-string (bt-base64-encode-string raw)))) - raw) - (Assert-equal (bt-base64-decode-string + raw)) + (Assert (equal (bt-base64-decode-string (bt-base64-decode-string (bt-base64-decode-string (bt-base64-encode-string (bt-base64-encode-string (bt-base64-encode-string raw)))))) - raw) - (Assert-equal (bt-base64-decode-string + raw)) + (Assert (equal (bt-base64-decode-string (bt-base64-decode-string (bt-base64-decode-string (bt-base64-decode-string @@ -228,8 +228,8 @@ (bt-base64-encode-string (bt-base64-encode-string (bt-base64-encode-string raw)))))))) - raw) - (Assert-equal (bt-base64-decode-string + raw)) + (Assert (equal (bt-base64-decode-string (bt-base64-decode-string (bt-base64-decode-string (bt-base64-decode-string @@ -239,4 +239,4 @@ (bt-base64-encode-string (bt-base64-encode-string (bt-base64-encode-string raw)))))))))) - raw)) + raw)))
--- a/tests/automated/byte-compiler-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/byte-compiler-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -92,8 +92,8 @@ (eval '(let* ((x 1 2)) 3))) (defmacro before-and-after-compile-equal (&rest form) - `(Assert-equal (funcall (quote (lambda () ,@form))) - (funcall (byte-compile (quote (lambda () ,@form)))))) + `(Assert (equal (funcall (quote (lambda () ,@form))) + (funcall (byte-compile (quote (lambda () ,@form))))))) (defvar simplyamarker (point-min-marker))
--- a/tests/automated/c-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/c-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -1,4 +1,5 @@ ;; Copyright (C) 2000 Martin Buchholz +;; Copyright (C) 2010 Ben Wing. ;; Author: Martin Buchholz <martin@xemacs.org> ;; Maintainer: Martin Buchholz <martin@xemacs.org> @@ -38,8 +39,9 @@ (push (file-name-directory load-file-name) load-path)) (require 'test-harness)))) -(when (boundp 'test-function-list) ; Only if configure --debug - (loop for fun in test-function-list do - ;; #### I hope there's no way we can signal ... - (loop for result in (funcall fun) do - (Assert (nth 1 result) (nth 2 result) (nth 0 result))))) +(with-temp-buffer + (when (boundp 'test-function-list) ; Only if configure --debug + (loop for fun in test-function-list do + ;; #### I hope there's no way we can signal ... + (loop for result in (funcall fun) do + (Assert (nth 1 result) (nth 2 result) (nth 0 result))))))
--- a/tests/automated/case-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/case-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -109,10 +109,10 @@ "¡¢£¤¥¦§¨©ª«¬®¯°±²³´µ¶·¸¹º»¼½¾¿àáâãäåæçèéêëìíîïðñòóôõö×øùúûüýþßÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ÷ØÙÚÛÜÝÞÿ")) (table (standard-case-table))) (dotimes (i 256) - (Assert-eq (get-case-table 'downcase (int-to-char i) table) - (aref downcase-string i)) - (Assert-eq (get-case-table 'upcase (int-to-char i) table) - (aref upcase-string i)))) + (Assert (eq (get-case-table 'downcase (int-to-char i) table) + (aref downcase-string i))) + (Assert (eq (get-case-table 'upcase (int-to-char i) table) + (aref upcase-string i))))) (Check-Error-Message error "Char case must be downcase or upcase" (get-case-table 'foo ?a (standard-case-table))) @@ -1507,19 +1507,19 @@ ;; using downcase and upcase, however, won't necessarily work in ;; the presence of such mappings -- that's what the internal canon ;; and eqv tables are for. - (Assert-equalp lowermulti uppermulti) - (Assert-equalp loweruppermulti upperlowermulti) - (Assert-equal lower (downcase upper)) - (Assert-equal upper (upcase lower)) - (Assert-equal (downcase lower) (downcase (downcase lower))) - (Assert-equal (upcase lowerupper) (upcase upperlower)) - (Assert-equal (downcase lowerupper) (downcase upperlower)) + (Assert (equalp lowermulti uppermulti)) + (Assert (equalp loweruppermulti upperlowermulti)) + (Assert (equal lower (downcase upper))) + (Assert (equal upper (upcase lower))) + (Assert (equal (downcase lower) (downcase (downcase lower)))) + (Assert (equal (upcase lowerupper) (upcase upperlower))) + (Assert (equal (downcase lowerupper) (downcase upperlower))) ;; Individually -- we include multi-mappings since we're using ;; `equalp'. (loop for (uc lc) in uni-mappings do - (Assert-equalp uc lc) - (Assert-equalp (string uc) (string lc))) + (Assert (equalp uc lc)) + (Assert (equalp (string uc) (string lc)))) ) ;; Here we include multi-mappings -- searching should be able to @@ -1532,14 +1532,14 @@ (,upperlowermulti ,loweruppermulti)) do (erase-buffer) - (Assert= (point-min) 1) - (Assert= (point) 1) + (Assert (= (point-min) 1)) + (Assert (= (point) 1)) (insert str1) (let ((point (point)) (case-fold-search t)) - (Assert= (length str1) (1- point)) + (Assert (= (length str1) (1- point))) (goto-char (point-min)) - (Assert-eql (search-forward str2 nil t) point))) + (Assert (eql (search-forward str2 nil t) point)))) (loop for (uc lc) in uni-mappings do (loop for (ch1 ch2) in `((,uc ,lc) (,lc ,uc)) @@ -1549,8 +1549,8 @@ (insert ch1) (insert ?1) (goto-char (point-min)) - (Assert-eql (search-forward (char-to-string ch2) nil t) 3 - (format "Case-folded searching doesn't equate %s and %s" - (char-as-unicode-escape ch1) - (char-as-unicode-escape ch2)))))) + (Assert (eql (search-forward (char-to-string ch2) nil t) 3) + (format "Case-folded searching doesn't equate %s and %s" + (char-as-unicode-escape ch1) + (char-as-unicode-escape ch2)))))) )))
--- a/tests/automated/ccl-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/ccl-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -141,9 +141,9 @@ (defun ccl-test-normal-expr () ;; normal-expr (let ((r0 0) (r1 10) (r2 20) (r3 21) (r4 7)) - (Assert= (ccl-test '(0 ((r0 = ((((r1 * r2) + r3) % r4) << 2)))) + (Assert (= (ccl-test '(0 ((r0 = ((((r1 * r2) + r3) % r4) << 2)))) (list r0 r1 r2 r3 r4)) - (ash (% (+ (* r1 r2) r3) r4) 2))) + (ash (% (+ (* r1 r2) r3) r4) 2)))) (Assert (\= (ccl-test '(0 ((r2 = (r1 < 10)) (r0 = (r2 > 10)))) @@ -151,9 +151,9 @@ 0)) (let ((r0 0) (r1 #x10FF) (r2 #xCC) (r3 #xE0)) - (Assert= (ccl-test '(0 ((r0 = (((r1 & #xFF) ^ r2) | r3)))) + (Assert (= (ccl-test '(0 ((r0 = (((r1 & #xFF) ^ r2) | r3)))) (list r0 r1 r2 r3)) - (logior (logxor (logand r1 #xFF) r2) r3))) + (logior (logxor (logand r1 #xFF) r2) r3)))) ;; checking range of SJIS ;; 81(40-7E, 80-FC), 82, 9F, E0, E1, EF @@ -187,16 +187,16 @@ (setq low (1+ low))))) ;; self-expr - (Assert= (ccl-test '(0 ((r0 += 20) + (Assert (= (ccl-test '(0 ((r0 += 20) (r0 *= 40) (r0 -= 15))) '(100)) - (- (* (+ 100 20) 40) 15)) + (- (* (+ 100 20) 40) 15))) ;; ref. array - (Assert= (ccl-test '(0 ((r0 = r0 [100 101 102 103 104]))) + (Assert (= (ccl-test '(0 ((r0 = r0 [100 101 102 103 104]))) '(3)) - 103)) + 103))) ;;; Section 2. Simple read and write (defun ccl-test-simple-read-and-write () @@ -360,7 +360,7 @@ ((r0 = -1)))) ;; 1-level normal 1 mapping - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -369,9 +369,9 @@ '(0 99 100 101 102 103 104 105 106 107)) '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) - (105 . -1) (106 . -1) (107 . -1))) + (105 . -1) (106 . -1) (107 . -1)))) - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-iterate-multiple-map @@ -380,10 +380,10 @@ '(0 99 100 101 102 103 104 105 106 107)) '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (3 . 0) (4 . 0) (5 . 0) - (105 . -1) (106 . -1) (107 . -1))) + (105 . -1) (106 . -1) (107 . -1)))) ;; 1-level normal 2 mappings - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -393,9 +393,9 @@ '(0 99 100 101 102 103 104 105 106 107)) '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (13 . 1) (4 . 0) (5 . 0) (16 . 1) (17 . 1) - (107 . -1))) + (107 . -1)))) - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-iterate-multiple-map @@ -404,11 +404,11 @@ [101 12 13 14 15 16 17]))) '(0 99 100 101 102 103 104 105 106 107)) '((0 . -1) (99 . -1) (1 . 0) (2 . 0) (3 . 0) - (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . -1))) + (4 . 0) (5 . 0) (16 . 1) (17 . 1) (107 . -1)))) ;; 1-level normal 7 mappings - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -432,9 +432,9 @@ (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1) (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) - (20002 . 5) (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5))) + (20002 . 5) (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))) - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-iterate-multiple-map @@ -458,11 +458,11 @@ (105 . 2) (106 . 2) (1007 . 3) (108 . 2) (9999 . -1) (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) - (20002 . 5)(30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5))) + (20002 . 5)(30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))) ;; 1-level 7 mappings including CCL call - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -487,9 +487,9 @@ (1009 . 3) (1009 . 3) (9999 . -1) (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5) - (30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5))) + (30000 . 6)(20004 . 5)(20005 . 5)(20006 . 5)))) - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-iterate-multiple-map @@ -514,10 +514,10 @@ (1009 . 3) (-3 . 0) (9999 . -1) (10000 . -1) (10001 . -1) (10002 . -1) (10003 . -1) (10004 . -1) (19999 . -1) (20000 . 5) (20001 . 5) (20002 . 5) - (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5))) + (30000 . 6) (20004 . 5) (20005 . 5) (20006 . 5)))) ;; 3-level mappings - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -550,11 +550,11 @@ (30040 . 10) (30050 . 10) (10008 . 11) (10009 . 11) (10010 . 11) (19999 . 11) (20000 . 11) (20001 . 11) (20002 . 11) (20003 . 11) (20004 . 11) (20005 . 11) - (20006 . 11))) + (20006 . 11)))) ;; 3-level mappings including CCL call - (Assert-equal + (Assert (equal (mapcar (lambda (val) (ccl-test-map-multiple @@ -592,7 +592,7 @@ (10005 . 14) (30040 . 12) (1020008 . 12) (10008 . 14) (10009 . 14) (10010 . 14) (19999 . 14) (20000 . 14) (20001 . 14) (20002 . 14) (20003 . 14) (20004 . 14) - (20005 . 14) (20006 . 14))) + (20005 . 14) (20006 . 14)))) ;; All map-instruction tests ends here. )
--- a/tests/automated/database-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/database-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -46,9 +46,9 @@ (test-database (db) (Assert (databasep db)) (put-database "key1" "val1" db) - (Assert-equal "val1" (get-database "key1" db)) + (Assert (equal "val1" (get-database "key1" db))) (remove-database "key1" db) - (Assert-equal nil (get-database "key1" db)) + (Assert (equal nil (get-database "key1" db))) (close-database db) (Assert (not (database-live-p db))) (Assert (databasep db))))
--- a/tests/automated/extent-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/extent-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -52,12 +52,12 @@ ;; Put it in a buffer. (set-extent-endpoints extent 1 1 (current-buffer)) - (Assert-eq (extent-object extent) (current-buffer)) + (Assert (eq (extent-object extent) (current-buffer))) ;; And then into another buffer. (with-temp-buffer (set-extent-endpoints extent 1 1 (current-buffer)) - (Assert-eq (extent-object extent) (current-buffer))) + (Assert (eq (extent-object extent) (current-buffer)))) ;; Now that the buffer doesn't exist, extent should be detached ;; again. @@ -65,39 +65,39 @@ ;; This line crashes XEmacs 21.2.46 and prior. (set-extent-endpoints extent 1 (length string) string) - (Assert-eq (extent-object extent) string) + (Assert (eq (extent-object extent) string)) ) (let ((extent (make-extent 1 1))) ;; By default, extent should be closed-open - (Assert-eq (get extent 'start-closed) t) - (Assert-eq (get extent 'start-open) nil) - (Assert-eq (get extent 'end-open) t) - (Assert-eq (get extent 'end-closed) nil) + (Assert (eq (get extent 'start-closed) t)) + (Assert (eq (get extent 'start-open) nil)) + (Assert (eq (get extent 'end-open) t)) + (Assert (eq (get extent 'end-closed) nil)) ;; Make it closed-closed. (set-extent-property extent 'end-closed t) - (Assert-eq (get extent 'start-closed) t) - (Assert-eq (get extent 'start-open) nil) - (Assert-eq (get extent 'end-open) nil) - (Assert-eq (get extent 'end-closed) t) + (Assert (eq (get extent 'start-closed) t)) + (Assert (eq (get extent 'start-open) nil)) + (Assert (eq (get extent 'end-open) nil)) + (Assert (eq (get extent 'end-closed) t)) ;; open-closed (set-extent-property extent 'start-open t) - (Assert-eq (get extent 'start-closed) nil) - (Assert-eq (get extent 'start-open) t) - (Assert-eq (get extent 'end-open) nil) - (Assert-eq (get extent 'end-closed) t) + (Assert (eq (get extent 'start-closed) nil)) + (Assert (eq (get extent 'start-open) t)) + (Assert (eq (get extent 'end-open) nil)) + (Assert (eq (get extent 'end-closed) t)) ;; open-open (set-extent-property extent 'end-open t) - (Assert-eq (get extent 'start-closed) nil) - (Assert-eq (get extent 'start-open) t) - (Assert-eq (get extent 'end-open) t) - (Assert-eq (get extent 'end-closed) nil)) + (Assert (eq (get extent 'start-closed) nil)) + (Assert (eq (get extent 'start-open) t)) + (Assert (eq (get extent 'end-open) t)) + (Assert (eq (get extent 'end-closed) nil))) ) @@ -125,25 +125,25 @@ (let ((e (make-extent 4 7))) ;; current state: "###[eee)###" ;; 123 456 789 - (Assert-equal (et-range e) '(4 7)) + (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###[xxxeee)###" ;; 123 456789 012 - (Assert-equal (et-range e) '(4 10)) + (Assert (equal (et-range e) '(4 10))) (et-insert-at "yyy" 7) ;; current state: "###[xxxyyyeee)###" ;; 123 456789012 345 - (Assert-equal (et-range e) '(4 13)) + (Assert (equal (et-range e) '(4 13))) (et-insert-at "zzz" 13) ;; current state: "###[xxxyyyeee)zzz###" ;; 123 456789012 345678 - (Assert-equal (et-range e) '(4 13)) + (Assert (equal (et-range e) '(4 13))) )) ;; closed-closed @@ -155,25 +155,25 @@ ;; current state: "###[eee]###" ;; 123 456 789 - (Assert-equal (et-range e) '(4 7)) + (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###[xxxeee]###" ;; 123 456789 012 - (Assert-equal (et-range e) '(4 10)) + (Assert (equal (et-range e) '(4 10))) (et-insert-at "yyy" 7) ;; current state: "###[xxxyyyeee]###" ;; 123 456789012 345 - (Assert-equal (et-range e) '(4 13)) + (Assert (equal (et-range e) '(4 13))) (et-insert-at "zzz" 13) ;; current state: "###[xxxyyyeeezzz]###" ;; 123 456789012345 678 - (Assert-equal (et-range e) '(4 16)) + (Assert (equal (et-range e) '(4 16))) )) ;; open-closed @@ -186,25 +186,25 @@ ;; current state: "###(eee]###" ;; 123 456 789 - (Assert-equal (et-range e) '(4 7)) + (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###xxx(eee]###" ;; 123456 789 012 - (Assert-equal (et-range e) '(7 10)) + (Assert (equal (et-range e) '(7 10))) (et-insert-at "yyy" 8) ;; current state: "###xxx(eyyyee]###" ;; 123456 789012 345 - (Assert-equal (et-range e) '(7 13)) + (Assert (equal (et-range e) '(7 13))) (et-insert-at "zzz" 13) ;; current state: "###xxx(eyyyeezzz]###" ;; 123456 789012345 678 - (Assert-equal (et-range e) '(7 16)) + (Assert (equal (et-range e) '(7 16))) )) ;; open-open @@ -216,25 +216,25 @@ ;; current state: "###(eee)###" ;; 123 456 789 - (Assert-equal (et-range e) '(4 7)) + (Assert (equal (et-range e) '(4 7))) (et-insert-at "xxx" 4) ;; current state: "###xxx(eee)###" ;; 123456 789 012 - (Assert-equal (et-range e) '(7 10)) + (Assert (equal (et-range e) '(7 10))) (et-insert-at "yyy" 8) ;; current state: "###xxx(eyyyee)###" ;; 123456 789012 345 - (Assert-equal (et-range e) '(7 13)) + (Assert (equal (et-range e) '(7 13))) (et-insert-at "zzz" 13) ;; current state: "###xxx(eyyyee)zzz###" ;; 123456 789012 345678 - (Assert-equal (et-range e) '(7 13)) + (Assert (equal (et-range e) '(7 13))) )) @@ -256,31 +256,31 @@ ;; current state: xx[xxxxxx]xx ;; 12 345678 90 - (Assert-equal (et-range e) '(3 9)) + (Assert (equal (et-range e) '(3 9))) (delete-region 1 2) ;; current state: x[xxxxxx]xx ;; 1 234567 89 - (Assert-equal (et-range e) '(2 8)) + (Assert (equal (et-range e) '(2 8))) (delete-region 2 4) ;; current state: x[xxxx]xx ;; 1 2345 67 - (Assert-equal (et-range e) '(2 6)) + (Assert (equal (et-range e) '(2 6))) (delete-region 1 3) ;; current state: [xxx]xx ;; 123 45 - (Assert-equal (et-range e) '(1 4)) + (Assert (equal (et-range e) '(1 4))) (delete-region 3 5) ;; current state: [xx]x ;; 12 3 - (Assert-equal (et-range e) '(1 3)) + (Assert (equal (et-range e) '(1 3))) ))) @@ -329,7 +329,7 @@ (delete-region 4 6) ;; ###[]### (Assert (not (extent-detached-p e))) - (Assert-equal (et-range e) '(4 4)) + (Assert (equal (et-range e) '(4 4))) )) ) @@ -343,7 +343,7 @@ (insert "######") (let ((e (make-extent 4 4))) (et-insert-at "foo" 4) - (Assert-equal (et-range e) '(4 4)))) + (Assert (equal (et-range e) '(4 4))))) ;; open-closed (should move) (with-temp-buffer @@ -352,7 +352,7 @@ (put e 'start-open t) (put e 'end-closed t) (et-insert-at "foo" 4) - (Assert-equal (et-range e) '(7 7)))) + (Assert (equal (et-range e) '(7 7))))) ;; closed-closed (should extend) (with-temp-buffer @@ -360,7 +360,7 @@ (let ((e (make-extent 4 4))) (put e 'end-closed t) (et-insert-at "foo" 4) - (Assert-equal (et-range e) '(4 7)))) + (Assert (equal (et-range e) '(4 7))))) ;; open-open (illegal; forced to behave like closed-open) (with-temp-buffer @@ -368,4 +368,4 @@ (let ((e (make-extent 4 4))) (put e 'start-open t) (et-insert-at "foo" 4) - (Assert-equal (et-range e) '(4 4)))) + (Assert (equal (et-range e) '(4 4)))))
--- a/tests/automated/file-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/file-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -40,6 +40,6 @@ (make-temp-name "foo") ) do - (Assert-equal (file-truename (file-truename file)) (file-truename file))) + (Assert (equal (file-truename (file-truename file)) (file-truename file))))
--- a/tests/automated/hash-table-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/hash-table-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -49,26 +49,26 @@ :rehash-size rehash-size :rehash-threshold rehash-threshold :weakness weakness))) - (Assert-equal ht (car (let ((print-readably t)) - (read-from-string (prin1-to-string ht))))) - (Assert-eq test (hash-table-test ht)) + (Assert (equal ht (car (let ((print-readably t)) + (read-from-string (prin1-to-string ht)))))) + (Assert (eq test (hash-table-test ht))) (Assert (<= size (hash-table-size ht))) - (Assert-eql rehash-size (hash-table-rehash-size ht)) - (Assert-eql rehash-threshold (hash-table-rehash-threshold ht)) - (Assert-eq weakness (hash-table-weakness ht))))))))) + (Assert (eql rehash-size (hash-table-rehash-size ht))) + (Assert (eql rehash-threshold (hash-table-rehash-threshold ht))) + (Assert (eq weakness (hash-table-weakness ht)))))))))) (loop for (fun weakness) in '((make-hashtable nil) (make-weak-hashtable key-and-value) (make-key-weak-hashtable key) (make-value-weak-hashtable value)) - do (Assert-eq weakness (hash-table-weakness (funcall fun 10)))) + do (Assert (eq weakness (hash-table-weakness (funcall fun 10))))) (loop for (type weakness) in '((non-weak nil) (weak key-and-value) (key-weak key) (value-weak value)) - do (Assert-equal (make-hash-table :type type) - (make-hash-table :weakness weakness))) + do (Assert (equal (make-hash-table :type type) + (make-hash-table :weakness weakness)))) (Assert (not (equal (make-hash-table :weakness nil) (make-hash-table :weakness t)))) @@ -77,86 +77,86 @@ (size 80)) (Assert (hashtablep ht)) (Assert (hash-table-p ht)) - (Assert-eq 'eq (hash-table-test ht)) - (Assert-eq 'non-weak (hash-table-type ht)) - (Assert-eq 'non-weak (hashtable-type ht)) - (Assert-eq 'nil (hash-table-weakness ht)) + (Assert (eq 'eq (hash-table-test ht))) + (Assert (eq 'non-weak (hash-table-type ht))) + (Assert (eq 'non-weak (hashtable-type ht))) + (Assert (eq 'nil (hash-table-weakness ht))) (dotimes (j size) (puthash j (- j) ht) - (Assert-eq (gethash j ht) (- j)) - (Assert= (hash-table-count ht) (1+ j)) - (Assert= (hashtable-fullness ht) (hash-table-count ht)) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) + (Assert (= (hashtable-fullness ht) (hash-table-count ht))) (puthash j j ht) - (Assert-eq (gethash j ht 'foo) j) - (Assert= (hash-table-count ht) (1+ j)) + (Assert (eq (gethash j ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j))) (setf (gethash j ht) (- j)) - (Assert-eq (gethash j ht) (- j)) - (Assert= (hash-table-count ht) (1+ j))) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) (clrhash ht) - (Assert= 0 (hash-table-count ht)) + (Assert (= 0 (hash-table-count ht))) (dotimes (j size) (puthash j (- j) ht) - (Assert-eq (gethash j ht) (- j)) - (Assert= (hash-table-count ht) (1+ j))) + (Assert (eq (gethash j ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) (let ((k-sum 0) (v-sum 0)) (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) - (Assert= k-sum (/ (* size (- size 1)) 2)) - (Assert= v-sum (- k-sum))) + (Assert (= k-sum (/ (* size (- size 1)) 2))) + (Assert (= v-sum (- k-sum)))) (let ((count size)) (dotimes (j size) (remhash j ht) - (Assert-eq (gethash j ht) nil) - (Assert-eq (gethash j ht 'foo) 'foo) - (Assert= (hash-table-count ht) (decf count))))) + (Assert (eq (gethash j ht) nil)) + (Assert (eq (gethash j ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) (let ((ht (make-hash-table :size 30 :rehash-threshold .25 :test 'equal)) (size 70)) (Assert (hashtablep ht)) (Assert (hash-table-p ht)) (Assert (>= (hash-table-size ht) (/ 30 .25))) - (Assert-eql .25 (hash-table-rehash-threshold ht)) - (Assert-eq 'equal (hash-table-test ht)) - (Assert-eq (hash-table-test ht) (hashtable-test-function ht)) - (Assert-eq 'non-weak (hash-table-type ht)) + (Assert (eql .25 (hash-table-rehash-threshold ht))) + (Assert (eq 'equal (hash-table-test ht))) + (Assert (eq (hash-table-test ht) (hashtable-test-function ht))) + (Assert (eq 'non-weak (hash-table-type ht))) (dotimes (j size) (puthash (int-to-string j) (- j) ht) - (Assert-eq (gethash (int-to-string j) ht) (- j)) - (Assert= (hash-table-count ht) (1+ j)) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j))) (puthash (int-to-string j) j ht) - (Assert-eq (gethash (int-to-string j) ht 'foo) j) - (Assert= (hash-table-count ht) (1+ j))) + (Assert (eq (gethash (int-to-string j) ht 'foo) j)) + (Assert (= (hash-table-count ht) (1+ j)))) (clrhash ht) - (Assert= 0 (hash-table-count ht)) - (Assert-equal ht (copy-hash-table ht)) + (Assert (= 0 (hash-table-count ht))) + (Assert (equal ht (copy-hash-table ht))) (dotimes (j size) (setf (gethash (int-to-string j) ht) (- j)) - (Assert-eq (gethash (int-to-string j) ht) (- j)) - (Assert= (hash-table-count ht) (1+ j))) + (Assert (eq (gethash (int-to-string j) ht) (- j))) + (Assert (= (hash-table-count ht) (1+ j)))) (let ((count size)) (dotimes (j size) (remhash (int-to-string j) ht) - (Assert-eq (gethash (int-to-string j) ht) nil) - (Assert-eq (gethash (int-to-string j) ht 'foo) 'foo) - (Assert= (hash-table-count ht) (decf count))))) + (Assert (eq (gethash (int-to-string j) ht) nil)) + (Assert (eq (gethash (int-to-string j) ht 'foo) 'foo)) + (Assert (= (hash-table-count ht) (decf count)))))) (let ((iterations 5) (one 1.0) (two 2.0)) (flet ((check-copy (ht) (let ((copy-of-ht (copy-hash-table ht))) - (Assert-equal ht copy-of-ht) + (Assert (equal ht copy-of-ht)) (Assert (not (eq ht copy-of-ht))) - (Assert-eq (hash-table-count ht) (hash-table-count copy-of-ht)) - (Assert-eq (hash-table-type ht) (hash-table-type copy-of-ht)) - (Assert-eq (hash-table-size ht) (hash-table-size copy-of-ht)) - (Assert-eql (hash-table-rehash-size ht) (hash-table-rehash-size copy-of-ht)) - (Assert-eql (hash-table-rehash-threshold ht) (hash-table-rehash-threshold copy-of-ht))))) + (Assert (eq (hash-table-count ht) (hash-table-count copy-of-ht))) + (Assert (eq (hash-table-type ht) (hash-table-type copy-of-ht))) + (Assert (eq (hash-table-size ht) (hash-table-size copy-of-ht))) + (Assert (eql (hash-table-rehash-size ht) (hash-table-rehash-size copy-of-ht))) + (Assert (eql (hash-table-rehash-threshold ht) (hash-table-rehash-threshold copy-of-ht)))))) (let ((ht (make-hash-table :size 100 :rehash-threshold .6 :test 'eq))) (dotimes (j iterations) @@ -164,11 +164,11 @@ (puthash (+ two 0.0) t ht) (puthash (cons 1 2) t ht) (puthash (cons 3 4) t ht)) - (Assert-eq (hashtable-test-function ht) 'eq) - (Assert-eq (hash-table-test ht) 'eq) - (Assert= (* iterations 4) (hash-table-count ht)) - (Assert-eq nil (gethash 1.0 ht)) - (Assert-eq nil (gethash '(1 . 2) ht)) + (Assert (eq (hashtable-test-function ht) 'eq)) + (Assert (eq (hash-table-test ht) 'eq)) + (Assert (= (* iterations 4) (hash-table-count ht))) + (Assert (eq nil (gethash 1.0 ht))) + (Assert (eq nil (gethash '(1 . 2) ht))) (check-copy ht) ) @@ -178,11 +178,11 @@ (puthash (+ two 0.0) t ht) (puthash (cons 1 2) t ht) (puthash (cons 3 4) t ht)) - (Assert-eq (hashtable-test-function ht) 'eql) - (Assert-eq (hash-table-test ht) 'eql) - (Assert= (+ 2 (* 2 iterations)) (hash-table-count ht)) - (Assert-eq t (gethash 1.0 ht)) - (Assert-eq nil (gethash '(1 . 2) ht)) + (Assert (eq (hashtable-test-function ht) 'eql)) + (Assert (eq (hash-table-test ht) 'eql)) + (Assert (= (+ 2 (* 2 iterations)) (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq nil (gethash '(1 . 2) ht))) (check-copy ht) ) @@ -192,11 +192,11 @@ (puthash (+ two 0.0) t ht) (puthash (cons 1 2) t ht) (puthash (cons 3 4) t ht)) - (Assert-eq (hashtable-test-function ht) 'equal) - (Assert-eq (hash-table-test ht) 'equal) - (Assert= 4 (hash-table-count ht)) - (Assert-eq t (gethash 1.0 ht)) - (Assert-eq t (gethash '(1 . 2) ht)) + (Assert (eq (hashtable-test-function ht) 'equal)) + (Assert (eq (hash-table-test ht) 'equal)) + (Assert (= 4 (hash-table-count ht))) + (Assert (eq t (gethash 1.0 ht))) + (Assert (eq t (gethash '(1 . 2) ht))) (check-copy ht) ) @@ -223,18 +223,18 @@ (when (integerp k) (incf k-sum k)) (when (integerp v) (incf v-sum v))) ht) - (Assert-eq 38 k-sum) - (Assert-eq 25 v-sum)) - (Assert-eq 6 (hash-table-count ht)) + (Assert (eq 38 k-sum)) + (Assert (eq 25 v-sum))) + (Assert (eq 6 (hash-table-count ht))) (garbage-collect) - (Assert-eq expected-count (hash-table-count ht)) + (Assert (eq expected-count (hash-table-count ht))) (let ((k-sum 0) (v-sum 0)) (maphash #'(lambda (k v) (when (integerp k) (incf k-sum k)) (when (integerp v) (incf v-sum v))) ht) - (Assert-eq expected-k-sum k-sum) - (Assert-eq expected-v-sum v-sum)))) + (Assert (eq expected-k-sum k-sum)) + (Assert (eq expected-v-sum v-sum))))) ;;; Test the ability to puthash and remhash the current elt of a maphash (let ((ht (make-hash-table :test 'eql))) @@ -244,41 +244,41 @@ ht) (let ((k-sum 0) (v-sum 0)) (maphash #'(lambda (k v) (incf k-sum k) (incf v-sum v)) ht) - (Assert= (* 50 49) k-sum) - (Assert= v-sum k-sum))) + (Assert (= (* 50 49) k-sum)) + (Assert (= v-sum k-sum)))) ;;; Test reading and printing of hash-table objects (let ((h1 #s(hashtable weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) (h2 #s(hash-table weakness t rehash-size 3.0 rehash-threshold .2 test eq data (1 2 3 4))) (h3 (make-hash-table :weakness t :rehash-size 3.0 :rehash-threshold .2 :test 'eq))) - (Assert-equal h1 h2) + (Assert (equal h1 h2)) (Assert (not (equal h1 h3))) (puthash 1 2 h3) (puthash 3 4 h3) - (Assert-equal h1 h3)) + (Assert (equal h1 h3))) ;;; Testing equality of hash tables -(Assert-equal (make-hash-table :test 'eql :size 300 :rehash-threshold .9 :rehash-size 3.0) - (make-hash-table :test 'eql)) +(Assert (equal (make-hash-table :test 'eql :size 300 :rehash-threshold .9 :rehash-size 3.0) + (make-hash-table :test 'eql))) (Assert (not (equal (make-hash-table :test 'eq) (make-hash-table :test 'equal)))) (let ((h1 (make-hash-table)) (h2 (make-hash-table))) - (Assert-equal h1 h2) + (Assert (equal h1 h2)) (Assert (not (eq h1 h2))) (puthash 1 2 h1) (Assert (not (equal h1 h2))) (puthash 1 2 h2) - (Assert-equal h1 h2) + (Assert (equal h1 h2)) (puthash 1 3 h2) (Assert (not (equal h1 h2))) (clrhash h1) (Assert (not (equal h1 h2))) (clrhash h2) - (Assert-equal h1 h2) + (Assert (equal h1 h2)) ) ;;; Test sxhash -(Assert= (sxhash "foo") (sxhash "foo")) -(Assert= (sxhash '(1 2 3)) (sxhash '(1 2 3))) +(Assert (= (sxhash "foo") (sxhash "foo"))) +(Assert (= (sxhash '(1 2 3)) (sxhash '(1 2 3)))) (Assert (/= (sxhash '(1 2 3)) (sxhash '(3 2 1))))
--- a/tests/automated/lisp-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/lisp-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -1,4 +1,5 @@ ;; Copyright (C) 1998 Free Software Foundation, Inc. -*- coding: iso-8859-1 -*- +;; Copyright (C) 2010 Ben Wing. ;; Author: Martin Buchholz <martin@xemacs.org> ;; Maintainer: Martin Buchholz <martin@xemacs.org> @@ -42,19 +43,19 @@ (Check-Error wrong-number-of-arguments (setq setq-test-foo 1 setq-test-bar)) (Check-Error wrong-number-of-arguments (setq-default setq-test-foo)) (Check-Error wrong-number-of-arguments (setq-default setq-test-foo 1 setq-test-bar)) -(Assert-eq (setq) nil) -(Assert-eq (setq-default) nil) -(Assert-eq (setq setq-test-foo 42) 42) -(Assert-eq (setq-default setq-test-foo 42) 42) -(Assert-eq (setq setq-test-foo 42 setq-test-bar 99) 99) -(Assert-eq (setq-default setq-test-foo 42 setq-test-bar 99) 99) +(Assert (eq (setq) nil)) +(Assert (eq (setq-default) nil)) +(Assert (eq (setq setq-test-foo 42) 42)) +(Assert (eq (setq-default setq-test-foo 42) 42)) +(Assert (eq (setq setq-test-foo 42 setq-test-bar 99) 99)) +(Assert (eq (setq-default setq-test-foo 42 setq-test-bar 99) 99)) (macrolet ((test-setq (expected-result &rest body) `(progn (defun test-setq-fun () ,@body) - (Assert-eq ,expected-result (test-setq-fun)) + (Assert (eq ,expected-result (test-setq-fun))) (byte-compile 'test-setq-fun) - (Assert-eq ,expected-result (test-setq-fun))))) + (Assert (eq ,expected-result (test-setq-fun)))))) (test-setq nil (setq)) (test-setq nil (setq-default)) (test-setq 42 (setq test-setq-var 42)) @@ -69,38 +70,38 @@ (my-list '(1 2 3 4))) ;;(Assert (fooooo)) ;; Generate Other failure - ;;(Assert-eq 1 2) ;; Generate Assertion failure + ;;(Assert (eq 1 2)) ;; Generate Assertion failure (dolist (sequence (list my-vector my-bit-vector my-string my-list)) (Assert (sequencep sequence)) - (Assert-eq 4 (length sequence))) + (Assert (eq 4 (length sequence)))) (dolist (array (list my-vector my-bit-vector my-string)) (Assert (arrayp array))) - (Assert-eq (elt my-vector 0) 1) - (Assert-eq (elt my-bit-vector 0) 1) - (Assert-eq (elt my-string 0) ?1) - (Assert-eq (elt my-list 0) 1) + (Assert (eq (elt my-vector 0) 1)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?1)) + (Assert (eq (elt my-list 0) 1)) (fillarray my-vector 5) (fillarray my-bit-vector 1) (fillarray my-string ?5) (dolist (array (list my-vector my-bit-vector)) - (Assert-eq 4 (length array))) + (Assert (eq 4 (length array)))) - (Assert-eq (elt my-vector 0) 5) - (Assert-eq (elt my-bit-vector 0) 1) - (Assert-eq (elt my-string 0) ?5) + (Assert (eq (elt my-vector 0) 5)) + (Assert (eq (elt my-bit-vector 0) 1)) + (Assert (eq (elt my-string 0) ?5)) - (Assert-eq (elt my-vector 3) 5) - (Assert-eq (elt my-bit-vector 3) 1) - (Assert-eq (elt my-string 3) ?5) + (Assert (eq (elt my-vector 3) 5)) + (Assert (eq (elt my-bit-vector 3) 1)) + (Assert (eq (elt my-string 3) ?5)) (fillarray my-bit-vector 0) - (Assert-eq 4 (length my-bit-vector)) - (Assert-eq (elt my-bit-vector 2) 0) + (Assert (eq 4 (length my-bit-vector))) + (Assert (eq (elt my-bit-vector 2) 0)) ) (defun make-circular-list (length) @@ -124,22 +125,22 @@ (Check-Error circular-list (nconc '(1 . 2) (make-circular-list length) 'foo)) (Check-Error circular-list (nconc '(1 . 2) '(3 . 4) (make-circular-list length) 'foo))) -(Assert-eq (nconc) nil) -(Assert-eq (nconc nil) nil) -(Assert-eq (nconc nil nil) nil) -(Assert-eq (nconc nil nil nil) nil) +(Assert (eq (nconc) nil)) +(Assert (eq (nconc nil) nil)) +(Assert (eq (nconc nil nil) nil)) +(Assert (eq (nconc nil nil nil) nil)) -(let ((x (make-list-012))) (Assert-eq (nconc nil x) x)) -(let ((x (make-list-012))) (Assert-eq (nconc x nil) x)) -(let ((x (make-list-012))) (Assert-eq (nconc nil x nil) x)) -(let ((x (make-list-012))) (Assert-eq (nconc x) x)) -(let ((x (make-list-012))) (Assert-eq (nconc x (make-circular-list 3)) x)) +(let ((x (make-list-012))) (Assert (eq (nconc nil x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc nil x nil) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x) x))) +(let ((x (make-list-012))) (Assert (eq (nconc x (make-circular-list 3)) x))) -(Assert-equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6)) +(Assert (equal (nconc '(1 . 2) '(3 . 4) '(5 . 6)) '(1 3 5 . 6))) (let ((y (nconc (make-list-012) nil (list 3 4 5) nil))) - (Assert-eq (length y) 6) - (Assert-eq (nth 3 y) 3)) + (Assert (eq (length y) 6)) + (Assert (eq (nth 3 y) 3))) ;;----------------------------------------------------- ;; Test `last' @@ -150,15 +151,15 @@ (Check-Error circular-list (last (make-circular-list 1))) (Check-Error circular-list (last (make-circular-list 2000))) (let ((x (list 0 1 2 3))) - (Assert-eq (last nil) nil) - (Assert-eq (last x 0) nil) - (Assert-eq (last x ) (cdddr x)) - (Assert-eq (last x 1) (cdddr x)) - (Assert-eq (last x 2) (cddr x)) - (Assert-eq (last x 3) (cdr x)) - (Assert-eq (last x 4) x) - (Assert-eq (last x 9) x) - (Assert-eq (last '(1 . 2) 0) 2) + (Assert (eq (last nil) nil)) + (Assert (eq (last x 0) nil)) + (Assert (eq (last x ) (cdddr x))) + (Assert (eq (last x 1) (cdddr x))) + (Assert (eq (last x 2) (cddr x))) + (Assert (eq (last x 3) (cdr x))) + (Assert (eq (last x 4) x)) + (Assert (eq (last x 9) x)) + (Assert (eq (last '(1 . 2) 0) 2)) ) ;;----------------------------------------------------- @@ -178,31 +179,31 @@ (let* ((x (list 0 1 2 3)) (y (butlast x)) (z (nbutlast x))) - (Assert-eq z x) + (Assert (eq z x)) (Assert (not (eq y x))) - (Assert-equal y '(0 1 2)) - (Assert-equal z y)) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) (let* ((x (list 0 1 2 3 4)) (y (butlast x 2)) (z (nbutlast x 2))) - (Assert-eq z x) + (Assert (eq z x)) (Assert (not (eq y x))) - (Assert-equal y '(0 1 2)) - (Assert-equal z y)) + (Assert (equal y '(0 1 2))) + (Assert (equal z y))) (let* ((x (list 0 1 2 3)) (y (butlast x 0)) (z (nbutlast x 0))) - (Assert-eq z x) + (Assert (eq z x)) (Assert (not (eq y x))) - (Assert-equal y '(0 1 2 3)) - (Assert-equal z y)) + (Assert (equal y '(0 1 2 3))) + (Assert (equal z y))) -(Assert-eq (butlast '(x)) nil) -(Assert-eq (nbutlast '(x)) nil) -(Assert-eq (butlast '()) nil) -(Assert-eq (nbutlast '()) nil) +(Assert (eq (butlast '(x)) nil)) +(Assert (eq (nbutlast '(x)) nil)) +(Assert (eq (butlast '()) nil)) +(Assert (eq (nbutlast '()) nil)) ;;----------------------------------------------------- ;; Test `copy-list' @@ -212,7 +213,7 @@ (Check-Error wrong-number-of-arguments (copy-list '(1 2) 1)) (Check-Error circular-list (copy-list (make-circular-list 1))) (Check-Error circular-list (copy-list (make-circular-list 2000))) -(Assert-eq '() (copy-list '())) +(Assert (eq '() (copy-list '()))) (dolist (x '((1) (1 2) (1 2 3) (1 2 . 3))) (let ((y (copy-list x))) (Assert (and (equal x y) (not (eq x y)))))) @@ -222,24 +223,24 @@ ;;----------------------------------------------------- ;; Test `+' -(Assert-eq (+ 1 1) 2) -(Assert= (+ 1.0 1.0) 2.0) -(Assert= (+ 1.0 3.0 0.0) 4.0) -(Assert= (+ 1 1.0) 2.0) -(Assert= (+ 1.0 1) 2.0) -(Assert= (+ 1.0 1 1) 3.0) -(Assert= (+ 1 1 1.0) 3.0) +(Assert (eq (+ 1 1) 2)) +(Assert (= (+ 1.0 1.0) 2.0)) +(Assert (= (+ 1.0 3.0 0.0) 4.0)) +(Assert (= (+ 1 1.0) 2.0)) +(Assert (= (+ 1.0 1) 2.0)) +(Assert (= (+ 1.0 1 1) 3.0)) +(Assert (= (+ 1 1 1.0) 3.0)) (if (featurep 'bignum) (progn (Assert (bignump (1+ most-positive-fixnum))) - (Assert-eq most-positive-fixnum (1- (1+ most-positive-fixnum))) + (Assert (eq most-positive-fixnum (1- (1+ most-positive-fixnum)))) (Assert (bignump (+ most-positive-fixnum 1))) - (Assert-eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1)) - (Assert= (1+ most-positive-fixnum) (- most-negative-fixnum)) + (Assert (eq most-positive-fixnum (- (+ most-positive-fixnum 1) 1))) + (Assert (= (1+ most-positive-fixnum) (- most-negative-fixnum))) (Assert (zerop (+ (* 3 most-negative-fixnum) (* 3 most-positive-fixnum) 3)))) - (Assert-eq (1+ most-positive-fixnum) most-negative-fixnum) - (Assert-eq (+ most-positive-fixnum 1) most-negative-fixnum)) + (Assert (eq (1+ most-positive-fixnum) most-negative-fixnum)) + (Assert (eq (+ most-positive-fixnum 1) most-negative-fixnum))) (when (featurep 'ratio) (let ((threefourths (read "3/4")) @@ -247,47 +248,47 @@ (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) (bigneg (div (+ most-positive-fixnum 2) most-negative-fixnum)) (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) - (Assert= negone -1) - (Assert= threehalfs (+ threefourths threefourths)) + (Assert (= negone -1)) + (Assert (= threehalfs (+ threefourths threefourths))) (Assert (zerop (+ bigpos bigneg))))) ;; Test `-' (Check-Error wrong-number-of-arguments (-)) -(Assert-eq (- 0) 0) -(Assert-eq (- 1) -1) +(Assert (eq (- 0) 0)) +(Assert (eq (- 1) -1)) (dolist (one `(1 1.0 ?\1 ,(Int-to-Marker 1))) - (Assert= (+ 1 one) 2) - (Assert= (+ one) 1) - (Assert= (+ one) one) - (Assert= (- one) -1) - (Assert= (- one one) 0) - (Assert= (- one one one) -1) - (Assert= (- 0 one) -1) - (Assert= (- 0 one one) -2) - (Assert= (+ one 1) 2) + (Assert (= (+ 1 one) 2)) + (Assert (= (+ one) 1)) + (Assert (= (+ one) one)) + (Assert (= (- one) -1)) + (Assert (= (- one one) 0)) + (Assert (= (- one one one) -1)) + (Assert (= (- 0 one) -1)) + (Assert (= (- 0 one one) -2)) + (Assert (= (+ one 1) 2)) (dolist (zero '(0 0.0 ?\0)) - (Assert= (+ 1 zero) 1 zero) - (Assert= (+ zero 1) 1 zero) - (Assert= (- zero) zero zero) - (Assert= (- zero) 0 zero) - (Assert= (- zero zero) 0 zero) - (Assert= (- zero one one) -2 zero))) + (Assert (= (+ 1 zero) 1) zero) + (Assert (= (+ zero 1) 1) zero) + (Assert (= (- zero) zero) zero) + (Assert (= (- zero) 0) zero) + (Assert (= (- zero zero) 0) zero) + (Assert (= (- zero one one) -2) zero))) -(Assert= (- 1.5 1) .5) -(Assert= (- 1 1.5) (- .5)) +(Assert (= (- 1.5 1) .5)) +(Assert (= (- 1 1.5) (- .5))) (if (featurep 'bignum) (progn (Assert (bignump (1- most-negative-fixnum))) - (Assert-eq most-negative-fixnum (1+ (1- most-negative-fixnum))) + (Assert (eq most-negative-fixnum (1+ (1- most-negative-fixnum)))) (Assert (bignump (- most-negative-fixnum 1))) - (Assert-eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1)) - (Assert= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2)) - (Assert-eq (- (- most-positive-fixnum most-negative-fixnum) + (Assert (eq most-negative-fixnum (+ (- most-negative-fixnum 1) 1))) + (Assert (= (1- most-negative-fixnum) (- 0 most-positive-fixnum 2))) + (Assert (eq (- (- most-positive-fixnum most-negative-fixnum) (* 2 most-positive-fixnum)) - 1)) - (Assert-eq (1- most-negative-fixnum) most-positive-fixnum) - (Assert-eq (- most-negative-fixnum 1) most-positive-fixnum)) + 1))) + (Assert (eq (1- most-negative-fixnum) most-positive-fixnum)) + (Assert (eq (- most-negative-fixnum 1) most-positive-fixnum))) (when (featurep 'ratio) (let ((threefourths (read "3/4")) @@ -295,9 +296,9 @@ (bigpos (div (+ most-positive-fixnum 2) (1+ most-positive-fixnum))) (bigneg (div most-positive-fixnum most-negative-fixnum)) (negone (div (1+ most-positive-fixnum) most-negative-fixnum))) - (Assert= (- negone) 1) - (Assert= threefourths (- threehalfs threefourths)) - (Assert= (- bigpos bigneg) 2))) + (Assert (= (- negone) 1)) + (Assert (= threefourths (- threehalfs threefourths))) + (Assert (= (- bigpos bigneg) 2)))) ;; Test `/' @@ -312,180 +313,180 @@ ;; Other tests for `/' (Check-Error wrong-number-of-arguments (/)) (let (x) - (Assert= (/ (setq x 2)) 0) - (Assert= (/ (setq x 2.0)) 0.5)) + (Assert (= (/ (setq x 2)) 0)) + (Assert (= (/ (setq x 2.0)) 0.5))) (dolist (six '(6 6.0 ?\06)) (dolist (two '(2 2.0 ?\02)) (dolist (three '(3 3.0 ?\03)) - (Assert= (/ six two) three (list six two three))))) + (Assert (= (/ six two) three) (list six two three))))) (dolist (three '(3 3.0 ?\03)) - (Assert= (/ three 2.0) 1.5 three)) + (Assert (= (/ three 2.0) 1.5) three)) (dolist (two '(2 2.0 ?\02)) - (Assert= (/ 3.0 two) 1.5 two)) + (Assert (= (/ 3.0 two) 1.5) two)) (when (featurep 'bignum) (let* ((million 1000000) (billion (* million 1000)) ;; American, not British, billion (trillion (* billion 1000))) - (Assert= (/ billion 1000) (/ trillion million) million 1000000.0) - (Assert= (/ billion -1000) (/ trillion (- million)) (- million)) - (Assert= (/ trillion 1000) billion 1000000000.0) - (Assert= (/ trillion -1000) (- billion) -1000000000.0) - (Assert= (/ trillion 10) (* 100 billion) 100000000000.0) - (Assert= (/ (- trillion) 10) (* -100 billion) -100000000000.0))) + (Assert (= (/ billion 1000) (/ trillion million) million 1000000.0)) + (Assert (= (/ billion -1000) (/ trillion (- million)) (- million))) + (Assert (= (/ trillion 1000) billion 1000000000.0)) + (Assert (= (/ trillion -1000) (- billion) -1000000000.0)) + (Assert (= (/ trillion 10) (* 100 billion) 100000000000.0)) + (Assert (= (/ (- trillion) 10) (* -100 billion) -100000000000.0)))) (when (featurep 'ratio) (let ((half (div 1 2)) (fivefourths (div 5 4)) (fivehalfs (div 5 2))) - (Assert= half (read "3000000000/6000000000")) - (Assert= (/ fivehalfs fivefourths) 2) - (Assert= (/ fivefourths fivehalfs) half) - (Assert= (- half) (read "-3000000000/6000000000")) - (Assert= (/ fivehalfs (- fivefourths)) -2) - (Assert= (/ (- fivefourths) fivehalfs) (- half)))) + (Assert (= half (read "3000000000/6000000000"))) + (Assert (= (/ fivehalfs fivefourths) 2)) + (Assert (= (/ fivefourths fivehalfs) half)) + (Assert (= (- half) (read "-3000000000/6000000000"))) + (Assert (= (/ fivehalfs (- fivefourths)) -2)) + (Assert (= (/ (- fivefourths) fivehalfs) (- half))))) ;; Test `*' -(Assert= 1 (*)) +(Assert (= 1 (*))) (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) - (Assert= 1 (* one) one)) + (Assert (= 1 (* one)) one)) (dolist (two '(2 2.0 ?\02)) - (Assert= 2 (* two) two)) + (Assert (= 2 (* two)) two)) (dolist (six '(6 6.0 ?\06)) (dolist (two '(2 2.0 ?\02)) (dolist (three '(3 3.0 ?\03)) - (Assert= (* three two) six (list three two six))))) + (Assert (= (* three two) six) (list three two six))))) (dolist (three '(3 3.0 ?\03)) (dolist (two '(2 2.0 ?\02)) - (Assert= (* 1.5 two) three (list two three)) + (Assert (= (* 1.5 two) three) (list two three)) (dolist (five '(5 5.0 ?\05)) - (Assert= 30 (* five two three) (list five two three))))) + (Assert (= 30 (* five two three)) (list five two three))))) (when (featurep 'bignum) (let ((64K 65536)) - (Assert= (* 64K 64K) (read "4294967296")) - (Assert= (* (- 64K) 64K) (read "-4294967296")) + (Assert (= (* 64K 64K) (read "4294967296"))) + (Assert (= (* (- 64K) 64K) (read "-4294967296"))) (Assert (/= (* -1 most-negative-fixnum) most-negative-fixnum)))) (when (featurep 'ratio) (let ((half (div 1 2)) (fivefourths (div 5 4)) (twofifths (div 2 5))) - (Assert= (* fivefourths twofifths) half) - (Assert= (* half twofifths) (read "3/15")))) + (Assert (= (* fivefourths twofifths) half)) + (Assert (= (* half twofifths) (read "3/15"))))) ;; Test `+' -(Assert= 0 (+)) +(Assert (= 0 (+))) (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) - (Assert= 1 (+ one) one)) + (Assert (= 1 (+ one)) one)) (dolist (two '(2 2.0 ?\02)) - (Assert= 2 (+ two) two)) + (Assert (= 2 (+ two)) two)) (dolist (five '(5 5.0 ?\05)) (dolist (two '(2 2.0 ?\02)) (dolist (three '(3 3.0 ?\03)) - (Assert= (+ three two) five (list three two five)) - (Assert= 10 (+ five two three) (list five two three))))) + (Assert (= (+ three two) five) (list three two five)) + (Assert (= 10 (+ five two three)) (list five two three))))) ;; Test `max', `min' (dolist (one `(1 1.0 ?\01 ,(Int-to-Marker 1))) - (Assert= one (max one) one) - (Assert= one (max one one) one) - (Assert= one (max one one one) one) - (Assert= one (min one) one) - (Assert= one (min one one) one) - (Assert= one (min one one one) one) + (Assert (= one (max one)) one) + (Assert (= one (max one one)) one) + (Assert (= one (max one one one)) one) + (Assert (= one (min one)) one) + (Assert (= one (min one one)) one) + (Assert (= one (min one one one)) one) (dolist (two `(2 2.0 ?\02 ,(Int-to-Marker 2))) - (Assert= one (min one two) (list one two)) - (Assert= one (min one two two) (list one two)) - (Assert= one (min two two one) (list one two)) - (Assert= two (max one two) (list one two)) - (Assert= two (max one two two) (list one two)) - (Assert= two (max two two one) (list one two)))) + (Assert (= one (min one two)) (list one two)) + (Assert (= one (min one two two)) (list one two)) + (Assert (= one (min two two one)) (list one two)) + (Assert (= two (max one two)) (list one two)) + (Assert (= two (max one two two)) (list one two)) + (Assert (= two (max two two one)) (list one two)))) (when (featurep 'bignum) (let ((big (1+ most-positive-fixnum)) (small (1- most-negative-fixnum))) - (Assert= big (max 1 1000000.0 most-positive-fixnum big)) - (Assert= small (min -1 -1000000.0 most-negative-fixnum small)))) + (Assert (= big (max 1 1000000.0 most-positive-fixnum big))) + (Assert (= small (min -1 -1000000.0 most-negative-fixnum small))))) (when (featurep 'ratio) (let* ((big (1+ most-positive-fixnum)) (small (1- most-negative-fixnum)) (bigr (div (* 5 (1+ most-positive-fixnum)) 4)) (smallr (- bigr))) - (Assert= bigr (max 1 1000000.0 most-positive-fixnum big bigr)) - (Assert= smallr (min -1 -1000000.0 most-negative-fixnum small smallr)))) + (Assert (= bigr (max 1 1000000.0 most-positive-fixnum big bigr))) + (Assert (= smallr (min -1 -1000000.0 most-negative-fixnum small smallr))))) ;; The byte compiler has special handling for these constructs: (let ((three 3) (five 5)) - (Assert= (+ three five 1) 9) - (Assert= (+ 1 three five) 9) - (Assert= (+ three five -1) 7) - (Assert= (+ -1 three five) 7) - (Assert= (+ three 1) 4) - (Assert= (+ three -1) 2) - (Assert= (+ -1 three) 2) - (Assert= (+ -1 three) 2) - (Assert= (- three five 1) -3) - (Assert= (- 1 three five) -7) - (Assert= (- three five -1) -1) - (Assert= (- -1 three five) -9) - (Assert= (- three 1) 2) - (Assert= (- three 2 1) 0) - (Assert= (- 2 three 1) -2) - (Assert= (- three -1) 4) - (Assert= (- three 0) 3) - (Assert= (- three 0 five) -2) - (Assert= (- 0 three 0 five) -8) - (Assert= (- 0 three five) -8) - (Assert= (* three 2) 6) - (Assert= (* three -1 five) -15) - (Assert= (* three 1 five) 15) - (Assert= (* three 0 five) 0) - (Assert= (* three 2 five) 30) - (Assert= (/ three 1) 3) - (Assert= (/ three -1) -3) - (Assert= (/ (* five five) 2 2) 6) - (Assert= (/ 64 five 2) 6)) + (Assert (= (+ three five 1) 9)) + (Assert (= (+ 1 three five) 9)) + (Assert (= (+ three five -1) 7)) + (Assert (= (+ -1 three five) 7)) + (Assert (= (+ three 1) 4)) + (Assert (= (+ three -1) 2)) + (Assert (= (+ -1 three) 2)) + (Assert (= (+ -1 three) 2)) + (Assert (= (- three five 1) -3)) + (Assert (= (- 1 three five) -7)) + (Assert (= (- three five -1) -1)) + (Assert (= (- -1 three five) -9)) + (Assert (= (- three 1) 2)) + (Assert (= (- three 2 1) 0)) + (Assert (= (- 2 three 1) -2)) + (Assert (= (- three -1) 4)) + (Assert (= (- three 0) 3)) + (Assert (= (- three 0 five) -2)) + (Assert (= (- 0 three 0 five) -8)) + (Assert (= (- 0 three five) -8)) + (Assert (= (* three 2) 6)) + (Assert (= (* three -1 five) -15)) + (Assert (= (* three 1 five) 15)) + (Assert (= (* three 0 five) 0)) + (Assert (= (* three 2 five) 30)) + (Assert (= (/ three 1) 3)) + (Assert (= (/ three -1) -3)) + (Assert (= (/ (* five five) 2 2) 6)) + (Assert (= (/ 64 five 2) 6))) ;;----------------------------------------------------- ;; Logical bit-twiddling operations ;;----------------------------------------------------- -(Assert= (logxor) 0) -(Assert= (logior) 0) -(Assert= (logand) -1) +(Assert (= (logxor) 0)) +(Assert (= (logior) 0)) +(Assert (= (logand) -1)) (Check-Error wrong-type-argument (logxor 3.0)) (Check-Error wrong-type-argument (logior 3.0)) (Check-Error wrong-type-argument (logand 3.0)) (dolist (three '(3 ?\03)) - (Assert-eq 3 (logand three) three) - (Assert-eq 3 (logxor three) three) - (Assert-eq 3 (logior three) three) - (Assert-eq 3 (logand three three) three) - (Assert-eq 0 (logxor three three) three) - (Assert-eq 3 (logior three three)) three) + (Assert (eq 3 (logand three)) three) + (Assert (eq 3 (logxor three)) three) + (Assert (eq 3 (logior three)) three) + (Assert (eq 3 (logand three three)) three) + (Assert (eq 0 (logxor three three)) three) + (Assert (eq 3 (logior three three))) three) (dolist (one `(1 ?\01 ,(Int-to-Marker 1))) (dolist (two '(2 ?\02)) - (Assert-eq 0 (logand one two) (list one two)) - (Assert-eq 3 (logior one two) (list one two)) - (Assert-eq 3 (logxor one two) (list one two))) + (Assert (eq 0 (logand one two)) (list one two)) + (Assert (eq 3 (logior one two)) (list one two)) + (Assert (eq 3 (logxor one two)) (list one two))) (dolist (three '(3 ?\03)) - (Assert-eq 1 (logand one three) (list one three)) - (Assert-eq 3 (logior one three) (list one three)) - (Assert-eq 2 (logxor one three) (list one three)))) + (Assert (eq 1 (logand one three)) (list one three)) + (Assert (eq 3 (logior one three)) (list one three)) + (Assert (eq 2 (logxor one three)) (list one three)))) ;;----------------------------------------------------- ;; Test `%', mod @@ -501,11 +502,11 @@ (Check-Error wrong-type-argument (% 10.0 2)) (Check-Error wrong-type-argument (% 10 2.0)) -(flet ((test1 (x) (Assert-eql x (+ (% x 17) (* (/ x 17) 17)) x)) - (test2 (x) (Assert-eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) - (test3 (x) (Assert-eql x (+ (% (- x) 17) (* (/ (- x) 17) 17)) x)) - (test4 (x) (Assert-eql (% x -17) (- (% (- x) 17)) x)) - (test5 (x) (Assert-eql (% x -17) (% (- x) 17)) x)) +(flet ((test1 (x) (Assert (eql x (+ (% x 17) (* (/ x 17) 17))) x)) + (test2 (x) (Assert (eql (- x) (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) + (test3 (x) (Assert (eql x (+ (% (- x) 17) (* (/ (- x) 17) 17))) x)) + (test4 (x) (Assert (eql (% x -17) (- (% (- x) 17))) x)) + (test5 (x) (Assert (eql (% x -17) (% (- x) 17))) x)) (test1 most-negative-fixnum) (if (featurep 'bignum) (progn @@ -527,54 +528,54 @@ (macrolet ((division-test (seven) `(progn - (Assert-eq (% ,seven 2) 1) - (Assert-eq (% ,seven -2) 1) - (Assert-eq (% (- ,seven) 2) -1) - (Assert-eq (% (- ,seven) -2) -1) + (Assert (eq (% ,seven 2) 1)) + (Assert (eq (% ,seven -2) 1)) + (Assert (eq (% (- ,seven) 2) -1)) + (Assert (eq (% (- ,seven) -2) -1)) - (Assert-eq (% ,seven 4) 3) - (Assert-eq (% ,seven -4) 3) - (Assert-eq (% (- ,seven) 4) -3) - (Assert-eq (% (- ,seven) -4) -3) + (Assert (eq (% ,seven 4) 3)) + (Assert (eq (% ,seven -4) 3)) + (Assert (eq (% (- ,seven) 4) -3)) + (Assert (eq (% (- ,seven) -4) -3)) - (Assert-eq (% 35 ,seven) 0) - (Assert-eq (% -35 ,seven) 0) - (Assert-eq (% 35 (- ,seven)) 0) - (Assert-eq (% -35 (- ,seven)) 0) + (Assert (eq (% 35 ,seven) 0)) + (Assert (eq (% -35 ,seven) 0)) + (Assert (eq (% 35 (- ,seven)) 0)) + (Assert (eq (% -35 (- ,seven)) 0)) - (Assert-eq (mod ,seven 2) 1) - (Assert-eq (mod ,seven -2) -1) - (Assert-eq (mod (- ,seven) 2) 1) - (Assert-eq (mod (- ,seven) -2) -1) + (Assert (eq (mod ,seven 2) 1)) + (Assert (eq (mod ,seven -2) -1)) + (Assert (eq (mod (- ,seven) 2) 1)) + (Assert (eq (mod (- ,seven) -2) -1)) - (Assert-eq (mod ,seven 4) 3) - (Assert-eq (mod ,seven -4) -1) - (Assert-eq (mod (- ,seven) 4) 1) - (Assert-eq (mod (- ,seven) -4) -3) + (Assert (eq (mod ,seven 4) 3)) + (Assert (eq (mod ,seven -4) -1)) + (Assert (eq (mod (- ,seven) 4) 1)) + (Assert (eq (mod (- ,seven) -4) -3)) - (Assert-eq (mod 35 ,seven) 0) - (Assert-eq (mod -35 ,seven) 0) - (Assert-eq (mod 35 (- ,seven)) 0) - (Assert-eq (mod -35 (- ,seven)) 0) + (Assert (eq (mod 35 ,seven) 0)) + (Assert (eq (mod -35 ,seven) 0)) + (Assert (eq (mod 35 (- ,seven)) 0)) + (Assert (eq (mod -35 (- ,seven)) 0)) - (Assert= (mod ,seven 2.0) 1.0) - (Assert= (mod ,seven -2.0) -1.0) - (Assert= (mod (- ,seven) 2.0) 1.0) - (Assert= (mod (- ,seven) -2.0) -1.0) + (Assert (= (mod ,seven 2.0) 1.0)) + (Assert (= (mod ,seven -2.0) -1.0)) + (Assert (= (mod (- ,seven) 2.0) 1.0)) + (Assert (= (mod (- ,seven) -2.0) -1.0)) - (Assert= (mod ,seven 4.0) 3.0) - (Assert= (mod ,seven -4.0) -1.0) - (Assert= (mod (- ,seven) 4.0) 1.0) - (Assert= (mod (- ,seven) -4.0) -3.0) + (Assert (= (mod ,seven 4.0) 3.0)) + (Assert (= (mod ,seven -4.0) -1.0)) + (Assert (= (mod (- ,seven) 4.0) 1.0)) + (Assert (= (mod (- ,seven) -4.0) -3.0)) - (Assert-eq (% 0 ,seven) 0) - (Assert-eq (% 0 (- ,seven)) 0) + (Assert (eq (% 0 ,seven) 0)) + (Assert (eq (% 0 (- ,seven)) 0)) - (Assert-eq (mod 0 ,seven) 0) - (Assert-eq (mod 0 (- ,seven)) 0) + (Assert (eq (mod 0 ,seven) 0)) + (Assert (eq (mod 0 (- ,seven)) 0)) - (Assert= (mod 0.0 ,seven) 0.0) - (Assert= (mod 0.0 (- ,seven)) 0.0)))) + (Assert (= (mod 0.0 ,seven) 0.0)) + (Assert (= (mod 0.0 (- ,seven)) 0.0))))) (division-test 7) (division-test ?\07) @@ -600,12 +601,12 @@ ;; One argument always yields t (loop for x in `(1 1.0 ,(Int-to-Marker 1) ?z) do - (Assert-eq t (= x) x) - (Assert-eq t (< x) x) - (Assert-eq t (> x) x) - (Assert-eq t (>= x) x) - (Assert-eq t (<= x) x) - (Assert-eq t (/= x) x) + (Assert (eq t (= x)) x) + (Assert (eq t (< x)) x) + (Assert (eq t (> x)) x) + (Assert (eq t (>= x)) x) + (Assert (eq t (<= x)) x) + (Assert (eq t (/= x)) x) ) ;; Type checking @@ -633,7 +634,7 @@ (Assert (not (< one one two two)) (list one two)) (Assert (>= two two one one) (list one two)) (Assert (not (> two two one one)) (list one two)) - (Assert= one one one one) + (Assert (= one one one) one) (Assert (not (= one one one two)) (list one two)) (Assert (not (/= one two one)) (list one two)) )) @@ -654,7 +655,7 @@ (Assert (not (< one one two two)) (list one two)) (Assert (>= two two one one) (list one two)) (Assert (not (> two two one one)) (list one two)) - (Assert= one one one one) + (Assert (= one one one) one) (Assert (not (= one one one two)) (list one two)) (Assert (not (/= one two one)) (list one two)) )) @@ -674,8 +675,8 @@ (Assert (<= 1 1)) (Assert (not (eq (point) (point-marker)))) -(Assert= 1 (Int-to-Marker 1)) -(Assert= (point) (point-marker)) +(Assert (= 1 (Int-to-Marker 1))) +(Assert (= (point) (point-marker))) (when (featurep 'bignum) (let ((big1 (1+ most-positive-fixnum)) @@ -700,8 +701,8 @@ (small1 (div (* 10 most-negative-fixnum) 4)) (small2 (div (* 5 most-negative-fixnum) 2)) (small3 (div (* 7 most-negative-fixnum) 2))) - (Assert= big1 big2) - (Assert= small1 small2) + (Assert (= big1 big2)) + (Assert (= small1 small2)) (Assert (< small3 small1 most-negative-fixnum most-positive-fixnum big1 big3)) (Assert (<= small3 small2 small1 most-negative-fixnum most-positive-fixnum @@ -737,56 +738,56 @@ remassoc remassq remrassoc remrassq)) (let ((x '((1 . 2) 3 (4 . 5)))) - (Assert-eq (assoc 1 x) (car x)) - (Assert-eq (assq 1 x) (car x)) - (Assert-eq (rassoc 1 x) nil) - (Assert-eq (rassq 1 x) nil) - (Assert-eq (assoc 2 x) nil) - (Assert-eq (assq 2 x) nil) - (Assert-eq (rassoc 2 x) (car x)) - (Assert-eq (rassq 2 x) (car x)) - (Assert-eq (assoc 3 x) nil) - (Assert-eq (assq 3 x) nil) - (Assert-eq (rassoc 3 x) nil) - (Assert-eq (rassq 3 x) nil) - (Assert-eq (assoc 4 x) (caddr x)) - (Assert-eq (assq 4 x) (caddr x)) - (Assert-eq (rassoc 4 x) nil) - (Assert-eq (rassq 4 x) nil) - (Assert-eq (assoc 5 x) nil) - (Assert-eq (assq 5 x) nil) - (Assert-eq (rassoc 5 x) (caddr x)) - (Assert-eq (rassq 5 x) (caddr x)) - (Assert-eq (assoc 6 x) nil) - (Assert-eq (assq 6 x) nil) - (Assert-eq (rassoc 6 x) nil) - (Assert-eq (rassq 6 x) nil)) + (Assert (eq (assoc 1 x) (car x))) + (Assert (eq (assq 1 x) (car x))) + (Assert (eq (rassoc 1 x) nil)) + (Assert (eq (rassq 1 x) nil)) + (Assert (eq (assoc 2 x) nil)) + (Assert (eq (assq 2 x) nil)) + (Assert (eq (rassoc 2 x) (car x))) + (Assert (eq (rassq 2 x) (car x))) + (Assert (eq (assoc 3 x) nil)) + (Assert (eq (assq 3 x) nil)) + (Assert (eq (rassoc 3 x) nil)) + (Assert (eq (rassq 3 x) nil)) + (Assert (eq (assoc 4 x) (caddr x))) + (Assert (eq (assq 4 x) (caddr x))) + (Assert (eq (rassoc 4 x) nil)) + (Assert (eq (rassq 4 x) nil)) + (Assert (eq (assoc 5 x) nil)) + (Assert (eq (assq 5 x) nil)) + (Assert (eq (rassoc 5 x) (caddr x))) + (Assert (eq (rassq 5 x) (caddr x))) + (Assert (eq (assoc 6 x) nil)) + (Assert (eq (assq 6 x) nil)) + (Assert (eq (rassoc 6 x) nil)) + (Assert (eq (rassq 6 x) nil))) (let ((x '(("1" . "2") "3" ("4" . "5")))) - (Assert-eq (assoc "1" x) (car x)) - (Assert-eq (assq "1" x) nil) - (Assert-eq (rassoc "1" x) nil) - (Assert-eq (rassq "1" x) nil) - (Assert-eq (assoc "2" x) nil) - (Assert-eq (assq "2" x) nil) - (Assert-eq (rassoc "2" x) (car x)) - (Assert-eq (rassq "2" x) nil) - (Assert-eq (assoc "3" x) nil) - (Assert-eq (assq "3" x) nil) - (Assert-eq (rassoc "3" x) nil) - (Assert-eq (rassq "3" x) nil) - (Assert-eq (assoc "4" x) (caddr x)) - (Assert-eq (assq "4" x) nil) - (Assert-eq (rassoc "4" x) nil) - (Assert-eq (rassq "4" x) nil) - (Assert-eq (assoc "5" x) nil) - (Assert-eq (assq "5" x) nil) - (Assert-eq (rassoc "5" x) (caddr x)) - (Assert-eq (rassq "5" x) nil) - (Assert-eq (assoc "6" x) nil) - (Assert-eq (assq "6" x) nil) - (Assert-eq (rassoc "6" x) nil) - (Assert-eq (rassq "6" x) nil)) + (Assert (eq (assoc "1" x) (car x))) + (Assert (eq (assq "1" x) nil)) + (Assert (eq (rassoc "1" x) nil)) + (Assert (eq (rassq "1" x) nil)) + (Assert (eq (assoc "2" x) nil)) + (Assert (eq (assq "2" x) nil)) + (Assert (eq (rassoc "2" x) (car x))) + (Assert (eq (rassq "2" x) nil)) + (Assert (eq (assoc "3" x) nil)) + (Assert (eq (assq "3" x) nil)) + (Assert (eq (rassoc "3" x) nil)) + (Assert (eq (rassq "3" x) nil)) + (Assert (eq (assoc "4" x) (caddr x))) + (Assert (eq (assq "4" x) nil)) + (Assert (eq (rassoc "4" x) nil)) + (Assert (eq (rassq "4" x) nil)) + (Assert (eq (assoc "5" x) nil)) + (Assert (eq (assq "5" x) nil)) + (Assert (eq (rassoc "5" x) (caddr x))) + (Assert (eq (rassq "5" x) nil)) + (Assert (eq (assoc "6" x) nil)) + (Assert (eq (assq "6" x) nil)) + (Assert (eq (rassoc "6" x) nil)) + (Assert (eq (rassq "6" x) nil))) (flet ((a () (list '(1 . 2) 3 '(4 . 5)))) (Assert (let* ((x (a)) (y (remassoc 1 x))) (and (not (eq x y)) (equal y '(3 (4 . 5)))))) @@ -868,8 +869,8 @@ ;;----------------------------------------------------- (defmacro check-function-argcounts (fun min max) `(progn - (Assert-eq (function-min-args ,fun) ,min) - (Assert-eq (function-max-args ,fun) ,max))) + (Assert (eq (function-min-args ,fun) ,min)) + (Assert (eq (function-max-args ,fun) ,max)))) (check-function-argcounts 'prog1 1 nil) ; special form (check-function-argcounts 'command-execute 1 3) ; normal subr @@ -896,7 +897,7 @@ (list (0 . many)) (type-of (1 . 1)) (garbage-collect (0 . 0))) - do (Assert-equal (subr-arity (symbol-function function-name)) arity)) + do (Assert (equal (subr-arity (symbol-function function-name)) arity))) (Check-Error wrong-type-argument (subr-arity (lambda () (message "Hi there!")))) @@ -918,37 +919,37 @@ ;;----------------------------------------------------- ;; Test `type-of' ;;----------------------------------------------------- -(Assert-eq (type-of load-path) 'cons) -(Assert-eq (type-of obarray) 'vector) -(Assert-eq (type-of 42) 'integer) -(Assert-eq (type-of ?z) 'character) -(Assert-eq (type-of "42") 'string) -(Assert-eq (type-of 'foo) 'symbol) -(Assert-eq (type-of (selected-device)) 'device) +(Assert (eq (type-of load-path) 'cons)) +(Assert (eq (type-of obarray) 'vector)) +(Assert (eq (type-of 42) 'integer)) +(Assert (eq (type-of ?z) 'character)) +(Assert (eq (type-of "42") 'string)) +(Assert (eq (type-of 'foo) 'symbol)) +(Assert (eq (type-of (selected-device)) 'device)) ;;----------------------------------------------------- ;; Test mapping functions ;;----------------------------------------------------- (Check-Error wrong-type-argument (mapcar #'identity (current-buffer))) -(Assert-equal (mapcar #'identity load-path) load-path) -(Assert-equal (mapcar #'identity '(1 2 3)) '(1 2 3)) -(Assert-equal (mapcar #'identity "123") '(?1 ?2 ?3)) -(Assert-equal (mapcar #'identity [1 2 3]) '(1 2 3)) -(Assert-equal (mapcar #'identity #*010) '(0 1 0)) +(Assert (equal (mapcar #'identity load-path) load-path)) +(Assert (equal (mapcar #'identity '(1 2 3)) '(1 2 3))) +(Assert (equal (mapcar #'identity "123") '(?1 ?2 ?3))) +(Assert (equal (mapcar #'identity [1 2 3]) '(1 2 3))) +(Assert (equal (mapcar #'identity #*010) '(0 1 0))) (let ((z 0) (list (make-list 1000 1))) (mapc (lambda (x) (incf z x)) list) - (Assert-eq 1000 z)) + (Assert (eq 1000 z))) (Check-Error wrong-type-argument (mapvector #'identity (current-buffer))) -(Assert-equal (mapvector #'identity '(1 2 3)) [1 2 3]) -(Assert-equal (mapvector #'identity "123") [?1 ?2 ?3]) -(Assert-equal (mapvector #'identity [1 2 3]) [1 2 3]) -(Assert-equal (mapvector #'identity #*010) [0 1 0]) +(Assert (equal (mapvector #'identity '(1 2 3)) [1 2 3])) +(Assert (equal (mapvector #'identity "123") [?1 ?2 ?3])) +(Assert (equal (mapvector #'identity [1 2 3]) [1 2 3])) +(Assert (equal (mapvector #'identity #*010) [0 1 0])) (Check-Error wrong-type-argument (mapconcat #'identity (current-buffer) "foo")) -(Assert-equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3") -(Assert-equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3") +(Assert (equal (mapconcat #'identity '("1" "2" "3") "|") "1|2|3")) +(Assert (equal (mapconcat #'identity ["1" "2" "3"] "|") "1|2|3")) ;; The following 2 functions used to crash XEmacs via mapcar1(). ;; We don't test the actual values of the mapcar, since they're undefined. @@ -973,38 +974,38 @@ (car y)) x))) -(Assert-eql +(Assert (eql (length (multiple-value-list (car (mapcar #'(lambda (argument) (floor argument)) (list pi e))))) - 1 + 1) "checking multiple values are correctly discarded in mapcar") ;;----------------------------------------------------- ;; Test vector functions ;;----------------------------------------------------- -(Assert-equal [1 2 3] [1 2 3]) -(Assert-equal [] []) +(Assert (equal [1 2 3] [1 2 3])) +(Assert (equal [] [])) (Assert (not (equal [1 2 3] []))) (Assert (not (equal [1 2 3] [1 2 4]))) (Assert (not (equal [0 2 3] [1 2 3]))) (Assert (not (equal [1 2 3] [1 2 3 4]))) (Assert (not (equal [1 2 3 4] [1 2 3]))) -(Assert-equal (vector 1 2 3) [1 2 3]) -(Assert-equal (make-vector 3 1) [1 1 1]) +(Assert (equal (vector 1 2 3) [1 2 3])) +(Assert (equal (make-vector 3 1) [1 1 1])) ;;----------------------------------------------------- ;; Test bit-vector functions ;;----------------------------------------------------- -(Assert-equal #*010 #*010) -(Assert-equal #* #*) +(Assert (equal #*010 #*010)) +(Assert (equal #* #*)) (Assert (not (equal #*010 #*011))) (Assert (not (equal #*010 #*))) (Assert (not (equal #*110 #*010))) (Assert (not (equal #*010 #*0100))) (Assert (not (equal #*0101 #*010))) -(Assert-equal (bit-vector 0 1 0) #*010) -(Assert-equal (make-bit-vector 3 1) #*111) -(Assert-equal (make-bit-vector 3 0) #*000) +(Assert (equal (bit-vector 0 1 0) #*010)) +(Assert (equal (make-bit-vector 3 1) #*111)) +(Assert (equal (make-bit-vector 3 0) #*000)) ;;----------------------------------------------------- ;; Test buffer-local variables used as (ugh!) function parameters @@ -1022,59 +1023,59 @@ ;; Hrvoje didn't like the next 3 tests so I'm disabling them for now. -sb ;; I assume Hrvoje worried about the possibility of infloops. -sjt (when test-harness-risk-infloops - (Assert-equal (split-string "foo" "") '("" "f" "o" "o" "")) - (Assert-equal (split-string "foo" "^") '("" "foo")) - (Assert-equal (split-string "foo" "$") '("foo" ""))) -(Assert-equal (split-string "foo,bar" ",") '("foo" "bar")) -(Assert-equal (split-string ",foo,bar," ",") '("" "foo" "bar" "")) -(Assert-equal (split-string ",foo,bar," "^,") '("" "foo,bar,")) -(Assert-equal (split-string ",foo,bar," ",$") '(",foo,bar" "")) -(Assert-equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" "")) -(Assert-equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar")) -(Assert-equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" "")) -(Assert-equal (split-string "foo,,bar" ",+") '("foo" "bar")) -(Assert-equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" "")) + (Assert (equal (split-string "foo" "") '("" "f" "o" "o" ""))) + (Assert (equal (split-string "foo" "^") '("" "foo"))) + (Assert (equal (split-string "foo" "$") '("foo" "")))) +(Assert (equal (split-string "foo,bar" ",") '("foo" "bar"))) +(Assert (equal (split-string ",foo,bar," ",") '("" "foo" "bar" ""))) +(Assert (equal (split-string ",foo,bar," "^,") '("" "foo,bar,"))) +(Assert (equal (split-string ",foo,bar," ",$") '(",foo,bar" ""))) +(Assert (equal (split-string ",foo,,bar," ",") '("" "foo" "" "bar" ""))) +(Assert (equal (split-string "foo,,,bar" ",") '("foo" "" "" "bar"))) +(Assert (equal (split-string "foo,,bar,," ",") '("foo" "" "bar" "" ""))) +(Assert (equal (split-string "foo,,bar" ",+") '("foo" "bar"))) +(Assert (equal (split-string ",foo,,bar," ",+") '("" "foo" "bar" ""))) ;; Omit nulls, explicit SEPARATORS (when test-harness-risk-infloops - (Assert-equal (split-string "foo" "" t) '("f" "o" "o")) - (Assert-equal (split-string "foo" "^" t) '("foo")) - (Assert-equal (split-string "foo" "$" t) '("foo"))) -(Assert-equal (split-string "foo,bar" "," t) '("foo" "bar")) -(Assert-equal (split-string ",foo,bar," "," t) '("foo" "bar")) -(Assert-equal (split-string ",foo,bar," "^," t) '("foo,bar,")) -(Assert-equal (split-string ",foo,bar," ",$" t) '(",foo,bar")) -(Assert-equal (split-string ",foo,,bar," "," t) '("foo" "bar")) -(Assert-equal (split-string "foo,,,bar" "," t) '("foo" "bar")) -(Assert-equal (split-string "foo,,bar,," "," t) '("foo" "bar")) -(Assert-equal (split-string "foo,,bar" ",+" t) '("foo" "bar")) -(Assert-equal (split-string ",foo,,bar," ",+" t) '("foo" "bar")) + (Assert (equal (split-string "foo" "" t) '("f" "o" "o"))) + (Assert (equal (split-string "foo" "^" t) '("foo"))) + (Assert (equal (split-string "foo" "$" t) '("foo")))) +(Assert (equal (split-string "foo,bar" "," t) '("foo" "bar"))) +(Assert (equal (split-string ",foo,bar," "," t) '("foo" "bar"))) +(Assert (equal (split-string ",foo,bar," "^," t) '("foo,bar,"))) +(Assert (equal (split-string ",foo,bar," ",$" t) '(",foo,bar"))) +(Assert (equal (split-string ",foo,,bar," "," t) '("foo" "bar"))) +(Assert (equal (split-string "foo,,,bar" "," t) '("foo" "bar"))) +(Assert (equal (split-string "foo,,bar,," "," t) '("foo" "bar"))) +(Assert (equal (split-string "foo,,bar" ",+" t) '("foo" "bar"))) +(Assert (equal (split-string ",foo,,bar," ",+" t) '("foo" "bar"))) ;; "Double-default" case -(Assert-equal (split-string "foo bar") '("foo" "bar")) -(Assert-equal (split-string " foo bar ") '("foo" "bar")) -(Assert-equal (split-string " foo bar ") '("foo" "bar")) -(Assert-equal (split-string "foo bar") '("foo" "bar")) -(Assert-equal (split-string "foo bar ") '("foo" "bar")) -(Assert-equal (split-string "foobar") '("foobar")) +(Assert (equal (split-string "foo bar") '("foo" "bar"))) +(Assert (equal (split-string " foo bar ") '("foo" "bar"))) +(Assert (equal (split-string " foo bar ") '("foo" "bar"))) +(Assert (equal (split-string "foo bar") '("foo" "bar"))) +(Assert (equal (split-string "foo bar ") '("foo" "bar"))) +(Assert (equal (split-string "foobar") '("foobar"))) ;; Semantics are identical to "double-default" case! Fool ya? -(Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) -(Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) -(Assert-equal (split-string " foo bar " nil t) '("foo" "bar")) -(Assert-equal (split-string "foo bar" nil t) '("foo" "bar")) -(Assert-equal (split-string "foo bar " nil t) '("foo" "bar")) -(Assert-equal (split-string "foobar" nil t) '("foobar")) +(Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) +(Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) +(Assert (equal (split-string " foo bar " nil t) '("foo" "bar"))) +(Assert (equal (split-string "foo bar" nil t) '("foo" "bar"))) +(Assert (equal (split-string "foo bar " nil t) '("foo" "bar"))) +(Assert (equal (split-string "foobar" nil t) '("foobar"))) ;; Perverse "anti-double-default" case -(Assert-equal (split-string "foo bar" split-string-default-separators) - '("foo" "bar")) -(Assert-equal (split-string " foo bar " split-string-default-separators) - '("" "foo" "bar" "")) -(Assert-equal (split-string " foo bar " split-string-default-separators) - '("" "foo" "bar" "")) -(Assert-equal (split-string "foo bar" split-string-default-separators) - '("foo" "bar")) -(Assert-equal (split-string "foo bar " split-string-default-separators) - '("foo" "bar" "")) -(Assert-equal (split-string "foobar" split-string-default-separators) - '("foobar")) +(Assert (equal (split-string "foo bar" split-string-default-separators) + '("foo" "bar"))) +(Assert (equal (split-string " foo bar " split-string-default-separators) + '("" "foo" "bar" ""))) +(Assert (equal (split-string " foo bar " split-string-default-separators) + '("" "foo" "bar" ""))) +(Assert (equal (split-string "foo bar" split-string-default-separators) + '("foo" "bar"))) +(Assert (equal (split-string "foo bar " split-string-default-separators) + '("foo" "bar" ""))) +(Assert (equal (split-string "foobar" split-string-default-separators) + '("foobar"))) ;;----------------------------------------------------- ;; Test split-string-by-char @@ -1151,50 +1152,50 @@ ;;----------------------------------------------------- (with-temp-buffer (erase-buffer) - (Assert-eq (char-before) nil) - (Assert-eq (char-before (point)) nil) - (Assert-eq (char-before (point-marker)) nil) - (Assert-eq (char-before (point) (current-buffer)) nil) - (Assert-eq (char-before (point-marker) (current-buffer)) nil) - (Assert-eq (char-after) nil) - (Assert-eq (char-after (point)) nil) - (Assert-eq (char-after (point-marker)) nil) - (Assert-eq (char-after (point) (current-buffer)) nil) - (Assert-eq (char-after (point-marker) (current-buffer)) nil) - (Assert-eq (preceding-char) 0) - (Assert-eq (preceding-char (current-buffer)) 0) - (Assert-eq (following-char) 0) - (Assert-eq (following-char (current-buffer)) 0) + (Assert (eq (char-before) nil)) + (Assert (eq (char-before (point)) nil)) + (Assert (eq (char-before (point-marker)) nil)) + (Assert (eq (char-before (point) (current-buffer)) nil)) + (Assert (eq (char-before (point-marker) (current-buffer)) nil)) + (Assert (eq (char-after) nil)) + (Assert (eq (char-after (point)) nil)) + (Assert (eq (char-after (point-marker)) nil)) + (Assert (eq (char-after (point) (current-buffer)) nil)) + (Assert (eq (char-after (point-marker) (current-buffer)) nil)) + (Assert (eq (preceding-char) 0)) + (Assert (eq (preceding-char (current-buffer)) 0)) + (Assert (eq (following-char) 0)) + (Assert (eq (following-char (current-buffer)) 0)) (insert "foobar") - (Assert-eq (char-before) ?r) - (Assert-eq (char-after) nil) - (Assert-eq (preceding-char) ?r) - (Assert-eq (following-char) 0) + (Assert (eq (char-before) ?r)) + (Assert (eq (char-after) nil)) + (Assert (eq (preceding-char) ?r)) + (Assert (eq (following-char) 0)) (goto-char (point-min)) - (Assert-eq (char-before) nil) - (Assert-eq (char-after) ?f) - (Assert-eq (preceding-char) 0) - (Assert-eq (following-char) ?f) + (Assert (eq (char-before) nil)) + (Assert (eq (char-after) ?f)) + (Assert (eq (preceding-char) 0)) + (Assert (eq (following-char) ?f)) ) ;;----------------------------------------------------- ;; Test plist manipulation functions. ;;----------------------------------------------------- (let ((sym (make-symbol "test-symbol"))) - (Assert-eq t (get* sym t t)) - (Assert-eq t (get sym t t)) - (Assert-eq t (getf nil t t)) - (Assert-eq t (plist-get nil t t)) + (Assert (eq t (get* sym t t))) + (Assert (eq t (get sym t t))) + (Assert (eq t (getf nil t t))) + (Assert (eq t (plist-get nil t t))) (put sym 'bar 'baz) - (Assert-eq 'baz (get sym 'bar)) - (Assert-eq 'baz (getf '(bar baz) 'bar)) - (Assert-eq 'baz (getf (symbol-plist sym) 'bar)) - (Assert-eq 2 (getf '(1 2) 1)) - (Assert-eq 4 (put sym 3 4)) - (Assert-eq 4 (get sym 3)) - (Assert-eq t (remprop sym 3)) - (Assert-eq nil (remprop sym 3)) - (Assert-eq 5 (get sym 3 5)) + (Assert (eq 'baz (get sym 'bar))) + (Assert (eq 'baz (getf '(bar baz) 'bar))) + (Assert (eq 'baz (getf (symbol-plist sym) 'bar))) + (Assert (eq 2 (getf '(1 2) 1))) + (Assert (eq 4 (put sym 3 4))) + (Assert (eq 4 (get sym 3))) + (Assert (eq t (remprop sym 3))) + (Assert (eq nil (remprop sym 3))) + (Assert (eq 5 (get sym 3 5))) ) (loop for obj in @@ -1203,18 +1204,18 @@ (make-extent nil nil nil) (make-face 'test-face)) do - (Assert-eq 2 (get obj ?1 2) obj) - (Assert-eq 4 (put obj ?3 4) obj) - (Assert-eq 4 (get obj ?3) obj) + (Assert (eq 2 (get obj ?1 2)) obj) + (Assert (eq 4 (put obj ?3 4)) obj) + (Assert (eq 4 (get obj ?3)) obj) (when (or (stringp obj) (symbolp obj)) - (Assert-equal '(?3 4) (object-plist obj) obj)) - (Assert-eq t (remprop obj ?3) obj) + (Assert (equal '(?3 4) (object-plist obj)) obj)) + (Assert (eq t (remprop obj ?3)) obj) (when (or (stringp obj) (symbolp obj)) - (Assert-eq '() (object-plist obj) obj)) - (Assert-eq nil (remprop obj ?3) obj) + (Assert (eq '() (object-plist obj)) obj)) + (Assert (eq nil (remprop obj ?3)) obj) (when (or (stringp obj) (symbolp obj)) - (Assert-eq '() (object-plist obj) obj)) - (Assert-eq 5 (get obj ?3 5) obj) + (Assert (eq '() (object-plist obj)) obj)) + (Assert (eq 5 (get obj ?3 5)) obj) ) (Check-Error-Message @@ -1240,15 +1241,15 @@ ;;----------------------------------------------------- ;; Test subseq ;;----------------------------------------------------- -(Assert-equal (subseq nil 0) nil) -(Assert-equal (subseq [1 2 3] 0) [1 2 3]) -(Assert-equal (subseq [1 2 3] 1 -1) [2]) -(Assert-equal (subseq "123" 0) "123") -(Assert-equal (subseq "1234" -3 -1) "23") -(Assert-equal (subseq #*0011 0) #*0011) -(Assert-equal (subseq #*0011 -3 3) #*01) -(Assert-equal (subseq '(1 2 3) 0) '(1 2 3)) -(Assert-equal (subseq '(1 2 3 4) -3 nil) '(2 3 4)) +(Assert (equal (subseq nil 0) nil)) +(Assert (equal (subseq [1 2 3] 0) [1 2 3])) +(Assert (equal (subseq [1 2 3] 1 -1) [2])) +(Assert (equal (subseq "123" 0) "123")) +(Assert (equal (subseq "1234" -3 -1) "23")) +(Assert (equal (subseq #*0011 0) #*0011)) +(Assert (equal (subseq #*0011 -3 3) #*01)) +(Assert (equal (subseq '(1 2 3) 0) '(1 2 3))) +(Assert (equal (subseq '(1 2 3 4) -3 nil) '(2 3 4))) (Check-Error wrong-type-argument (subseq 3 2)) (Check-Error args-out-of-range (subseq [1 2 3] -42)) @@ -1257,7 +1258,7 @@ ;;----------------------------------------------------- ;; Time-related tests ;;----------------------------------------------------- -(Assert= (length (current-time-string)) 24) +(Assert (= (length (current-time-string)) 24)) ;;----------------------------------------------------- ;; format test @@ -1347,20 +1348,20 @@ ;;; The following two tests used to use 1000 instead of 100, ;;; but that merely found buffer overflow bugs in Solaris sprintf(). -(Assert= 102 (length (format "%.100f" 3.14))) -(Assert= 100 (length (format "%100f" 3.14))) +(Assert (= 102 (length (format "%.100f" 3.14)))) +(Assert (= 100 (length (format "%100f" 3.14)))) ;;; Check for 64-bit cleanness on LP64 platforms. -(Assert= (read (format "%d" most-positive-fixnum)) most-positive-fixnum) -(Assert= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum) -(Assert= (read (format "%u" most-positive-fixnum)) most-positive-fixnum) -(Assert= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum) -(Assert= (read (format "%d" most-negative-fixnum)) most-negative-fixnum) -(Assert= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum) +(Assert (= (read (format "%d" most-positive-fixnum)) most-positive-fixnum)) +(Assert (= (read (format "%ld" most-positive-fixnum)) most-positive-fixnum)) +(Assert (= (read (format "%u" most-positive-fixnum)) most-positive-fixnum)) +(Assert (= (read (format "%lu" most-positive-fixnum)) most-positive-fixnum)) +(Assert (= (read (format "%d" most-negative-fixnum)) most-negative-fixnum)) +(Assert (= (read (format "%ld" most-negative-fixnum)) most-negative-fixnum)) ;; These used to crash. -(Assert-eql (read (format "%f" 1.2e+302)) 1.2e+302) -(Assert-eql (read (format "%.1000d" 1)) 1) +(Assert (eql (read (format "%f" 1.2e+302)) 1.2e+302)) +(Assert (eql (read (format "%.1000d" 1)) 1)) ;;; "%u" is undocumented, and Emacs Lisp has no unsigned type. ;;; What to do if "%u" is used with a negative number? @@ -1418,12 +1419,12 @@ (if (= new-char old-char) (setq new-char ?/)) (aset load-file-name 0 new-char) - (Assert= new-char (aref load-file-name 0) + (Assert (= new-char (aref load-file-name 0)) \"Check that we can modify the string value of load-file-name\")) (let* ((new-load-file-name \"hi there\") (load-file-name new-load-file-name)) - (Assert-eq new-load-file-name load-file-name + (Assert (eq new-load-file-name load-file-name) \"Checking that we can bind load-file-name successfully.\")) ") @@ -1467,137 +1468,137 @@ one-fround-result two-fround-result one-truncate-result two-truncate-result one-ftruncate-result two-ftruncate-result) - (Assert-equal one-floor-result (multiple-value-list - (floor first)) + (Assert (equal one-floor-result (multiple-value-list + (floor first))) (format "checking (floor %S) gives %S" first one-floor-result)) - (Assert-equal one-floor-result (multiple-value-list - (floor first 1)) + (Assert (equal one-floor-result (multiple-value-list + (floor first 1))) (format "checking (floor %S 1) gives %S" first one-floor-result)) (Check-Error arith-error (floor first 0)) (Check-Error arith-error (floor first 0.0)) - (Assert-equal two-floor-result (multiple-value-list - (floor first second)) + (Assert (equal two-floor-result (multiple-value-list + (floor first second))) (format "checking (floor %S %S) gives %S" first second two-floor-result)) - (Assert-equal (cl-floor first second) - (multiple-value-list (floor first second)) + (Assert (equal (cl-floor first second) + (multiple-value-list (floor first second))) (format "checking (floor %S %S) gives the same as the old code" first second)) - (Assert-equal one-ffloor-result (multiple-value-list - (ffloor first)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first))) (format "checking (ffloor %S) gives %S" first one-ffloor-result)) - (Assert-equal one-ffloor-result (multiple-value-list - (ffloor first 1)) + (Assert (equal one-ffloor-result (multiple-value-list + (ffloor first 1))) (format "checking (ffloor %S 1) gives %S" first one-ffloor-result)) (Check-Error arith-error (ffloor first 0)) (Check-Error arith-error (ffloor first 0.0)) - (Assert-equal two-ffloor-result (multiple-value-list - (ffloor first second)) + (Assert (equal two-ffloor-result (multiple-value-list + (ffloor first second))) (format "checking (ffloor %S %S) gives %S" first second two-ffloor-result)) - (Assert-equal one-ceiling-result (multiple-value-list - (ceiling first)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first))) (format "checking (ceiling %S) gives %S" first one-ceiling-result)) - (Assert-equal one-ceiling-result (multiple-value-list - (ceiling first 1)) + (Assert (equal one-ceiling-result (multiple-value-list + (ceiling first 1))) (format "checking (ceiling %S 1) gives %S" first one-ceiling-result)) (Check-Error arith-error (ceiling first 0)) (Check-Error arith-error (ceiling first 0.0)) - (Assert-equal two-ceiling-result (multiple-value-list - (ceiling first second)) + (Assert (equal two-ceiling-result (multiple-value-list + (ceiling first second))) (format "checking (ceiling %S %S) gives %S" first second two-ceiling-result)) - (Assert-equal (cl-ceiling first second) - (multiple-value-list (ceiling first second)) + (Assert (equal (cl-ceiling first second) + (multiple-value-list (ceiling first second))) (format "checking (ceiling %S %S) gives the same as the old code" first second)) - (Assert-equal one-fceiling-result (multiple-value-list - (fceiling first)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first))) (format "checking (fceiling %S) gives %S" first one-fceiling-result)) - (Assert-equal one-fceiling-result (multiple-value-list - (fceiling first 1)) + (Assert (equal one-fceiling-result (multiple-value-list + (fceiling first 1))) (format "checking (fceiling %S 1) gives %S" first one-fceiling-result)) (Check-Error arith-error (fceiling first 0)) (Check-Error arith-error (fceiling first 0.0)) - (Assert-equal two-fceiling-result (multiple-value-list - (fceiling first second)) + (Assert (equal two-fceiling-result (multiple-value-list + (fceiling first second))) (format "checking (fceiling %S %S) gives %S" first second two-fceiling-result)) - (Assert-equal one-round-result (multiple-value-list - (round first)) + (Assert (equal one-round-result (multiple-value-list + (round first))) (format "checking (round %S) gives %S" first one-round-result)) - (Assert-equal one-round-result (multiple-value-list - (round first 1)) + (Assert (equal one-round-result (multiple-value-list + (round first 1))) (format "checking (round %S 1) gives %S" first one-round-result)) (Check-Error arith-error (round first 0)) (Check-Error arith-error (round first 0.0)) - (Assert-equal two-round-result (multiple-value-list - (round first second)) + (Assert (equal two-round-result (multiple-value-list + (round first second))) (format "checking (round %S %S) gives %S" first second two-round-result)) - (Assert-equal one-fround-result (multiple-value-list - (fround first)) + (Assert (equal one-fround-result (multiple-value-list + (fround first))) (format "checking (fround %S) gives %S" first one-fround-result)) - (Assert-equal one-fround-result (multiple-value-list - (fround first 1)) + (Assert (equal one-fround-result (multiple-value-list + (fround first 1))) (format "checking (fround %S 1) gives %S" first one-fround-result)) (Check-Error arith-error (fround first 0)) (Check-Error arith-error (fround first 0.0)) - (Assert-equal two-fround-result (multiple-value-list - (fround first second)) + (Assert (equal two-fround-result (multiple-value-list + (fround first second))) (format "checking (fround %S %S) gives %S" first second two-fround-result)) - (Assert-equal (cl-round first second) - (multiple-value-list (round first second)) + (Assert (equal (cl-round first second) + (multiple-value-list (round first second))) (format "checking (round %S %S) gives the same as the old code" first second)) - (Assert-equal one-truncate-result (multiple-value-list - (truncate first)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first))) (format "checking (truncate %S) gives %S" first one-truncate-result)) - (Assert-equal one-truncate-result (multiple-value-list - (truncate first 1)) + (Assert (equal one-truncate-result (multiple-value-list + (truncate first 1))) (format "checking (truncate %S 1) gives %S" first one-truncate-result)) (Check-Error arith-error (truncate first 0)) (Check-Error arith-error (truncate first 0.0)) - (Assert-equal two-truncate-result (multiple-value-list - (truncate first second)) + (Assert (equal two-truncate-result (multiple-value-list + (truncate first second))) (format "checking (truncate %S %S) gives %S" first second two-truncate-result)) - (Assert-equal (cl-truncate first second) - (multiple-value-list (truncate first second)) + (Assert (equal (cl-truncate first second) + (multiple-value-list (truncate first second))) (format "checking (truncate %S %S) gives the same as the old code" first second)) - (Assert-equal one-ftruncate-result (multiple-value-list - (ftruncate first)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first))) (format "checking (ftruncate %S) gives %S" first one-ftruncate-result)) - (Assert-equal one-ftruncate-result (multiple-value-list - (ftruncate first 1)) + (Assert (equal one-ftruncate-result (multiple-value-list + (ftruncate first 1))) (format "checking (ftruncate %S 1) gives %S" first one-ftruncate-result)) (Check-Error arith-error (ftruncate first 0)) (Check-Error arith-error (ftruncate first 0.0)) - (Assert-equal two-ftruncate-result (multiple-value-list - (ftruncate first second)) + (Assert (equal two-ftruncate-result (multiple-value-list + (ftruncate first second))) (format "checking (ftruncate %S %S) gives %S" first second two-ftruncate-result))) (Assert-rounding-floating (pie ee) @@ -2033,34 +2034,34 @@ (foo-zero 400 (1+ most-positive-fixnum))))) "Checking multiple values are discarded correctly when forced") (Check-Error setting-constant (setq multiple-values-limit 20)) - (Assert-equal '(-1 1) - (multiple-value-list (floor -3 4)) - "Checking #'multiple-value-list gives a sane result") + (Assert (equal '(-1 1) + (multiple-value-list (floor -3 4))) + "Checking #'multiple-value-list gives a sane result") (let ((ey 40000) (bee "this is a string") (cee #s(hash-table size 256 data (969 ?\xF9)))) - (Assert-equal - (multiple-value-list (values ey bee cee)) - (multiple-value-list (values-list (list ey bee cee))) - "Checking that #'values and #'values-list are correctly related") - (Assert-equal - (multiple-value-list (values-list (list ey bee cee))) - (multiple-value-list (apply #'values (list ey bee cee))) - "Checking #'values-list and #'apply with #values are correctly related")) - (Assert= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10 - "Checking #'multiple-value-call gives reasonable results.") - (Assert= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10 - "Checking #'multiple-value-call correct when first arg multiple.") - (Assert= 1 (length (multiple-value-list (prog1 (floor pi) "hi there"))) - "Checking #'prog1 does not pass back multiple values") - (Assert= 2 (length (multiple-value-list - (multiple-value-prog1 (floor pi) "hi there"))) - "Checking #'multiple-value-prog1 passes back multiple values") + (Assert (equal + (multiple-value-list (values ey bee cee)) + (multiple-value-list (values-list (list ey bee cee)))) + "Checking that #'values and #'values-list are correctly related") + (Assert (equal + (multiple-value-list (values-list (list ey bee cee))) + (multiple-value-list (apply #'values (list ey bee cee)))) + "Checking #'values-list and #'apply with #values are correctly related")) + (Assert (= (multiple-value-call #'+ (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call gives reasonable results.") + (Assert (= (multiple-value-call (values '+ '*) (floor 5 3) (floor 19 4)) 10) + "Checking #'multiple-value-call correct when first arg multiple.") + (Assert (= 1 (length (multiple-value-list (prog1 (floor pi) "hi there")))) + "Checking #'prog1 does not pass back multiple values") + (Assert (= 2 (length (multiple-value-list + (multiple-value-prog1 (floor pi) "hi there")))) + "Checking #'multiple-value-prog1 passes back multiple values") (multiple-value-bind (floored remainder this-is-nil) (floor pi 1.0) - (Assert= floored 3 + (Assert (= floored 3) "Checking floored bound correctly") - (Assert-eql remainder (- pi 3.0) + (Assert (eql remainder (- pi 3.0)) "Checking remainder bound correctly") (Assert (null this-is-nil) "Checking trailing arg bound but nil")) @@ -2069,62 +2070,62 @@ (cee #s(hash-table size 256 data (969 ?\xF9)))) (multiple-value-setq (ey bee cee) (ffloor e 1.0)) - (Assert-eql 2.0 ey "Checking ey set correctly") - (Assert-eql bee (- e 2.0) "Checking bee set correctly") + (Assert (eql 2.0 ey) "Checking ey set correctly") + (Assert (eql bee (- e 2.0)) "Checking bee set correctly") (Assert (null cee) "Checking cee set to nil correctly")) - (Assert= 3 (length (multiple-value-list (eval '(values nil t pi)))) - "Checking #'eval passes back multiple values") - (Assert= 2 (length (multiple-value-list (apply #'floor '(5 3)))) - "Checking #'apply passes back multiple values") - (Assert= 2 (length (multiple-value-list (funcall #'floor 5 3))) - "Checking #'funcall passes back multiple values") - (Assert-equal '(1 2) (multiple-value-list - (multiple-value-call #'floor (values 5 3))) - "Checking #'multiple-value-call passes back multiple values correctly") - (Assert= 1 (length (multiple-value-list - (and (multiple-value-function-returning-nil) t))) - "Checking multiple values from non-trailing forms discarded by #'and") - (Assert= 5 (length (multiple-value-list - (and t (multiple-value-function-returning-nil)))) - "Checking multiple values from final forms not discarded by #'and") - (Assert= 1 (length (multiple-value-list - (or (multiple-value-function-returning-t) t))) - "Checking multiple values from non-trailing forms discarded by #'and") - (Assert= 5 (length (multiple-value-list - (or nil (multiple-value-function-returning-t)))) - "Checking multiple values from final forms not discarded by #'and") - (Assert= 1 (length (multiple-value-list - (cond ((multiple-value-function-returning-t))))) - "Checking cond doesn't pass back multiple values in tests.") - (Assert-equal (list nil pi e radians-to-degrees degrees-to-radians) + (Assert (= 3 (length (multiple-value-list (eval '(values nil t pi))))) + "Checking #'eval passes back multiple values") + (Assert (= 2 (length (multiple-value-list (apply #'floor '(5 3))))) + "Checking #'apply passes back multiple values") + (Assert (= 2 (length (multiple-value-list (funcall #'floor 5 3)))) + "Checking #'funcall passes back multiple values") + (Assert (equal '(1 2) (multiple-value-list + (multiple-value-call #'floor (values 5 3)))) + "Checking #'multiple-value-call passes back multiple values correctly") + (Assert (= 1 (length (multiple-value-list + (and (multiple-value-function-returning-nil) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert (= 5 (length (multiple-value-list + (and t (multiple-value-function-returning-nil))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert (= 1 (length (multiple-value-list + (or (multiple-value-function-returning-t) t)))) + "Checking multiple values from non-trailing forms discarded by #'and") + (Assert (= 5 (length (multiple-value-list + (or nil (multiple-value-function-returning-t))))) + "Checking multiple values from final forms not discarded by #'and") + (Assert (= 1 (length (multiple-value-list + (cond ((multiple-value-function-returning-t)))))) + "Checking cond doesn't pass back multiple values in tests.") + (Assert (equal (list nil pi e radians-to-degrees degrees-to-radians) + (multiple-value-list + (cond (t (multiple-value-function-returning-nil))))) + "Checking cond passes back multiple values in clauses.") + (Assert (= 1 (length (multiple-value-list + (prog1 (multiple-value-function-returning-nil))))) + "Checking prog1 discards multiple values correctly.") + (Assert (= 5 (length (multiple-value-list + (multiple-value-prog1 + (multiple-value-function-returning-nil))))) + "Checking multiple-value-prog1 passes back multiple values correctly.") + (Assert (equal (list t pi e degrees-to-radians radians-to-degrees) (multiple-value-list - (cond (t (multiple-value-function-returning-nil)))) - "Checking cond passes back multiple values in clauses.") - (Assert= 1 (length (multiple-value-list - (prog1 (multiple-value-function-returning-nil)))) - "Checking prog1 discards multiple values correctly.") - (Assert= 5 (length (multiple-value-list - (multiple-value-prog1 - (multiple-value-function-returning-nil)))) - "Checking multiple-value-prog1 passes back multiple values correctly.") - (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) - (multiple-value-list - (catch 'VoN61Lo4Y (function-throwing-multiple-values)))) - (Assert-equal (list t pi e degrees-to-radians radians-to-degrees) + (catch 'VoN61Lo4Y (function-throwing-multiple-values))))) + (Assert (equal (list t pi e degrees-to-radians radians-to-degrees) (multiple-value-list (loop for eye in `(a b c d ,e f g ,nil ,pi) do (when (null eye) - (return (multiple-value-function-returning-t))))) + (return (multiple-value-function-returning-t)))))) "Checking #'loop passes back multiple values correctly.") (Assert (null (or)) "Checking #'or behaves correctly with zero arguments.") - (Assert-eq t (and) + (Assert (eq t (and)) "Checking #'and behaves correctly with zero arguments.") - (Assert= (* 3.0 (- pi 3.0)) + (Assert (= (* 3.0 (- pi 3.0)) (letf (((values three one-four-one-five-nine) (floor pi))) - (* three one-four-one-five-nine)) + (* three one-four-one-five-nine))) "checking letf handles #'values in a basic sense")) ;; #'equalp tests. @@ -2152,8 +2153,8 @@ (loop for li in equal-lists do (loop for (x . tail) on li do (loop for y in tail do - (Assert-equalp x y) - (Assert-equalp y x))))) + (Assert (equalp x y)) + (Assert (equalp y x)))))) (let ((diff-list `(0 1 2 3 1000 5000000000 5555555555555555555555555555555555555 @@ -2164,73 +2165,73 @@ 1e+300 1e+301 -1e+300 -1e+301))) (loop for (x . tail) on diff-list do (loop for y in tail do - (Assert-not-equalp x y) - (Assert-not-equalp y x)))) + (Assert (not (equalp x y))) + (Assert (not (equalp y x)))))) - (Assert-equalp "hi there" "Hi There" - "checking equalp isn't case-sensitive") - (Assert-equalp 99 99.0 - "checking equalp compares numerical values of different types") + (Assert (equalp "hi there" "Hi There") + "checking equalp isn't case-sensitive") + (Assert (equalp 99 99.0) + "checking equalp compares numerical values of different types") (Assert (null (equalp 99 ?c)) "checking equalp does not convert characters to numbers") ;; Fixed in Hg d0ea57eb3de4. (Assert (null (equalp "hi there" [hi there])) "checking equalp doesn't error with string and non-string") - (Assert-equalp "ABCDEEFGH\u00CDJ" string-variable - "checking #'equalp is case-insensitive with an upcased constant") - (Assert-equalp "abcdeefgh\xedj" string-variable - "checking #'equalp is case-insensitive with a downcased constant") - (Assert-equalp string-variable string-variable - "checking #'equalp works when handed the same string twice") - (Assert-equalp string-variable "aBcDeeFgH\u00Edj" - "check #'equalp is case-insensitive with a variable-cased constant") - (Assert-equalp "" (bit-vector) - "check empty string and empty bit-vector are #'equalp.") - (Assert-equalp (string) (bit-vector) - "check empty string and empty bit-vector are #'equalp, no constants") - (Assert-equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e) - "check string and vector with same contents #'equalp") - (Assert-equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) - (vector ?h ?i ?\ ?t ?h ?e ?r ?e) - "check string and vector with same contents #'equalp, no constants") - (Assert-equalp [?h ?i ?\ ?t ?h ?e ?r ?e] - (string ?h ?i ?\ ?t ?h ?e ?r ?e) - "check string and vector with same contents #'equalp, vector constant") - (Assert-equalp [0 1.0 0.0 0 1] - (bit-vector 0 1 0 0 1) - "check vector and bit-vector with same contents #'equalp,\ + (Assert (equalp "ABCDEEFGH\u00CDJ" string-variable) + "checking #'equalp is case-insensitive with an upcased constant") + (Assert (equalp "abcdeefgh\xedj" string-variable) + "checking #'equalp is case-insensitive with a downcased constant") + (Assert (equalp string-variable string-variable) + "checking #'equalp works when handed the same string twice") + (Assert (equalp string-variable "aBcDeeFgH\u00Edj") + "check #'equalp is case-insensitive with a variable-cased constant") + (Assert (equalp "" (bit-vector)) + "check empty string and empty bit-vector are #'equalp.") + (Assert (equalp (string) (bit-vector)) + "check empty string and empty bit-vector are #'equalp, no constants") + (Assert (equalp "hi there" (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) + "check string and vector with same contents #'equalp") + (Assert (equalp (string ?h ?i ?\ ?t ?h ?e ?r ?e) + (vector ?h ?i ?\ ?t ?h ?e ?r ?e)) + "check string and vector with same contents #'equalp, no constants") + (Assert (equalp [?h ?i ?\ ?t ?h ?e ?r ?e] + (string ?h ?i ?\ ?t ?h ?e ?r ?e)) + "check string and vector with same contents #'equalp, vector constant") + (Assert (equalp [0 1.0 0.0 0 1] + (bit-vector 0 1 0 0 1)) + "check vector and bit-vector with same contents #'equalp,\ vector constant") - (Assert-not-equalp [0 2 0.0 0 1] - (bit-vector 0 1 0 0 1) - "check vector and bit-vector with different contents not #'equalp,\ + (Assert (not (equalp [0 2 0.0 0 1] + (bit-vector 0 1 0 0 1))) + "check vector and bit-vector with different contents not #'equalp,\ vector constant") - (Assert-equalp #*01001 - (vector 0 1.0 0.0 0 1) - "check vector and bit-vector with same contents #'equalp,\ + (Assert (equalp #*01001 + (vector 0 1.0 0.0 0 1)) + "check vector and bit-vector with same contents #'equalp,\ bit-vector constant") - (Assert-equalp ?\u00E9 Eacute-character - "checking characters are case-insensitive, one constant") - (Assert-not-equalp ?\u00E9 (aref (format "%c" ?a) 0) - "checking distinct characters are not equalp, one constant") - (Assert-equalp t (and) - "checking symbols are correctly #'equalp") - (Assert-not-equalp t (or nil '#:t) - "checking distinct symbols with the same name are not #'equalp") - (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "hi-there" aragh) - aragh) - "checking #'equalp succeeds correctly, char-tables") - (Assert-equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "HI-THERE" aragh) - aragh) - "checking #'equalp succeeds correctly, char-tables") - (Assert-not-equalp #s(char-table type generic data (?\u0080 "hi-there")) - (let ((aragh (make-char-table 'generic))) - (put-char-table ?\u0080 "hi there" aragh) - aragh) - "checking #'equalp fails correctly, char-tables")) + (Assert (equalp ?\u00E9 Eacute-character) + "checking characters are case-insensitive, one constant") + (Assert (not (equalp ?\u00E9 (aref (format "%c" ?a) 0))) + "checking distinct characters are not equalp, one constant") + (Assert (equalp t (and)) + "checking symbols are correctly #'equalp") + (Assert (not (equalp t (or nil '#:t))) + "checking distinct symbols with the same name are not #'equalp") + (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi-there" aragh) + aragh)) + "checking #'equalp succeeds correctly, char-tables") + (Assert (equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "HI-THERE" aragh) + aragh)) + "checking #'equalp succeeds correctly, char-tables") + (Assert (not (equalp #s(char-table type generic data (?\u0080 "hi-there")) + (let ((aragh (make-char-table 'generic))) + (put-char-table ?\u0080 "hi there" aragh) + aragh))) + "checking #'equalp fails correctly, char-tables") ;; There are more tests available for equalp here: ;; @@ -2279,33 +2280,33 @@ (1- most-negative-fixnum)) (*-2-most-positive-fixnum () (* 2 most-positive-fixnum))) - (Assert-eq - (member* (1+ most-positive-fixnum) member*-list) - (member* (1+ most-positive-fixnum) member*-list :test #'eql) - "checking #'member* correct if #'eql not explicitly specified") - (Assert-eq - (assoc* (1+ most-positive-fixnum) assoc*-list) - (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql) - "checking #'assoc* correct if #'eql not explicitly specified") - (Assert-eq - (rassoc* (1- most-negative-fixnum) assoc*-list) - (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql) - "checking #'rassoc* correct if #'eql not explicitly specified") - (Assert-eql (1+most-positive-fixnum) (1+ most-positive-fixnum) - "checking #'eql handles a bignum literal properly.") - (Assert-eq - (member* (1+most-positive-fixnum) member*-list) - (member* (1+ most-positive-fixnum) member*-list :test #'equal) - "checking #'member* compiler macro correct with literal bignum") - (Assert-eq - (assoc* (1+most-positive-fixnum) assoc*-list) - (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal) - "checking #'assoc* compiler macro correct with literal bignum") + (Assert (eq + (member* (1+ most-positive-fixnum) member*-list) + (member* (1+ most-positive-fixnum) member*-list :test #'eql)) + "checking #'member* correct if #'eql not explicitly specified") + (Assert (eq + (assoc* (1+ most-positive-fixnum) assoc*-list) + (assoc* (1+ most-positive-fixnum) assoc*-list :test #'eql)) + "checking #'assoc* correct if #'eql not explicitly specified") + (Assert (eq + (rassoc* (1- most-negative-fixnum) assoc*-list) + (rassoc* (1- most-negative-fixnum) assoc*-list :test #'eql)) + "checking #'rassoc* correct if #'eql not explicitly specified") + (Assert (eql (1+most-positive-fixnum) (1+ most-positive-fixnum)) + "checking #'eql handles a bignum literal properly.") + (Assert (eq + (member* (1+most-positive-fixnum) member*-list) + (member* (1+ most-positive-fixnum) member*-list :test #'equal)) + "checking #'member* compiler macro correct with literal bignum") + (Assert (eq + (assoc* (1+most-positive-fixnum) assoc*-list) + (assoc* (1+ most-positive-fixnum) assoc*-list :test #'equal)) + "checking #'assoc* compiler macro correct with literal bignum") (puthash (setq hashed-bignum (*-2-most-positive-fixnum)) (gensym) hashing) - (Assert-eq - (gethash (* 2 most-positive-fixnum) hashing) - (gethash hashed-bignum hashing) - "checking hashing works correctly with #'eql tests and bignums")))) + (Assert (eq + (gethash (* 2 most-positive-fixnum) hashing) + (gethash hashed-bignum hashing)) + "checking hashing works correctly with #'eql tests and bignums")))) ;;; end of lisp-tests.el
--- a/tests/automated/md5-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/md5-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -56,7 +56,7 @@ ;;----------------------------------------------------- (mapcar (lambda (x) - (Assert-equal (md5 (car x)) (cdr x))) + (Assert (equal (md5 (car x)) (cdr x)))) md5-tests) ;;----------------------------------------------------- @@ -66,8 +66,8 @@ (let ((large-string (mapconcat #'car md5-tests ""))) (let ((count 0)) (mapcar (lambda (x) - (Assert-equal (md5 large-string count (+ count (length (car x)))) - (cdr x)) + (Assert (equal (md5 large-string count (+ count (length (car x)))) + (cdr x))) (incf count (length (car x)))) md5-tests))) @@ -79,7 +79,7 @@ (mapcar (lambda (x) (erase-buffer) (insert (car x)) - (Assert-equal (md5 (current-buffer)) (cdr x))) + (Assert (equal (md5 (current-buffer)) (cdr x)))) md5-tests)) ;;----------------------------------------------------- @@ -90,7 +90,7 @@ (insert (mapconcat #'car md5-tests "")) (let ((point 1)) (mapcar (lambda (x) - (Assert-equal (md5 (current-buffer) point (+ point (length (car x)))) - (cdr x)) + (Assert (equal (md5 (current-buffer) point (+ point (length (car x)))) + (cdr x))) (incf point (length (car x)))) md5-tests)))
--- a/tests/automated/mule-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/mule-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -1,4 +1,5 @@ ;; Copyright (C) 1999 Free Software Foundation, Inc. +;; Copyright (C) 2010 Ben Wing. ;; Author: Hrvoje Niksic <hniksic@xemacs.org> ;; Maintainers: Hrvoje Niksic <hniksic@xemacs.org>, @@ -65,7 +66,7 @@ ;; buffer. (with-temp-buffer (insert string) - (Assert-equal (buffer-string) string)) + (Assert (equal (buffer-string) string))) ;; For use without test harness: use a normal buffer, so that ;; you can also test whether redisplay works. (switch-to-buffer (get-buffer-create "test")) @@ -152,12 +153,12 @@ (dolist (coding-system '(utf-8 windows-1251 macintosh big5)) (when (find-coding-system coding-system) (find-file existing-file-name coding-system) - (Assert-eq (find-coding-system coding-system) - buffer-file-coding-system) + (Assert (eq (find-coding-system coding-system) + buffer-file-coding-system)) (kill-buffer nil) (find-file nonexistent-file-name coding-system) - (Assert-eq (find-coding-system coding-system) - buffer-file-coding-system) + (Assert (eq (find-coding-system coding-system) + buffer-file-coding-system)) (set-buffer-modified-p nil) (kill-buffer nil))) (delete-file existing-file-name)) @@ -177,9 +178,9 @@ (char2 (make-char charset2 69))) `(let ((string (make-string 1000 ,char1))) (fillarray string ,char2) - (Assert-eq (aref string 0) ,char2) - (Assert-eq (aref string (1- (length string))) ,char2) - (Assert-eq (length string) 1000))))) + (Assert (eq (aref string 0) ,char2)) + (Assert (eq (aref string (1- (length string))) ,char2)) + (Assert (eq (length string) 1000)))))) (fillarray-test ascii latin-iso8859-1) (fillarray-test ascii latin-iso8859-2) (fillarray-test latin-iso8859-1 ascii) @@ -188,7 +189,7 @@ ;; Test aset (let ((string (string (make-char 'ascii 69) (make-char 'latin-iso8859-2 69)))) (aset string 0 (make-char 'latin-iso8859-2 42)) - (Assert-eq (aref string 1) (make-char 'latin-iso8859-2 69))) + (Assert (eq (aref string 1) (make-char 'latin-iso8859-2 69)))) ;;--------------------------------------------------------------- ;; Test coding system functions @@ -210,8 +211,8 @@ (define-coding-system-alias 'mule-tests-alias 'binary) (Assert (coding-system-alias-p 'mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) - (Assert-eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)) - (Assert-eq 'binary (coding-system-aliasee 'mule-tests-alias)) + (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias))) + (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias))) (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) (Assert (not (coding-system-alias-p 'mule-tests-alias-dos))) (Assert (not (coding-system-alias-p 'mule-tests-alias-mac))) @@ -219,8 +220,8 @@ (define-coding-system-alias 'mule-tests-alias (get-coding-system 'binary)) (Assert (coding-system-alias-p 'mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) - (Assert-eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias)) - (Assert-eq 'binary (coding-system-aliasee 'mule-tests-alias)) + (Assert (eq (get-coding-system 'binary) (get-coding-system 'mule-tests-alias))) + (Assert (eq 'binary (coding-system-aliasee 'mule-tests-alias))) (Assert (not (coding-system-alias-p 'mule-tests-alias-unix))) (Assert (not (coding-system-alias-p 'mule-tests-alias-dos))) (Assert (not (coding-system-alias-p 'mule-tests-alias-mac))) @@ -228,9 +229,9 @@ (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias) (Assert (coding-system-alias-p 'nested-mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias))) - (Assert-eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias)) - (Assert-eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias) - (Assert-eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)) + (Assert (eq (get-coding-system 'binary) (get-coding-system 'nested-mule-tests-alias))) + (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias)) + (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias))) (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-unix))) (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-dos))) (Assert (not (coding-system-alias-p 'nested-mule-tests-alias-mac))) @@ -266,8 +267,8 @@ (define-coding-system-alias 'mule-tests-alias 'iso-8859-7) (Assert (coding-system-alias-p 'mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) - (Assert-eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)) - (Assert-eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)) + (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias))) + (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias))) (Assert (coding-system-alias-p 'mule-tests-alias-unix)) (Assert (coding-system-alias-p 'mule-tests-alias-dos)) (Assert (coding-system-alias-p 'mule-tests-alias-mac)) @@ -275,26 +276,26 @@ (define-coding-system-alias 'mule-tests-alias (get-coding-system 'iso-8859-7)) (Assert (coding-system-alias-p 'mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'mule-tests-alias))) - (Assert-eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias)) - (Assert-eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias)) + (Assert (eq (get-coding-system 'iso-8859-7) (get-coding-system 'mule-tests-alias))) + (Assert (eq 'iso-8859-7 (coding-system-aliasee 'mule-tests-alias))) (Assert (coding-system-alias-p 'mule-tests-alias-unix)) (Assert (coding-system-alias-p 'mule-tests-alias-dos)) (Assert (coding-system-alias-p 'mule-tests-alias-mac)) - (Assert-eq (find-coding-system 'mule-tests-alias-mac) - (find-coding-system 'iso-8859-7-mac)) + (Assert (eq (find-coding-system 'mule-tests-alias-mac) + (find-coding-system 'iso-8859-7-mac))) (define-coding-system-alias 'nested-mule-tests-alias 'mule-tests-alias) (Assert (coding-system-alias-p 'nested-mule-tests-alias)) (Assert (not (coding-system-canonical-name-p 'nested-mule-tests-alias))) - (Assert-eq (get-coding-system 'iso-8859-7) - (get-coding-system 'nested-mule-tests-alias)) - (Assert-eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias) - (Assert-eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias)) + (Assert (eq (get-coding-system 'iso-8859-7) + (get-coding-system 'nested-mule-tests-alias))) + (Assert (eq (coding-system-aliasee 'nested-mule-tests-alias) 'mule-tests-alias)) + (Assert (eq 'mule-tests-alias (coding-system-aliasee 'nested-mule-tests-alias))) (Assert (coding-system-alias-p 'nested-mule-tests-alias-unix)) (Assert (coding-system-alias-p 'nested-mule-tests-alias-dos)) (Assert (coding-system-alias-p 'nested-mule-tests-alias-mac)) - (Assert-eq (find-coding-system 'nested-mule-tests-alias-unix) - (find-coding-system 'iso-8859-7-unix)) + (Assert (eq (find-coding-system 'nested-mule-tests-alias-unix) + (find-coding-system 'iso-8859-7-unix))) (Check-Error-Message error "Attempt to create a coding system alias loop" @@ -351,28 +352,51 @@ (loop for j from 0 below (length string) do (aset string j (aref greek-string (mod j 96)))) (loop for k in '(0 1 58 59) do - (Assert-equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))) + (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string)))) (let ((greek-string (charset-char-string 'greek-iso8859-7)) (string (make-string (* 96 60) ??))) (loop for j from (1- (length string)) downto 0 do (aset string j (aref greek-string (mod j 96)))) (loop for k in '(0 1 58 59) do - (Assert-equal (substring string (* 96 k) (* 96 (1+ k))) greek-string))) + (Assert (equal (substring string (* 96 k) (* 96 (1+ k))) greek-string)))) (let ((ascii-string (charset-char-string 'ascii)) (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57)))) (loop for j from 0 below (length string) do (aset string j (aref ascii-string (mod j 94)))) (loop for k in '(0 1 58 59) do - (Assert-equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string))) + (Assert (equal (substring string (* 94 k) (+ 94 (* 94 k))) ascii-string)))) (let ((ascii-string (charset-char-string 'ascii)) (string (make-string (* 94 60) (make-char 'greek-iso8859-7 57)))) (loop for j from (1- (length string)) downto 0 do (aset string j (aref ascii-string (mod j 94)))) (loop for k in '(0 1 58 59) do - (Assert-equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string))) + (Assert (equal (substring string (* 94 k) (* 94 (1+ k))) ascii-string)))) + + ;;--------------------------------------------------------------- + ;; Test string character conversion + ;;--------------------------------------------------------------- + + ;; #### This should test all coding systems! + + (let ((all-octets (let ((s (make-string 256 ?\000))) + (loop for i from (1- (length s)) downto 0 do + (aset s i (int-char i))) + s)) + (escape-quoted-result (let ((schar '(27 155 142 143 14 15)) + (s (make-string 262 ?\000)) + (pos 0)) + (loop for ord from 0 to 255 do + (when (member ord schar) + (aset s pos ?\033) + (incf pos)) + (aset s pos (int-char ord)) + (incf pos)) + s))) + (Assert (string= (encode-coding-string all-octets 'escape-quoted) + escape-quoted-result))) ;;--------------------------------------------------------------- ;; Test file-system character conversion (and, en passant, file ops) @@ -415,8 +439,8 @@ (when working-symlinks (make-symbolic-link name1 name2) (Assert (file-exists-p name2)) - (Assert-equal (file-truename name2) name1) - (Assert-equal (file-truename name1) name1)) + (Assert (equal (file-truename name2) name1)) + (Assert (equal (file-truename name1) name1))) (ignore-file-errors (delete-file name1)) (ignore-file-errors (delete-file name2)) (ignore-file-errors (delete-file name3))) @@ -434,8 +458,8 @@ do (progn (set-unicode-conversion scaron code) - (Assert-eq code (char-to-unicode scaron)) - (Assert-eq scaron (unicode-to-char code '(latin-iso8859-2)))) + (Assert (eq code (char-to-unicode scaron))) + (Assert (eq scaron (unicode-to-char code '(latin-iso8859-2))))) finally (set-unicode-conversion scaron initial-unicode)) (Check-Error wrong-type-argument (set-unicode-conversion scaron -10000))) @@ -450,37 +474,37 @@ (let* ((xemacs-character (car (append (decode-coding-string utf-8-char 'utf-8) nil))) - (xemacs-charset (char-charset xemacs-character))) + (xemacs-charset (car (split-char xemacs-character)))) ;; Trivial test of the UTF-8 support of the escape-quoted character set. - (Assert-equal (decode-coding-string utf-8-char 'utf-8) + (Assert (equal (decode-coding-string utf-8-char 'utf-8) (decode-coding-string (concat "\033%G" utf-8-char) - 'escape-quoted)) + 'escape-quoted))) ;; Check that the reverse mapping holds. - (Assert-equal (unicode-code-point-to-utf-8-string + (Assert (equal (unicode-code-point-to-utf-8-string (encode-char xemacs-character 'ucs)) - utf-8-char) + utf-8-char)) ;; Check that, if this character has been JIT-allocated, it is encoded ;; in escape-quoted using the corresponding UTF-8 escape. (when (charset-property xemacs-charset 'encode-as-utf-8) - (Assert-equal (concat "\033%G" utf-8-char) - (encode-coding-string xemacs-character 'escape-quoted)) - (Assert-equal (concat "\033%G" utf-8-char) - (encode-coding-string xemacs-character 'ctext))))) + (Assert (equal (concat "\033%G" utf-8-char) + (encode-coding-string xemacs-character 'escape-quoted))) + (Assert (equal (concat "\033%G" utf-8-char) + (encode-coding-string xemacs-character 'ctext)))))) (loop for (code-point utf-16-big-endian utf-16-little-endian) in '((#x10000 "\xd8\x00\xdc\x00" "\x00\xd8\x00\xdc") (#x10FFFD "\xdb\xff\xdf\xfd" "\xff\xdb\xfd\xdf")) do - (Assert-equal (encode-coding-string + (Assert (equal (encode-coding-string (decode-char 'ucs code-point) 'utf-16) - utf-16-big-endian) - (Assert-equal (encode-coding-string + utf-16-big-endian)) + (Assert (equal (encode-coding-string (decode-char 'ucs code-point) 'utf-16-le) - utf-16-little-endian)) + utf-16-little-endian))) ;;--------------------------------------------------------------- @@ -497,11 +521,11 @@ (write-multibyte-character r0 r1))) "CCL program that writes two control-1 multibyte characters.") - (Assert-equal + (Assert (equal (ccl-execute-on-string 'ccl-write-two-control-1-chars ccl-vector "") (format "%c%c" (make-char 'control-1 0) - (make-char 'control-1 31))) + (make-char 'control-1 31)))) (define-ccl-program ccl-unicode-two-control-1-chars `(1 @@ -539,11 +563,11 @@ ;; (maybe we should): (eq 'lf (coding-system-eol-type coding-system))) ;; These coding systems are round-trip compatible with themselves. - (Assert-equal (encode-coding-string + (Assert (equal (encode-coding-string (decode-coding-string all-possible-octets coding-system) coding-system) - all-possible-octets + all-possible-octets) (format "checking %s is transparent" coding-system)))) ;;--------------------------------------------------------------- @@ -557,17 +581,17 @@ hebrew-iso8859-8 japanese-jisx0208 japanese-jisx0212 katakana-jisx0201 korean-ksc5601 latin-iso8859-1 latin-iso8859-2 vietnamese-viscii-lower))) - (Assert-equal + (Assert (equal ;; The sort is to make the algorithm of charsets-in-region ;; irrelevant. (sort (charsets-in-region (point-min) (point-max)) #'string<) - sorted-charsets-in-HELLO) - (Assert-equal + sorted-charsets-in-HELLO)) + (Assert (equal (sort (charsets-in-string (buffer-substring (point-min) (point-max))) #'string<) - sorted-charsets-in-HELLO))) + sorted-charsets-in-HELLO)))) ;;--------------------------------------------------------------- ;; Language environments, and whether the specified values are sane. @@ -580,7 +604,7 @@ do ;; s-l-e can call #'require, which says "Loading ..." (Silence-Message (set-language-environment language)) - (Assert-equal language current-language-environment) + (Assert (equal language current-language-environment)) (setq language-input-method (get-language-info language 'input-method)) @@ -600,7 +624,7 @@ ;; s-i-m can load files. (Silence-Message (set-input-method language-input-method)) - (Assert-equal language-input-method current-input-method))) + (Assert (equal language-input-method current-input-method)))) (dolist (charset (get-language-info language 'charset)) (Assert (charsetp (find-charset charset))))
--- a/tests/automated/query-coding-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/query-coding-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -70,7 +70,7 @@ :test #'eq)) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) coding-system) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) (format "checking query-coding-region ASCII-transparency, %s" coding-system)) (Assert (null query-coding-table) @@ -78,7 +78,7 @@ coding-system))) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-string ascii-chars-string coding-system) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) (format "checking query-coding-string ASCII-transparency, %s" coding-system)) (Assert (null query-coding-table) @@ -89,19 +89,20 @@ (insert latin-1-chars-string) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) 'iso-8859-1-unix) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) "checking query-coding-region iso-8859-1-transparency") (Assert (null query-coding-table) "checking query-coding-region iso-8859-1-transparency")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-string (buffer-string) 'iso-8859-1-unix) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) "checking query-coding-string iso-8859-1-transparency") (Assert (null query-coding-table) "checking query-coding-string iso-8859-1-transparency")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-string (buffer-string) 'iso-latin-1-with-esc-unix) - (Assert-eq t query-coding-succeeded + (Assert + (eq t query-coding-succeeded) "checking query-coding-region iso-latin-1-with-esc-transparency") (Assert (null query-coding-table) @@ -113,9 +114,10 @@ (Assert (null query-coding-succeeded) "checking that query-coding-region fails, U+20AC, iso-8859-1") - (Assert-equal query-coding-table + (Assert + (equal query-coding-table #s(range-table type start-closed-end-open data - ((257 258) unencodable)) + ((257 258) unencodable))) "checking query-coding-region fails correctly, U+20AC, iso-8859-1")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) @@ -159,17 +161,19 @@ (Assert (null query-coding-succeeded) "check query-coding-region fails, windows-1252, invalid-sequences") - (Assert-equal query-coding-table + (Assert + (equal query-coding-table #s(range-table type start-closed-end-open data ((130 131) invalid-sequence (142 143) invalid-sequence (144 146) invalid-sequence - (158 159) invalid-sequence)) + (158 159) invalid-sequence))) "check query-coding-region fails, windows-1252, invalid-sequences")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) 'windows-1252-unix (current-buffer) t) - (Assert-eq t query-coding-succeeded + (Assert + (eq t query-coding-succeeded) "checking that query-coding-region succeeds, U+20AC, windows-1252") (Assert (null query-coding-table) @@ -181,22 +185,24 @@ (Assert (null query-coding-succeeded) "checking that query-coding-region fails, U+0080, windows-1252") - (Assert-equal query-coding-table + (Assert + (equal query-coding-table #s(range-table type start-closed-end-open data - ((257 258) unencodable)) + ((257 258) unencodable))) "checking that query-coding-region fails, U+0080, windows-1252")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) 'windows-1252-unix) (Assert (null query-coding-succeeded) "check query-coding-region fails, U+0080, invalid-sequence, cp1252") - (Assert-equal query-coding-table + (Assert + (equal query-coding-table #s(range-table type start-closed-end-open data ((130 131) invalid-sequence (142 143) invalid-sequence (144 146) invalid-sequence (158 159) invalid-sequence - (257 258) unencodable)) + (257 258) unencodable))) "check query-coding-region fails, U+0080, invalid-sequence, cp1252")) ;; Try a similar approach with koi8-o, the koi8 variant with ;; support for Old Church Slavonic. @@ -213,7 +219,7 @@ "checking that query-coding-region succeeds, koi8-o-unix")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) (point-max) 'escape-quoted) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) "checking that query-coding-region succeeds, escape-quoted") (Assert (null query-coding-table) "checking that query-coding-region succeeds, escape-quoted")) @@ -277,15 +283,15 @@ (query-coding-region (point-min) (point-max) coding-system) (Assert (null query-coding-succeeded) "checking unicode coding systems fail with unmapped chars") - (Assert-equal query-coding-table + (Assert (equal query-coding-table #s(range-table type start-closed-end-open data ((173 174) unencodable (209 210) unencodable - (254 255) unencodable)) + (254 255) unencodable))) "checking unicode coding systems fail with unmapped chars")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region (point-min) 173 coding-system) - (Assert-eq t query-coding-succeeded + (Assert (eq t query-coding-succeeded) "checking unicode coding systems succeed sans unmapped chars") (Assert (null query-coding-table) @@ -300,7 +306,7 @@ "checking unicode coding systems succeed sans unmapped chars again")) (multiple-value-bind (query-coding-succeeded query-coding-table) (query-coding-region 210 254 coding-system) - (Assert-eq t query-coding-succeeded) + (Assert (eq t query-coding-succeeded)) (Assert (null query-coding-table))) ;; Check that it errors correctly. (setq text-conversion-error-signalled nil) @@ -336,11 +342,11 @@ (format "checking %s fails with unmapped chars and invalid seqs" coding-system)) - (Assert-equal query-coding-table + (Assert (equal query-coding-table #s(range-table type start-closed-end-open data ((1 5) unencodable (5 9) invalid-sequence - (9 13) unencodable)) + (9 13) unencodable))) (format "checking %s fails with unmapped chars and invalid seqs" coding-system))) @@ -390,23 +396,23 @@ "check #'unencodable-char-position has some borked GNU semantics") (dotimes (i 6) (insert (decode-char 'ucs #x20ac))) ;; Check if it stops at one: - (Assert-equal '(257) (unencodable-char-position (point-min) (point-max) - 'iso-8859-1 1) + (Assert (equal '(257) (unencodable-char-position (point-min) (point-max) + 'iso-8859-1 1)) "check #'unencodable-char-position stops at 1 when asked to") ;; Check if it stops at four: - (Assert-equal '(260 259 258 257) + (Assert (equal '(260 259 258 257) (unencodable-char-position (point-min) (point-max) - 'iso-8859-1 4) + 'iso-8859-1 4)) "check #'unencodable-char-position stops at 4 when asked to") ;; Check whether it stops at seven: - (Assert-equal '(263 262 261 260 259 258 257) + (Assert (equal '(263 262 261 260 259 258 257) (unencodable-char-position (point-min) (point-max) - 'iso-8859-1 7) + 'iso-8859-1 7)) "check #'unencodable-char-position stops at 7 when asked to") ;; Check that it still stops at seven: - (Assert-equal '(263 262 261 260 259 258 257) + (Assert (equal '(263 262 261 260 259 258 257) (unencodable-char-position (point-min) (point-max) - 'iso-8859-1 2000) + 'iso-8859-1 2000)) "check #'unencodable-char-position stops at 7 if 2000 asked for") ;; Now, #'check-coding-systems-region. ;; UTF-8 should certainly be able to encode these characters:
--- a/tests/automated/regexp-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/regexp-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -1,6 +1,7 @@ ;;; -*- coding: iso-8859-1 -*- ;; Copyright (C) 2000, 2002, 2003 Free Software Foundation, Inc. +;; Copyright (C) 2010 Ben Wing. ;; Author: Yoshiki Hayashi <yoshiki@xemacs.org> ;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org> @@ -96,40 +97,40 @@ ;; forward (goto-char (point-min)) ;; Avoid trivial regexp. - (Assert-eq 2 (re-search-forward "ä\\|a" nil t)) + (Assert (eq 2 (re-search-forward "ä\\|a" nil t))) (goto-char (point-min)) - (Assert-eq 2 (re-search-forward "Ä\\|a" nil t)) + (Assert (eq 2 (re-search-forward "Ä\\|a" nil t))) (goto-char (1+ (point-min))) - (Assert-eq 3 (re-search-forward "ä\\|a" nil t)) + (Assert (eq 3 (re-search-forward "ä\\|a" nil t))) (goto-char (1+ (point-min))) - (Assert-eq 3 (re-search-forward "Ä\\|a" nil t)) + (Assert (eq 3 (re-search-forward "Ä\\|a" nil t))) ;; backward (goto-char (point-max)) - (Assert-eq 2 (re-search-backward "ä\\|a" nil t)) + (Assert (eq 2 (re-search-backward "ä\\|a" nil t))) (goto-char (point-max)) - (Assert-eq 2 (re-search-backward "Ä\\|a" nil t)) + (Assert (eq 2 (re-search-backward "Ä\\|a" nil t))) (goto-char (1- (point-max))) - (Assert-eq 1 (re-search-backward "ä\\|a" nil t)) + (Assert (eq 1 (re-search-backward "ä\\|a" nil t))) (goto-char (1- (point-max))) - (Assert-eq 1 (re-search-backward "Ä\\|a" nil t)) + (Assert (eq 1 (re-search-backward "Ä\\|a" nil t))) ;; case sensitive (setq case-fold-search nil) ;; forward (goto-char (point-min)) - (Assert-eq 2 (re-search-forward "ä\\|a" nil t)) + (Assert (eq 2 (re-search-forward "ä\\|a" nil t))) (goto-char (point-min)) - (Assert-eq 3 (re-search-forward "Ä\\|a" nil t)) + (Assert (eq 3 (re-search-forward "Ä\\|a" nil t))) (goto-char (1+ (point-min))) (Assert (not (re-search-forward "ä\\|a" nil t))) (goto-char (1+ (point-min))) - (Assert-eq 3 (re-search-forward "Ä\\|a" nil t)) + (Assert (eq 3 (re-search-forward "Ä\\|a" nil t))) ;; backward (goto-char (point-max)) - (Assert-eq 1 (re-search-backward "ä\\|a" nil t)) + (Assert (eq 1 (re-search-backward "ä\\|a" nil t))) (goto-char (point-max)) - (Assert-eq 2 (re-search-backward "Ä\\|a" nil t)) + (Assert (eq 2 (re-search-backward "Ä\\|a" nil t))) (goto-char (1- (point-max))) - (Assert-eq 1 (re-search-backward "ä\\|a" nil t)) + (Assert (eq 1 (re-search-backward "ä\\|a" nil t))) (goto-char (1- (point-max))) (Assert (not (re-search-backward "Ä\\|a" nil t)))) @@ -217,25 +218,25 @@ (forward-line 1) (Assert (not (looking-at "^[a]\\{3,5\\}$"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "a\\{4,4\\}")) + (Assert (= 12 (re-search-forward "a\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "b?a\\{4,4\\}")) + (Assert (= 12 (re-search-forward "b?a\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 31 (re-search-forward "ba\\{4,4\\}")) + (Assert (= 31 (re-search-forward "ba\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 31 (re-search-forward "[b]a\\{4,4\\}")) + (Assert (= 31 (re-search-forward "[b]a\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 31 (re-search-forward "\\(b\\)a\\{4,4\\}")) + (Assert (= 31 (re-search-forward "\\(b\\)a\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "^a\\{4,4\\}")) + (Assert (= 12 (re-search-forward "^a\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "^a\\{4,4\\}$")) + (Assert (= 12 (re-search-forward "^a\\{4,4\\}$"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "[a]\\{4,4\\}")) + (Assert (= 12 (re-search-forward "[a]\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "^[a]\\{4,4\\}")) + (Assert (= 12 (re-search-forward "^[a]\\{4,4\\}"))) (goto-char (point-min)) - (Assert= 12 (re-search-forward "^[a]\\{4,4\\}$")) + (Assert (= 12 (re-search-forward "^[a]\\{4,4\\}$"))) ) ;; charset, charset_not @@ -315,15 +316,15 @@ (Assert (string= (match-string 1) nil))) ;; Test word boundaries -(Assert= (string-match "\\<a" " a") 1) -(Assert= (string-match "a\\>" "a ") 0) -(Assert= (string-match "\\ba" " a") 1) -(Assert= (string-match "a\\b" "a ") 0) +(Assert (= (string-match "\\<a" " a") 1)) +(Assert (= (string-match "a\\>" "a ") 0)) +(Assert (= (string-match "\\ba" " a") 1)) +(Assert (= (string-match "a\\b" "a ") 0)) ;; should work at target boundaries -(Assert= (string-match "\\<a" "a") 0) -(Assert= (string-match "a\\>" "a") 0) -(Assert= (string-match "\\ba" "a") 0) -(Assert= (string-match "a\\b" "a") 0) +(Assert (= (string-match "\\<a" "a") 0)) +(Assert (= (string-match "a\\>" "a") 0)) +(Assert (= (string-match "\\ba" "a") 0)) +(Assert (= (string-match "a\\b" "a") 0)) ;; Check for weirdness (Assert (not (string-match " \\> " " "))) (Assert (not (string-match " \\< " " "))) @@ -351,17 +352,17 @@ (ch1 (make-char 'japanese-jisx0208 51 65))) (Assert (not (string-match "A" (string ch0)))) (Assert (not (string-match "[A]" (string ch0)))) - (Assert-eq (string-match "[^A]" (string ch0)) 0) + (Assert (eq (string-match "[^A]" (string ch0)) 0)) (Assert (not (string-match "@A" (string ?@ ch0)))) (Assert (not (string-match "@[A]" (string ?@ ch0)))) - (Assert-eq (string-match "@[^A]" (string ?@ ch0)) 0) + (Assert (eq (string-match "@[^A]" (string ?@ ch0)) 0)) (Assert (not (string-match "@?A" (string ?@ ch0)))) (Assert (not (string-match "A" (string ch1)))) (Assert (not (string-match "[A]" (string ch1)))) - (Assert-eq (string-match "[^A]" (string ch1)) 0) + (Assert (eq (string-match "[^A]" (string ch1)) 0)) (Assert (not (string-match "@A" (string ?@ ch1)))) (Assert (not (string-match "@[A]" (string ?@ ch1)))) - (Assert-eq (string-match "@[^A]" (string ?@ ch1)) 0) + (Assert (eq (string-match "@[^A]" (string ?@ ch1)) 0)) (Assert (not (string-match "@?A" (string ?@ ch1)))) ) ) @@ -408,24 +409,24 @@ ;; fix submitted by sjt 2004-09-08 ;; trailing comments are values from buggy 21.4.15 (let ((text "abc")) - (Assert-eq 0 (string-match "\\(?:ab+\\)*c" text)) ; 2 - (Assert-eq 0 (string-match "^\\(?:ab+\\)*c" text)) ; nil - (Assert-eq 0 (string-match "^\\(?:ab+\\)*" text)) ; 0 - (Assert-eq 0 (string-match "^\\(?:ab+\\)c" text)) ; 0 - (Assert-eq 0 (string-match "^\\(?:ab\\)*c" text)) ; 0 - (Assert-eq 0 (string-match "^\\(?:a+\\)*b" text)) ; nil - (Assert-eq 0 (string-match "^\\(?:a\\)*b" text)) ; 0 + (Assert (eq 0 (string-match "\\(?:ab+\\)*c" text))) ; 2 + (Assert (eq 0 (string-match "^\\(?:ab+\\)*c" text))) ; nil + (Assert (eq 0 (string-match "^\\(?:ab+\\)*" text))) ; 0 + (Assert (eq 0 (string-match "^\\(?:ab+\\)c" text))) ; 0 + (Assert (eq 0 (string-match "^\\(?:ab\\)*c" text))) ; 0 + (Assert (eq 0 (string-match "^\\(?:a+\\)*b" text))) ; nil + (Assert (eq 0 (string-match "^\\(?:a\\)*b" text))) ; 0 ) ;; per Steve Youngs 2004-09-30 <microsoft-free.87ekkjhj7t.fsf@youngs.au.com> ;; fix submitted by sjt 2004-10-07 ;; trailing comments are values from buggy 21.4.pre16 (let ((text "abc")) - (Assert-eq 0 (string-match "\\(?:a\\(b\\)\\)" text)) ; 0 + (Assert (eq 0 (string-match "\\(?:a\\(b\\)\\)" text))) ; 0 (Assert (string= (match-string 1 text) "b")) ; ab (Assert (null (match-string 2 text))) ; b (Assert (null (match-string 3 text))) ; nil - (Assert-eq 0 (string-match "\\(?:a\\(?:b\\(c\\)\\)\\)" text)) ; 0 + (Assert (eq 0 (string-match "\\(?:a\\(?:b\\(c\\)\\)\\)" text))) ; 0 (Assert (string= (match-string 1 text) "c")) ; abc (Assert (null (match-string 2 text))) ; ab (Assert (null (match-string 3 text))) ; c @@ -440,7 +441,7 @@ (re2 "\\(?:a\\)\\(b\\)\\1") (re3 "\\(a\\)\\(?:b\\)\\1")) - (Assert-eq 0 (string-match re0 text1)) + (Assert (eq 0 (string-match re0 text1))) (Assert (string= text1 (match-string 0 text1))) (Assert (string= "a" (match-string 1 text1))) (Assert (string= "b" (match-string 2 text1))) @@ -449,14 +450,14 @@ (Check-Error-Message 'invalid-regexp "Invalid back reference" (string-match re1 text1)) - (Assert-eq 0 (string-match re2 text1)) + (Assert (eq 0 (string-match re2 text1))) (Assert (string= text1 (match-string 0 text1))) (Assert (string= "b" (match-string 1 text1))) (Assert (null (match-string 2 text1))) (Assert (null (string-match re2 text2))) (Assert (null (string-match re3 text1))) - (Assert-eq 0 (string-match re3 text2)) + (Assert (eq 0 (string-match re3 text2))) (Assert (string= text2 (match-string 0 text2))) (Assert (string= "a" (match-string 1 text2))) (Assert (null (match-string 2 text2))) @@ -531,14 +532,14 @@ "-]-----------------------------][]]------------------------" (goto-char (point-min)) (skip-chars-forward (skip-chars-quote "-[]")) - (Assert= (point) (point-max)) + (Assert (= (point) (point-max))) (skip-chars-backward (skip-chars-quote "-[]")) - (Assert= (point) (point-min)) + (Assert (= (point) (point-min))) ;; Testing in passing for an old bug in #'skip-chars-forward where I ;; thought it was impossible to call it with a string containing only ?- ;; and ?]: - (Assert= (skip-chars-forward (skip-chars-quote "-]")) - (position ?[ (buffer-string) :test #'=)) + (Assert (= (skip-chars-forward (skip-chars-quote "-]")) + (position ?[ (buffer-string) :test #'=))) ;; This used to error, incorrectly: (Assert (skip-chars-quote "[-"))) @@ -554,16 +555,16 @@ (with-string-as-buffer-contents "aáa" (goto-char (point-min)) (Assert (looking-at "\\=")) - (Assert= (re-search-forward "\\=") 1) + (Assert (= (re-search-forward "\\=") 1)) (forward-char 1) (Assert (looking-at "\\=")) - (Assert= (re-search-forward "\\=") 2) + (Assert (= (re-search-forward "\\=") 2)) (forward-char 1) (Assert (looking-at "\\=")) - (Assert= (re-search-forward "\\=") 3) + (Assert (= (re-search-forward "\\=") 3)) (forward-char 1) (Assert (looking-at "\\=")) - (Assert= (re-search-forward "\\=") 4)) + (Assert (= (re-search-forward "\\=") 4))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -584,16 +585,16 @@ ;; Control-1 characters were second-class citizens in regexp ranges ;; for a while there. Addressed in Ben's Mercurial changeset ;; 2e15c29cc2b3; attempt to ensure this doesn't happen again. -(Assert-eql (string-match "[\x00-\x7f\x80-\x9f]" "a") 0) -(Assert-eql (string-match "[\x00-\x7f\x80-\x9f]" "é") nil) +(Assert (eql (string-match "[\x00-\x7f\x80-\x9f]" "a") 0)) +(Assert (eql (string-match "[\x00-\x7f\x80-\x9f]" "é") nil)) ;; Gave nil in 21.5 for a couple of years. -(Assert-eql (string-match "[\x00-\x7f\x80-\x9f]" "\x80") 0) -(Assert-eql (string-match "[\x00-\x7f]\\|[\x80-\x9f]" "\x80") 0) +(Assert (eql (string-match "[\x00-\x7f\x80-\x9f]" "\x80") 0)) +(Assert (eql (string-match "[\x00-\x7f]\\|[\x80-\x9f]" "\x80") 0)) ;; Gave nil -(Assert-eql (string-match "[\x7f\x80-\x9f]" "\x80") 0) -(Assert-eql (string-match "[\x80-\x9f]" "\x80") 0) -(Assert-eql (string-match "[\x7f\x80-\x9e]" "\x80") 0) +(Assert (eql (string-match "[\x7f\x80-\x9f]" "\x80") 0)) +(Assert (eql (string-match "[\x80-\x9f]" "\x80") 0)) +(Assert (eql (string-match "[\x7f\x80-\x9e]" "\x80") 0)) ;; Used to succeed even with the bug. -(Assert-eql (string-match "[\x7f\x80\x9f]" "\x80") 0) -(Assert-eql (string-match "[\x7e\x80-\x9f]" "\x80") 0) -(Assert-eql (string-match "[\x7f\x81-\x9f]" "\x81") 0) +(Assert (eql (string-match "[\x7f\x80\x9f]" "\x80") 0)) +(Assert (eql (string-match "[\x7e\x80-\x9f]" "\x80") 0)) +(Assert (eql (string-match "[\x7f\x81-\x9f]" "\x81") 0))
--- a/tests/automated/region-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/region-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -71,7 +71,7 @@ ;; Region not active in this second temp buffer (Assert (not (region-active-p))) ;; Region still active in first temp buffer - (Assert-eq (zmacs-region-buffer) first-buffer) + (Assert (eq (zmacs-region-buffer) first-buffer)) ;; Activate region in second temp buffer (Silence-Message (mark-whole-buffer))
--- a/tests/automated/search-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/search-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -45,11 +45,11 @@ (insert "Test Buffer") (let ((case-fold-search t)) (goto-char (point-min)) - (Assert-eq (search-forward "test buffer" nil t) 12) + (Assert (eq (search-forward "test buffer" nil t) 12)) (goto-char (point-min)) - (Assert-eq (search-forward "Test buffer" nil t) 12) + (Assert (eq (search-forward "Test buffer" nil t) 12)) (goto-char (point-min)) - (Assert-eq (search-forward "Test Buffer" nil t) 12) + (Assert (eq (search-forward "Test Buffer" nil t) 12)) (setq case-fold-search nil) (goto-char (point-min)) @@ -57,51 +57,51 @@ (goto-char (point-min)) (Assert (not (search-forward "Test buffer" nil t))) (goto-char (point-min)) - (Assert-eq (search-forward "Test Buffer" nil t) 12))) + (Assert (eq (search-forward "Test Buffer" nil t) 12)))) (with-temp-buffer (insert "abcdefghijklmnäopqrstuÄvwxyz") ;; case insensitive (Assert (not (search-forward "ö" nil t))) (goto-char (point-min)) - (Assert-eq 16 (search-forward "ä" nil t)) - (Assert-eq 24 (search-forward "ä" nil t)) + (Assert (eq 16 (search-forward "ä" nil t))) + (Assert (eq 24 (search-forward "ä" nil t))) (goto-char (point-min)) - (Assert-eq 16 (search-forward "Ä" nil t)) - (Assert-eq 24 (search-forward "Ä" nil t)) + (Assert (eq 16 (search-forward "Ä" nil t))) + (Assert (eq 24 (search-forward "Ä" nil t))) (goto-char (point-max)) - (Assert-eq 23 (search-backward "ä" nil t)) - (Assert-eq 15 (search-backward "ä" nil t)) + (Assert (eq 23 (search-backward "ä" nil t))) + (Assert (eq 15 (search-backward "ä" nil t))) (goto-char (point-max)) - (Assert-eq 23 (search-backward "Ä" nil t)) - (Assert-eq 15 (search-backward "Ä" nil t)) + (Assert (eq 23 (search-backward "Ä" nil t))) + (Assert (eq 15 (search-backward "Ä" nil t))) ;; case sensitive (setq case-fold-search nil) (goto-char (point-min)) (Assert (not (search-forward "ö" nil t))) (goto-char (point-min)) - (Assert-eq 16 (search-forward "ä" nil t)) + (Assert (eq 16 (search-forward "ä" nil t))) (Assert (not (search-forward "ä" nil t))) (goto-char (point-min)) - (Assert-eq 24 (search-forward "Ä" nil t)) + (Assert (eq 24 (search-forward "Ä" nil t))) (goto-char 16) - (Assert-eq 24 (search-forward "Ä" nil t)) + (Assert (eq 24 (search-forward "Ä" nil t))) (goto-char (point-max)) - (Assert-eq 15 (search-backward "ä" nil t)) + (Assert (eq 15 (search-backward "ä" nil t))) (goto-char 15) (Assert (not (search-backward "ä" nil t))) (goto-char (point-max)) - (Assert-eq 23 (search-backward "Ä" nil t)) + (Assert (eq 23 (search-backward "Ä" nil t))) (Assert (not (search-backward "Ä" nil t)))) (with-temp-buffer (insert "aaaaäÄäÄäÄäÄäÄbbbb") (goto-char (point-min)) - (Assert-eq 15 (search-forward "ää" nil t 5)) + (Assert (eq 15 (search-forward "ää" nil t 5))) (goto-char (point-min)) (Assert (not (search-forward "ää" nil t 6))) (goto-char (point-max)) - (Assert-eq 5 (search-backward "ää" nil t 5)) + (Assert (eq 5 (search-backward "ää" nil t 5))) (goto-char (point-max)) (Assert (not (search-backward "ää" nil t 6)))) @@ -120,26 +120,26 @@ (goto-char (point-min)) (Assert (not (search-forward "ö" nil t))) (goto-char (point-min)) - (Assert-eq 2 (search-forward str-hiragana-a nil t)) + (Assert (eq 2 (search-forward str-hiragana-a nil t))) (goto-char (point-min)) - (Assert-eq 2 (search-forward str-a-diaeresis nil t)) + (Assert (eq 2 (search-forward str-a-diaeresis nil t))) (goto-char (1+ (point-min))) - (Assert-eq (point-max) - (search-forward str-hiragana-a nil t)) + (Assert (eq (point-max) + (search-forward str-hiragana-a nil t))) (goto-char (1+ (point-min))) - (Assert-eq (point-max) - (search-forward str-a-diaeresis nil t)) + (Assert (eq (point-max) + (search-forward str-a-diaeresis nil t))) ;; backward (goto-char (point-max)) (Assert (not (search-backward "ö" nil t))) (goto-char (point-max)) - (Assert-eq (1- (point-max)) (search-backward str-hiragana-a nil t)) + (Assert (eq (1- (point-max)) (search-backward str-hiragana-a nil t))) (goto-char (point-max)) - (Assert-eq (1- (point-max)) (search-backward str-a-diaeresis nil t)) + (Assert (eq (1- (point-max)) (search-backward str-a-diaeresis nil t))) (goto-char (1- (point-max))) - (Assert-eq 1 (search-backward str-hiragana-a nil t)) + (Assert (eq 1 (search-backward str-hiragana-a nil t))) (goto-char (1- (point-max))) - (Assert-eq 1 (search-backward str-a-diaeresis nil t)) + (Assert (eq 1 (search-backward str-a-diaeresis nil t))) (replace-match "a") (Assert (looking-at (format "abcdefg%c" a-diaeresis)))) (with-temp-buffer @@ -150,11 +150,11 @@ (insert string) (insert string) (goto-char (point-min)) - (Assert-eq 11 (search-forward string nil t 5)) + (Assert (eq 11 (search-forward string nil t 5))) (goto-char (point-min)) (Assert (not (search-forward string nil t 6))) (goto-char (point-max)) - (Assert-eq 1 (search-backward string nil t 5)) + (Assert (eq 1 (search-backward string nil t 5))) (goto-char (point-max)) (Assert (not (search-backward string nil t 6)))))) @@ -177,7 +177,7 @@ ;; But searches for ASCII strings in buffers with nothing above ?\xFF ;; use Boyer Moore with the current implementation, which is the ;; important thing for the Gnus use case. - (Assert= (1+ (length target)) (search-forward target nil t)))) + (Assert (= (1+ (length target)) (search-forward target nil t))))) (Skip-Test-Unless (boundp 'debug-searches) ; normal when we have DEBUG_XEMACS @@ -193,7 +193,7 @@ (insert "\n\nDer ber\xfchmte deutsche Flei\xdf\n\n") (goto-char (point-min)) (Assert (search-forward "Flei\xdf")) - (Assert-eq 'boyer-moore search-algorithm-used) + (Assert (eq 'boyer-moore search-algorithm-used)) (delete-region (point-min) (point-max)) (when (featurep 'mule) (insert "\n\nDer ber\xfchmte deutsche Flei\xdf\n\n") @@ -201,15 +201,15 @@ (Assert (search-forward (format "Fle%c\xdf" (make-char 'latin-iso8859-9 #xfd)))) - (Assert-eq 'boyer-moore search-algorithm-used) + (Assert (eq 'boyer-moore search-algorithm-used)) (insert (make-char 'latin-iso8859-9 #xfd)) (goto-char (point-min)) (Assert (search-forward "Flei\xdf")) - (Assert-eq 'simple-search search-algorithm-used) + (Assert (eq 'simple-search search-algorithm-used)) (goto-char (point-min)) (Assert (search-forward (format "Fle%c\xdf" (make-char 'latin-iso8859-9 #xfd)))) - (Assert-eq 'simple-search search-algorithm-used) + (Assert (eq 'simple-search search-algorithm-used)) (setq newcase (copy-case-table (standard-case-table))) (put-case-table-pair (make-char 'ethiopic #x23 #x23) (make-char 'ethiopic #x23 #x25) @@ -225,21 +225,21 @@ (insert (make-char 'ethiopic #x23 #x23)) (insert ?1) (goto-char (point-min)) - (Assert-eql (search-forward + (Assert (eql (search-forward (string (make-char 'ethiopic #x23 #x25)) nil t) - 3) - (Assert-eq 'simple-search search-algorithm-used) + 3)) + (Assert (eq 'simple-search search-algorithm-used)) (goto-char (point-min)) - (Assert-eql (search-forward + (Assert (eql (search-forward (string (make-char 'ethiopic #x23 #x27)) nil t) - nil) - (Assert-eq 'boyer-moore search-algorithm-used)))))) + nil)) + (Assert (eq 'boyer-moore search-algorithm-used))))))) ;; XEmacs bug of long standing. (with-temp-buffer (insert "foo\201bar") (goto-char (point-min)) - (Assert-eq (search-forward "\201" nil t) 5)) + (Assert (eq (search-forward "\201" nil t) 5)))
--- a/tests/automated/symbol-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/symbol-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -63,8 +63,8 @@ (uninterned (make-symbol name))) (Assert (symbolp interned)) (Assert (symbolp uninterned)) - (Assert-equal (symbol-name interned) name) - (Assert-equal (symbol-name uninterned) name) + (Assert (equal (symbol-name interned) name)) + (Assert (equal (symbol-name uninterned) name)) (Assert (not (eq interned uninterned))) (Assert (not (equal interned uninterned))))) @@ -76,12 +76,12 @@ (Implementation-Incomplete-Expect-Failure (Assert (not (zerop len))) (garbage-collect) - (Assert-eq (length (weak-list-list weak-list)) - (if (not reversep) 0 len))) + (Assert (eq (length (weak-list-list weak-list)) + (if (not reversep) 0 len)))) (Assert (not (zerop len))) (garbage-collect) - (Assert-eq (length (weak-list-list weak-list)) - (if (not reversep) 0 len)))))) + (Assert (eq (length (weak-list-list weak-list)) + (if (not reversep) 0 len))))))) (let ((weak-list (make-weak-list)) (gc-cons-threshold most-positive-fixnum)) ;; Symbols created with `make-symbol' and `gensym' should be fresh @@ -112,7 +112,7 @@ string (read (concat "\"" string "\""))) (Assert (intern-soft string)) (Assert (intern-soft symbol)) - (Assert-eq (intern-soft string) (intern-soft symbol))) + (Assert (eq (intern-soft string) (intern-soft symbol)))) (let ((fresh (read (concat "#:" (ts-fresh-symbol-name "foo"))))) (Assert (not (intern-soft fresh)))) @@ -127,15 +127,15 @@ (bar3 (nth 5 list))) (Assert (symbolp foo)) (Assert (not (intern-soft foo))) - (Assert-equal (symbol-name foo) "foo") + (Assert (equal (symbol-name foo) "foo")) (Assert (symbolp bar)) (Assert (not (intern-soft bar))) - (Assert-equal (symbol-name bar) "bar") + (Assert (equal (symbol-name bar) "bar")) - (Assert-eq foo foo2) - (Assert-eq foo2 foo3) - (Assert-eq bar bar2) - (Assert-eq bar2 bar3)) + (Assert (eq foo foo2)) + (Assert (eq foo2 foo3)) + (Assert (eq bar bar2)) + (Assert (eq bar2 bar3))) ;; Check #N=OBJECT and #N# print syntax. (let* ((foo (make-symbol "foo")) @@ -143,10 +143,10 @@ (list (list foo foo bar bar foo bar))) (let* ((print-gensym nil) (printed-list (prin1-to-string list))) - (Assert-equal printed-list "(foo foo bar bar foo bar)")) + (Assert (equal printed-list "(foo foo bar bar foo bar)"))) (let* ((print-gensym t) (printed-list (prin1-to-string list))) - (Assert-equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)"))) + (Assert (equal printed-list "(#1=#:foo #1# #2=#:bar #2# #1# #2#)")))) ;;----------------------------------------------------- ;; Read-only symbols @@ -164,18 +164,18 @@ (let ((foo 0) (bar 1)) (defvaralias 'foo 'bar) - (Assert-eq foo bar) - (Assert-eq foo 1) - (Assert-eq (variable-alias 'foo) 'bar) + (Assert (eq foo bar)) + (Assert (eq foo 1)) + (Assert (eq (variable-alias 'foo) 'bar)) (defvaralias 'bar 'foo) (Check-Error cyclic-variable-indirection (symbol-value 'foo)) (Check-Error cyclic-variable-indirection (symbol-value 'bar)) (defvaralias 'foo nil) - (Assert-eq foo 0) + (Assert (eq foo 0)) (defvaralias 'bar nil) - (Assert-eq bar 1)) + (Assert (eq bar 1))) ;;----------------------------------------------------- ;; Keywords @@ -187,10 +187,10 @@ ;; that is interned in the global obarray. ;; In Elisp, a keyword is interned as any other symbol. -(Assert-eq (read ":foo") (intern ":foo")) +(Assert (eq (read ":foo") (intern ":foo"))) ;; A keyword is self-quoting and evaluates to itself. -(Assert-eq (eval (intern ":foo")) :foo) +(Assert (eq (eval (intern ":foo")) :foo)) ;; Keywords are recognized as such only if interned in the global ;; obarray, and `keywordp' is aware of that. @@ -208,14 +208,14 @@ ;; keyword. (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo")) (fresh-keyword (intern fresh-keyword-name))) - (Assert-eq (symbol-value fresh-keyword) fresh-keyword) + (Assert (eq (symbol-value fresh-keyword) fresh-keyword)) (Assert (keywordp fresh-keyword))) ;; Likewise, reading a fresh keyword string should produce a regular ;; keyword. (let* ((fresh-keyword-name (ts-fresh-symbol-name ":foo")) (fresh-keyword (read fresh-keyword-name))) - (Assert-eq (symbol-value fresh-keyword) fresh-keyword) + (Assert (eq (symbol-value fresh-keyword) fresh-keyword)) (Assert (keywordp fresh-keyword))) ;;; Assigning to keywords @@ -236,19 +236,19 @@ ;; But symbols not interned in the global obarray are not real ;; keywords (in elisp): -(Assert-eq (set (intern ":foo" [0]) 5) 5) +(Assert (eq (set (intern ":foo" [0]) 5) 5)) ;;; Printing keywords (let ((print-gensym t)) - (Assert-equal (prin1-to-string :foo) ":foo") - (Assert-equal (prin1-to-string (intern ":foo")) ":foo") - (Assert-equal (prin1-to-string (intern ":foo" [0])) "#::foo")) + (Assert (equal (prin1-to-string :foo) ":foo")) + (Assert (equal (prin1-to-string (intern ":foo")) ":foo")) + (Assert (equal (prin1-to-string (intern ":foo" [0])) "#::foo"))) (let ((print-gensym nil)) - (Assert-equal (prin1-to-string :foo) ":foo") - (Assert-equal (prin1-to-string (intern ":foo")) ":foo") - (Assert-equal (prin1-to-string (intern ":foo" [0])) ":foo")) + (Assert (equal (prin1-to-string :foo) ":foo")) + (Assert (equal (prin1-to-string (intern ":foo")) ":foo")) + (Assert (equal (prin1-to-string (intern ":foo" [0])) ":foo"))) ;; #### Add many more tests for printing and reading symbols, as well ;; as print-gensym and print-gensym-alist! @@ -270,17 +270,17 @@ (lambda (&rest args) (throw 'test-tag args))) (Assert (not (boundp mysym))) - (Assert-equal (catch 'test-tag + (Assert (equal (catch 'test-tag (set mysym 'foo)) - `(,mysym (foo) set nil nil)) + `(,mysym (foo) set nil nil))) (Assert (not (boundp mysym))) (dontusethis-set-symbol-value-handler mysym 'set-value (lambda (&rest args) (setq save (nth 1 args)))) (set mysym 'foo) - (Assert-equal save '(foo)) - (Assert-eq (symbol-value mysym) 'foo) + (Assert (equal save '(foo))) + (Assert (eq (symbol-value mysym) 'foo)) ) (let ((mysym (make-symbol "test-symbol")) @@ -290,9 +290,9 @@ 'make-unbound (lambda (&rest args) (throw 'test-tag args))) - (Assert-equal (catch 'test-tag + (Assert (equal (catch 'test-tag (makunbound mysym)) - `(,mysym nil makunbound nil nil)) + `(,mysym nil makunbound nil nil))) (dontusethis-set-symbol-value-handler mysym 'make-unbound @@ -300,27 +300,27 @@ (Assert (not (boundp mysym))) (set mysym 'bar) (Assert (null save)) - (Assert-eq (symbol-value mysym) 'bar) + (Assert (eq (symbol-value mysym) 'bar)) (makunbound mysym) (Assert (not (boundp mysym))) - (Assert-eq save 'makunbound) + (Assert (eq save 'makunbound)) ) ;; pathname-coding-system is no more. ; (when (featurep 'file-coding) -; (Assert-eq pathname-coding-system file-name-coding-system) +; (Assert (eq pathname-coding-system file-name-coding-system)) ; (let ((val1 file-name-coding-system) ; (val2 pathname-coding-system)) -; (Assert-eq val1 val2) +; (Assert (eq val1 val2)) ; (let ((file-name-coding-system 'no-conversion-dos)) -; (Assert-eq file-name-coding-system 'no-conversion-dos) -; (Assert-eq pathname-coding-system file-name-coding-system)) +; (Assert (eq file-name-coding-system 'no-conversion-dos)) +; (Assert (eq pathname-coding-system file-name-coding-system))) ; (let ((pathname-coding-system 'no-conversion-mac)) -; (Assert-eq file-name-coding-system 'no-conversion-mac) -; (Assert-eq pathname-coding-system file-name-coding-system)) -; (Assert-eq file-name-coding-system pathname-coding-system) -; (Assert-eq val1 file-name-coding-system)) -; (Assert-eq pathname-coding-system file-name-coding-system)) +; (Assert (eq file-name-coding-system 'no-conversion-mac)) +; (Assert (eq pathname-coding-system file-name-coding-system))) +; (Assert (eq file-name-coding-system pathname-coding-system)) +; (Assert (eq val1 file-name-coding-system))) +; (Assert (eq pathname-coding-system file-name-coding-system))) ;(let ((mysym (make-symbol "test-symbol")))
--- a/tests/automated/syntax-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/syntax-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -49,7 +49,7 @@ (insert string) (goto-char point) (forward-word 1) - (Assert-eq (point) (+ point stop)))) + (Assert (eq (point) (+ point stop))))) (with-temp-buffer ;; -!- W NW @@ -77,7 +77,7 @@ (insert string) (let ((point (point))) (backward-word 1) - (Assert-eq (point) (- point stop)))) + (Assert (eq (point) (- point stop))))) (with-temp-buffer ;; NW W -!- @@ -120,7 +120,7 @@ 'syntax-table apply-syntax) (goto-char point) (forward-word 1) - (Assert-eq (point) (+ point stop))))) + (Assert (eq (point) (+ point stop)))))) ;; test syntax-table extents (with-temp-buffer @@ -143,7 +143,7 @@ (with-syntax-table (make-syntax-table) (insert "foo bar") (backward-sexp 1) - (Assert-eql (point) 5))) + (Assert (eql (point) 5)))) ;; Test forward-comment at buffer boundaries ;; #### The second Assert fails (once interpreted, once compiled) on 21.4.9 @@ -156,13 +156,13 @@ (insert "// comment\n") (forward-comment -2) - (Assert-eq (point) (point-min)) + (Assert (eq (point) (point-min))) (let ((point (point))) (insert "/* comment */") (goto-char point) (forward-comment 2) - (Assert-eq (point) (point-max)) + (Assert (eq (point) (point-max))) ;; this last used to crash (parse-partial-sexp point (point-max))))) @@ -204,7 +204,7 @@ "Unbalanced parentheses" (backward-up-list-moves-point-from-to 25 nil)) ;; special-case check that point didn't move - (Assert= (point) 25))) + (Assert (= (point) 25)))) (loop with envvar-not-existing = (symbol-name (gensym "whatever"))
--- a/tests/automated/tag-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/tag-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -70,7 +70,7 @@ ;; Search for the tag "mystruct"; this should succeed (Silence-Message (find-tag "mystruct")) - (Assert-eq (point) 2) + (Assert (eq (point) 2)) ;; Search again. The search should fail, based on the patch that ;; Sven Grundmann submitted for 21.4.16. @@ -86,7 +86,7 @@ (Silence-Message (find-tag "require")) (t t)) - (Assert-eq (point) 52)) + (Assert (eq (point) 52))) (kill-buffer testfile) (delete-file testfile)
--- a/tests/automated/weak-tests.el Tue Feb 23 07:28:35 2010 -0600 +++ b/tests/automated/weak-tests.el Mon Mar 29 21:28:13 2010 -0500 @@ -40,7 +40,7 @@ ;; tests for weak-boxes (let ((w (make-weak-box (cons 2 3)))) - (Assert-equal (cons 2 3) (weak-box-ref w)) + (Assert (equal (cons 2 3) (weak-box-ref w))) (garbage-collect) (Assert (not (weak-box-ref w)))) @@ -53,7 +53,7 @@ #'(lambda (value) (setq finalized-p t)))) (eph2 (make-ephemeron p p))) - (Assert-eq p (ephemeron-ref (make-ephemeron (cons 1 2) p))) + (Assert (eq p (ephemeron-ref (make-ephemeron (cons 1 2) p)))) (Assert (ephemeron-p (make-ephemeron (cons 1 2) p))) (garbage-collect) @@ -64,7 +64,7 @@ (garbage-collect) - (Assert-eq p (ephemeron-ref eph2))) + (Assert (eq p (ephemeron-ref eph2)))) (garbage-collect) @@ -81,20 +81,20 @@ (set-weak-list-list weaklist3 (list a (cons 1 2) b)) (set-weak-list-list weaklist4 (list a b (cons 1 2))) (Assert (weak-list-p weaklist1)) - (Assert-eq (weak-list-type weaklist1) 'simple) + (Assert (eq (weak-list-type weaklist1) 'simple)) (Assert (weak-list-p weaklist2)) - (Assert-eq (weak-list-type weaklist2) 'simple) + (Assert (eq (weak-list-type weaklist2) 'simple)) (Assert (weak-list-p weaklist3)) - (Assert-eq (weak-list-type weaklist3) 'simple) + (Assert (eq (weak-list-type weaklist3) 'simple)) (Assert (weak-list-p weaklist4)) - (Assert-eq (weak-list-type weaklist4) 'simple) + (Assert (eq (weak-list-type weaklist4) 'simple)) (garbage-collect) - (Assert-eq (weak-list-list weaklist1) testlist) - (Assert-equal (weak-list-list weaklist2) testlist) - (Assert-equal (weak-list-list weaklist3) testlist) - (Assert-equal (weak-list-list weaklist4) testlist)) + (Assert (eq (weak-list-list weaklist1) testlist)) + (Assert (equal (weak-list-list weaklist2) testlist)) + (Assert (equal (weak-list-list weaklist3) testlist)) + (Assert (equal (weak-list-list weaklist4) testlist))) (garbage-collect) @@ -111,20 +111,20 @@ (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b)) (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b)) (Assert (weak-list-p weaklist1)) - (Assert-eq (weak-list-type weaklist1) 'assoc) + (Assert (eq (weak-list-type weaklist1) 'assoc)) (Assert (weak-list-p weaklist2)) - (Assert-eq (weak-list-type weaklist2) 'assoc) + (Assert (eq (weak-list-type weaklist2) 'assoc)) (Assert (weak-list-p weaklist3)) - (Assert-eq (weak-list-type weaklist3) 'assoc) + (Assert (eq (weak-list-type weaklist3) 'assoc)) (Assert (weak-list-p weaklist4)) - (Assert-eq (weak-list-type weaklist4) 'assoc) + (Assert (eq (weak-list-type weaklist4) 'assoc)) (garbage-collect) - (Assert-eq (weak-list-list weaklist1) testlist) - (Assert-equal (weak-list-list weaklist2) testlist) - (Assert-equal (weak-list-list weaklist3) testlist) - (Assert-equal (weak-list-list weaklist4) testlist)) + (Assert (eq (weak-list-list weaklist1) testlist)) + (Assert (equal (weak-list-list weaklist2) testlist)) + (Assert (equal (weak-list-list weaklist3) testlist)) + (Assert (equal (weak-list-list weaklist4) testlist))) (garbage-collect) @@ -141,20 +141,20 @@ (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b)) (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b)) (Assert (weak-list-p weaklist1)) - (Assert-eq (weak-list-type weaklist1) 'key-assoc) + (Assert (eq (weak-list-type weaklist1) 'key-assoc)) (Assert (weak-list-p weaklist2)) - (Assert-eq (weak-list-type weaklist2) 'key-assoc) + (Assert (eq (weak-list-type weaklist2) 'key-assoc)) (Assert (weak-list-p weaklist3)) - (Assert-eq (weak-list-type weaklist3) 'key-assoc) + (Assert (eq (weak-list-type weaklist3) 'key-assoc)) (Assert (weak-list-p weaklist4)) - (Assert-eq (weak-list-type weaklist4) 'key-assoc) + (Assert (eq (weak-list-type weaklist4) 'key-assoc)) (garbage-collect) - (Assert-eq (weak-list-list weaklist1) testlist) - (Assert-equal (weak-list-list weaklist2) testlist) - (Assert-equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b)) - (Assert-equal (weak-list-list weaklist4) testlist)) + (Assert (eq (weak-list-list weaklist1) testlist)) + (Assert (equal (weak-list-list weaklist2) testlist)) + (Assert (equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b))) + (Assert (equal (weak-list-list weaklist4) testlist))) (garbage-collect) @@ -171,20 +171,20 @@ (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b)) (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b)) (Assert (weak-list-p weaklist1)) - (Assert-eq (weak-list-type weaklist1) 'value-assoc) + (Assert (eq (weak-list-type weaklist1) 'value-assoc)) (Assert (weak-list-p weaklist2)) - (Assert-eq (weak-list-type weaklist2) 'value-assoc) + (Assert (eq (weak-list-type weaklist2) 'value-assoc)) (Assert (weak-list-p weaklist3)) - (Assert-eq (weak-list-type weaklist3) 'value-assoc) + (Assert (eq (weak-list-type weaklist3) 'value-assoc)) (Assert (weak-list-p weaklist4)) - (Assert-eq (weak-list-type weaklist4) 'value-assoc) + (Assert (eq (weak-list-type weaklist4) 'value-assoc)) (garbage-collect) - (Assert-eq (weak-list-list weaklist1) testlist) - (Assert-equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b)) - (Assert-equal (weak-list-list weaklist3) testlist) - (Assert-equal (weak-list-list weaklist4) testlist)) + (Assert (eq (weak-list-list weaklist1) testlist)) + (Assert (equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b))) + (Assert (equal (weak-list-list weaklist3) testlist)) + (Assert (equal (weak-list-list weaklist4) testlist))) (garbage-collect) @@ -201,20 +201,20 @@ (set-weak-list-list weaklist3 (list b (cons a (cons 1 2)) b)) (set-weak-list-list weaklist4 (list b (cons (cons 1 2) (cons 3 4)) b)) (Assert (weak-list-p weaklist1)) - (Assert-eq (weak-list-type weaklist1) 'full-assoc) + (Assert (eq (weak-list-type weaklist1) 'full-assoc)) (Assert (weak-list-p weaklist2)) - (Assert-eq (weak-list-type weaklist2) 'full-assoc) + (Assert (eq (weak-list-type weaklist2) 'full-assoc)) (Assert (weak-list-p weaklist3)) - (Assert-eq (weak-list-type weaklist3) 'full-assoc) + (Assert (eq (weak-list-type weaklist3) 'full-assoc)) (Assert (weak-list-p weaklist4)) - (Assert-eq (weak-list-type weaklist4) 'full-assoc) + (Assert (eq (weak-list-type weaklist4) 'full-assoc)) (garbage-collect) - (Assert-eq (weak-list-list weaklist1) testlist) - (Assert-equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b)) - (Assert-equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b)) - (Assert-equal (weak-list-list weaklist4) testlist)) + (Assert (eq (weak-list-list weaklist1) testlist)) + (Assert (equal (weak-list-list weaklist2) (list b (cons (cons 1 2) a) b))) + (Assert (equal (weak-list-list weaklist3) (list b (cons a (cons 1 2)) b))) + (Assert (equal (weak-list-list weaklist4) testlist))) (garbage-collect)