1 /* XEmacs routines to deal with range tables.
2 Copyright (C) 1995 Sun Microsystems, Inc.
3 Copyright (C) 1995 Ben Wing.
5 This file is part of XEmacs.
7 XEmacs is free software; you can redistribute it and/or modify it
8 under the terms of the GNU General Public License as published by the
9 Free Software Foundation; either version 2, or (at your option) any
12 XEmacs is distributed in the hope that it will be useful, but WITHOUT
13 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
17 You should have received a copy of the GNU General Public License
18 along with XEmacs; see the file COPYING. If not, write to
19 the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
20 Boston, MA 02111-1307, USA. */
22 /* Synched up with: Not in FSF. */
24 /* Written by Ben Wing, August 1995. */
30 Lisp_Object Qrange_tablep;
31 Lisp_Object Qrange_table;
34 /************************************************************************/
35 /* Range table object */
36 /************************************************************************/
38 /* We use a sorted array of ranges.
40 #### We should be using the gap array stuff from extents.c. This
41 is not hard but just requires moving that stuff out of that file. */
44 mark_range_table (Lisp_Object obj, void (*markobj) (Lisp_Object))
46 struct Lisp_Range_Table *rt = XRANGE_TABLE (obj);
49 for (i = 0; i < Dynarr_length (rt->entries); i++)
50 markobj (Dynarr_at (rt->entries, i).val);
55 print_range_table (Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
57 struct Lisp_Range_Table *rt = XRANGE_TABLE (obj);
61 write_c_string ("#s(range-table data (", printcharfun);
62 for (i = 0; i < Dynarr_length (rt->entries); i++)
64 struct range_table_entry *rte = Dynarr_atp (rt->entries, i);
66 write_c_string (" ", printcharfun);
67 if (rte->first == rte->last)
68 sprintf (buf, "%ld ", (long) (rte->first));
70 sprintf (buf, "(%ld %ld) ", (long) (rte->first), (long) (rte->last));
71 write_c_string (buf, printcharfun);
72 print_internal (rte->val, printcharfun, 1);
74 write_c_string ("))", printcharfun);
78 range_table_equal (Lisp_Object obj1, Lisp_Object obj2, int depth)
80 struct Lisp_Range_Table *rt1 = XRANGE_TABLE (obj1);
81 struct Lisp_Range_Table *rt2 = XRANGE_TABLE (obj2);
84 if (Dynarr_length (rt1->entries) != Dynarr_length (rt2->entries))
87 for (i = 0; i < Dynarr_length (rt1->entries); i++)
89 struct range_table_entry *rte1 = Dynarr_atp (rt1->entries, i);
90 struct range_table_entry *rte2 = Dynarr_atp (rt2->entries, i);
92 if (rte1->first != rte2->first
93 || rte1->last != rte2->last
94 || !internal_equal (rte1->val, rte2->val, depth + 1))
102 range_table_entry_hash (struct range_table_entry *rte, int depth)
104 return HASH3 (rte->first, rte->last, internal_hash (rte->val, depth + 1));
108 range_table_hash (Lisp_Object obj, int depth)
110 struct Lisp_Range_Table *rt = XRANGE_TABLE (obj);
112 int size = Dynarr_length (rt->entries);
113 unsigned long hash = size;
115 /* approach based on internal_array_hash(). */
118 for (i = 0; i < size; i++)
120 range_table_entry_hash (Dynarr_atp (rt->entries, i),
125 /* just pick five elements scattered throughout the array.
126 A slightly better approach would be to offset by some
127 noise factor from the points chosen below. */
128 for (i = 0; i < 5; i++)
129 hash = HASH2 (hash, range_table_entry_hash (Dynarr_atp (rt->entries,
135 DEFINE_LRECORD_IMPLEMENTATION ("range-table", range_table,
136 mark_range_table, print_range_table, 0,
137 range_table_equal, range_table_hash,
138 struct Lisp_Range_Table);
140 /************************************************************************/
141 /* Range table operations */
142 /************************************************************************/
144 #ifdef ERROR_CHECK_TYPECHECK
147 verify_range_table (struct Lisp_Range_Table *rt)
151 for (i = 0; i < Dynarr_length (rt->entries); i++)
153 struct range_table_entry *rte = Dynarr_atp (rt->entries, i);
154 assert (rte->last >= rte->first);
156 assert (Dynarr_at (rt->entries, i - 1).last < rte->first);
162 #define verify_range_table(rt)
166 /* Look up in a range table without the Dynarr wrapper.
167 Used also by the unified range table format. */
170 get_range_table (EMACS_INT pos, int nentries, struct range_table_entry *tab,
171 Lisp_Object default_)
173 int left = 0, right = nentries;
175 /* binary search for the entry. Based on similar code in
176 extent_list_locate(). */
177 while (left != right)
179 /* RIGHT might not point to a valid entry (i.e. it's at the end
180 of the list), so NEWPOS must round down. */
181 unsigned int newpos = (left + right) >> 1;
182 struct range_table_entry *entry = tab + newpos;
183 if (pos > entry->last)
185 else if (pos < entry->first)
194 DEFUN ("range-table-p", Frange_table_p, 1, 1, 0, /*
195 Return non-nil if OBJECT is a range table.
199 return RANGE_TABLEP (object) ? Qt : Qnil;
202 DEFUN ("make-range-table", Fmake_range_table, 0, 0, 0, /*
203 Return a new, empty range table.
204 You can manipulate it using `put-range-table', `get-range-table',
205 `remove-range-table', and `clear-range-table'.
210 struct Lisp_Range_Table *rt = alloc_lcrecord_type (struct Lisp_Range_Table,
211 lrecord_range_table);
212 rt->entries = Dynarr_new (range_table_entry);
213 XSETRANGE_TABLE (obj, rt);
217 DEFUN ("copy-range-table", Fcopy_range_table, 1, 1, 0, /*
218 Make a new range table which contains the same values for the same
219 ranges as the given table. The values will not themselves be copied.
223 struct Lisp_Range_Table *rt, *rtnew;
226 CHECK_RANGE_TABLE (old_table);
227 rt = XRANGE_TABLE (old_table);
229 rtnew = alloc_lcrecord_type (struct Lisp_Range_Table, lrecord_range_table);
230 rtnew->entries = Dynarr_new (range_table_entry);
232 Dynarr_add_many (rtnew->entries, Dynarr_atp (rt->entries, 0),
233 Dynarr_length (rt->entries));
234 XSETRANGE_TABLE (obj, rtnew);
238 DEFUN ("get-range-table", Fget_range_table, 2, 3, 0, /*
239 Find value for position POS in TABLE.
240 If there is no corresponding value, return DEFAULT (defaults to nil).
242 (pos, table, default_))
244 struct Lisp_Range_Table *rt;
246 CHECK_RANGE_TABLE (table);
247 rt = XRANGE_TABLE (table);
249 CHECK_INT_COERCE_CHAR (pos);
251 return get_range_table (XINT (pos), Dynarr_length (rt->entries),
252 Dynarr_atp (rt->entries, 0), default_);
256 put_range_table (Lisp_Object table, EMACS_INT first,
257 EMACS_INT last, Lisp_Object val)
260 int insert_me_here = -1;
261 struct Lisp_Range_Table *rt = XRANGE_TABLE (table);
263 /* Now insert in the proper place. This gets tricky because
264 we may be overlapping one or more existing ranges and need
267 /* First delete all sections of any existing ranges that overlap
269 for (i = 0; i < Dynarr_length (rt->entries); i++)
271 struct range_table_entry *entry = Dynarr_atp (rt->entries, i);
272 /* We insert before the first range that begins at or after the
274 if (entry->first >= first && insert_me_here < 0)
276 if (entry->last < first)
277 /* completely before the new range. */
279 if (entry->first > last)
280 /* completely after the new range. No more possibilities of
281 finding overlapping ranges. */
283 if (entry->first < first && entry->last <= last)
291 /* truncate the end off of it. */
292 entry->last = first - 1;
294 else if (entry->first < first && entry->last > last)
301 /* need to split this one in two. */
303 struct range_table_entry insert_me_too;
305 insert_me_too.first = last + 1;
306 insert_me_too.last = entry->last;
307 insert_me_too.val = entry->val;
308 entry->last = first - 1;
309 Dynarr_insert_many (rt->entries, &insert_me_too, 1, i + 1);
311 else if (entry->last > last)
319 /* truncate the start off of it. */
320 entry->first = last + 1;
324 /* existing is entirely within new. */
325 Dynarr_delete_many (rt->entries, i, 1);
326 i--; /* back up since everything shifted one to the left. */
330 /* Someone asked us to delete the range, not insert it. */
334 /* Now insert the new entry, maybe at the end. */
336 if (insert_me_here < 0)
340 struct range_table_entry insert_me;
342 insert_me.first = first;
343 insert_me.last = last;
346 Dynarr_insert_many (rt->entries, &insert_me, 1, insert_me_here);
349 /* Now see if we can combine this entry with adjacent ones just
352 if (insert_me_here > 0)
354 struct range_table_entry *entry = Dynarr_atp (rt->entries,
356 if (EQ (val, entry->val) && entry->last == first - 1)
359 Dynarr_delete_many (rt->entries, insert_me_here, 1);
361 /* We have morphed into a larger range. Update our records
362 in case we also combine with the one after. */
363 first = entry->first;
367 if (insert_me_here < Dynarr_length (rt->entries) - 1)
369 struct range_table_entry *entry = Dynarr_atp (rt->entries,
371 if (EQ (val, entry->val) && entry->first == last + 1)
373 entry->first = first;
374 Dynarr_delete_many (rt->entries, insert_me_here, 1);
379 DEFUN ("put-range-table", Fput_range_table, 4, 4, 0, /*
380 Set the value for range (START, END) to be VAL in TABLE.
382 (start, end, val, table))
384 EMACS_INT first, last;
386 CHECK_RANGE_TABLE (table);
387 CHECK_INT_COERCE_CHAR (start);
388 first = XINT (start);
389 CHECK_INT_COERCE_CHAR (end);
392 signal_simple_error_2 ("start must be <= end", start, end);
394 put_range_table (table, first, last, val);
395 verify_range_table (XRANGE_TABLE (table));
399 DEFUN ("remove-range-table", Fremove_range_table, 3, 3, 0, /*
400 Remove the value for range (START, END) in TABLE.
404 return Fput_range_table (start, end, Qunbound, table);
407 DEFUN ("clear-range-table", Fclear_range_table, 1, 1, 0, /*
412 CHECK_RANGE_TABLE (table);
413 Dynarr_reset (XRANGE_TABLE (table)->entries);
417 DEFUN ("map-range-table", Fmap_range_table, 2, 2, 0, /*
418 Map FUNCTION over entries in TABLE, calling it with three args,
419 the beginning and end of the range and the corresponding value.
423 error ("not yet implemented");
428 /************************************************************************/
429 /* Range table read syntax */
430 /************************************************************************/
433 rangetab_data_validate (Lisp_Object keyword, Lisp_Object value,
438 /* #### should deal with errb */
439 EXTERNAL_LIST_LOOP (rest, value)
441 Lisp_Object range = XCAR (rest);
444 signal_simple_error ("Invalid list format", value);
445 if (!INTP (range) && !CHARP (range)
446 && !(CONSP (range) && CONSP (XCDR (range))
447 && NILP (XCDR (XCDR (range)))
448 && (INTP (XCAR (range)) || CHARP (XCAR (range)))
449 && (INTP (XCAR (XCDR (range))) || CHARP (XCAR (XCDR (range))))))
450 signal_simple_error ("Invalid range format", range);
457 rangetab_instantiate (Lisp_Object data)
459 Lisp_Object rangetab = Fmake_range_table ();
463 data = Fcar (Fcdr (data)); /* skip over 'data keyword */
466 Lisp_Object range = Fcar (data);
467 Lisp_Object val = Fcar (Fcdr (data));
469 data = Fcdr (Fcdr (data));
471 Fput_range_table (Fcar (range), Fcar (Fcdr (range)), val,
474 Fput_range_table (range, range, val, rangetab);
482 /************************************************************************/
483 /* Unified range tables */
484 /************************************************************************/
486 /* A "unified range table" is a format for storing range tables
487 as contiguous blocks of memory. This is used by the regexp
488 code, which needs to use range tables to properly handle []
489 constructs in the presence of extended characters but wants to
490 store an entire compiled pattern as a contiguous block of memory.
492 Unified range tables are designed so that they can be placed
493 at an arbitrary (possibly mis-aligned) place in memory.
494 (Dealing with alignment is a pain in the ass.)
496 WARNING: No provisions for garbage collection are currently made.
497 This means that there must not be any Lisp objects in a unified
498 range table that need to be marked for garbage collection.
499 Good candidates for objects that can go into a range table are
501 -- numbers and characters (do not need to be marked)
502 -- nil, t (marked elsewhere)
503 -- charsets and coding systems (automatically marked because
504 they are in a marked list,
505 and can't be removed)
507 Good but slightly less so:
509 -- symbols (could be uninterned, but that is not likely)
513 -- buffers, frames, devices (could get deleted)
516 It is expected that you work with range tables in the normal
517 format and then convert to unified format when you are done
518 making modifications. As such, no functions are provided
519 for modifying a unified range table. The only operations
520 you can do to unified range tables are
523 -- retrieve all the ranges in an iterative fashion
527 /* The format of a unified range table is as follows:
529 -- The first byte contains the number of bytes to skip to find the
530 actual start of the table. This deals with alignment constraints,
531 since the table might want to go at any arbitrary place in memory.
532 -- The next three bytes contain the number of bytes to skip (from the
533 *first* byte) to find the stuff after the table. It's stored in
534 little-endian format because that's how God intended things. We don't
535 necessarily start the stuff at the very end of the table because
536 we want to have at least ALIGNOF (EMACS_INT) extra space in case
537 we have to move the range table around. (It appears that some
538 architectures don't maintain alignment when reallocing.)
539 -- At the prescribed offset is a struct unified_range_table, containing
540 some number of `struct range_table_entry' entries. */
542 struct unified_range_table
545 struct range_table_entry first;
548 /* Return size in bytes needed to store the data in a range table. */
551 unified_range_table_bytes_needed (Lisp_Object rangetab)
553 return (sizeof (struct range_table_entry) *
554 (Dynarr_length (XRANGE_TABLE (rangetab)->entries) - 1) +
555 sizeof (struct unified_range_table) +
556 /* ALIGNOF a struct may be too big. */
557 /* We have four bytes for the size numbers, and an extra
558 four or eight bytes for making sure we get the alignment
560 ALIGNOF (EMACS_INT) + 4);
563 /* Convert a range table into unified format and store in DEST,
564 which must be able to hold the number of bytes returned by
565 range_table_bytes_needed(). */
568 unified_range_table_copy_data (Lisp_Object rangetab, void *dest)
570 /* We cast to the above structure rather than just casting to
571 char * and adding sizeof(int), because that will lead to
572 mis-aligned data on the Alpha machines. */
573 struct unified_range_table *un;
574 range_table_entry_dynarr *rted = XRANGE_TABLE (rangetab)->entries;
575 int total_needed = unified_range_table_bytes_needed (rangetab);
576 void *new_dest = ALIGN_PTR ((char *) dest + 4, ALIGNOF (EMACS_INT));
578 * (char *) dest = (char) ((char *) new_dest - (char *) dest);
579 * ((unsigned char *) dest + 1) = total_needed & 0xFF;
581 * ((unsigned char *) dest + 2) = total_needed & 0xFF;
583 * ((unsigned char *) dest + 3) = total_needed & 0xFF;
584 un = (struct unified_range_table *) new_dest;
585 un->nentries = Dynarr_length (rted);
586 memcpy (&un->first, Dynarr_atp (rted, 0),
587 sizeof (struct range_table_entry) * Dynarr_length (rted));
590 /* Return number of bytes actually used by a unified range table. */
593 unified_range_table_bytes_used (void *unrangetab)
595 return ((* ((unsigned char *) unrangetab + 1))
596 + ((* ((unsigned char *) unrangetab + 2)) << 8)
597 + ((* ((unsigned char *) unrangetab + 3)) << 16));
600 /* Make sure the table is aligned, and move it around if it's not. */
602 align_the_damn_table (void *unrangetab)
604 void *cur_dest = (char *) unrangetab + * (char *) unrangetab;
606 if ((((long) cur_dest) & 7) != 0)
608 if ((((int) cur_dest) & 3) != 0)
611 int count = (unified_range_table_bytes_used (unrangetab) - 4
612 - ALIGNOF (EMACS_INT));
613 /* Find the proper location, just like above. */
614 void *new_dest = ALIGN_PTR ((char *) unrangetab + 4,
615 ALIGNOF (EMACS_INT));
616 /* memmove() works in the presence of overlapping data. */
617 memmove (new_dest, cur_dest, count);
618 * (char *) unrangetab = (char) ((char *) new_dest - (char *) unrangetab);
622 /* Look up a value in a unified range table. */
625 unified_range_table_lookup (void *unrangetab, EMACS_INT pos,
626 Lisp_Object default_)
629 struct unified_range_table *un;
631 align_the_damn_table (unrangetab);
632 new_dest = (char *) unrangetab + * (char *) unrangetab;
633 un = (struct unified_range_table *) new_dest;
635 return get_range_table (pos, un->nentries, &un->first, default_);
638 /* Return number of entries in a unified range table. */
641 unified_range_table_nentries (void *unrangetab)
644 struct unified_range_table *un;
646 align_the_damn_table (unrangetab);
647 new_dest = (char *) unrangetab + * (char *) unrangetab;
648 un = (struct unified_range_table *) new_dest;
652 /* Return the OFFSETth range (counting from 0) in UNRANGETAB. */
654 unified_range_table_get_range (void *unrangetab, int offset,
655 EMACS_INT *min, EMACS_INT *max,
659 struct unified_range_table *un;
660 struct range_table_entry *tab;
662 align_the_damn_table (unrangetab);
663 new_dest = (char *) unrangetab + * (char *) unrangetab;
664 un = (struct unified_range_table *) new_dest;
666 assert (offset >= 0 && offset < un->nentries);
667 tab = (&un->first) + offset;
674 /************************************************************************/
676 /************************************************************************/
679 syms_of_rangetab (void)
681 defsymbol (&Qrange_tablep, "range-table-p");
682 defsymbol (&Qrange_table, "range-table");
684 DEFSUBR (Frange_table_p);
685 DEFSUBR (Fmake_range_table);
686 DEFSUBR (Fcopy_range_table);
687 DEFSUBR (Fget_range_table);
688 DEFSUBR (Fput_range_table);
689 DEFSUBR (Fremove_range_table);
690 DEFSUBR (Fclear_range_table);
691 DEFSUBR (Fmap_range_table);
695 structure_type_create_rangetab (void)
697 struct structure_type *st;
699 st = define_structure_type (Qrange_table, 0, rangetab_instantiate);
701 define_structure_type_keyword (st, Qdata, rangetab_data_validate);