Mercurial > hg > xemacs-beta
view lwlib/xlwgcs.c @ 5560:58b38d5b32d0
Implement print-circle, allowing recursive and circular structures to be read.
src/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* alloc.c:
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT_1):
* alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT):
* alloc.c (cons_print_preprocess):
* alloc.c (vector_print_preprocess):
* alloc.c (vector_nsubst_structures_descend):
* alloc.c (Fmake_symbol):
* alloc.c (UNMARK_symbol):
* alloc.c (sweep_symbols):
* alloc.c (reinit_alloc_objects_early):
* alloc.c (reinit_alloc_early):
* bytecode.c:
* bytecode.c (compiled_function_print_preprocess):
* bytecode.c (compiled_function_nsubst_structures_descend):
* bytecode.c (set_compiled_function_arglist):
* bytecode.c (set_compiled_function_interactive):
* bytecode.c (bytecode_objects_create):
* chartab.c:
* chartab.c (print_preprocess_mapper):
* chartab.c (nsubst_structures_mapper):
* chartab.c (char_table_nsubst_structures_descend):
* chartab.c (chartab_objects_create):
* elhash.c:
* elhash.c (nsubst_structures_map_hash_table):
* elhash.c (hash_table_nsubst_structures_descend):
* elhash.c (print_preprocess_mapper):
* elhash.c (hash_table_print_preprocess):
* elhash.c (inchash_eq):
* elhash.c (hash_table_objects_create):
* elhash.c (syms_of_elhash):
* elhash.h:
* emacs.c (main_1):
* fns.c:
* fns.c (check_eq_nokey):
* fns.c (Fnsubst):
* fns.c (syms_of_fns):
* lisp.h:
* lisp.h (struct Lisp_Symbol):
* lisp.h (IN_OBARRAY):
* lisp.h (struct):
* lisp.h (PRINT_PREPROCESS):
* lread.c (read1):
* lrecord.h:
* lrecord.h (struct lrecord_implementation):
* lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT):
* print.c:
* print.c (PRINT_CIRCLE_LIMIT):
* print.c (print_continuous_numbering_changed):
* print.c (print_prepare):
* print.c (print_finish):
* print.c (Fprin1_to_string):
* print.c (print_cons):
* print.c (print_preprocess_inchash_eq):
* print.c (print_preprocess):
* print.c (print_sort_get_numbers):
* print.c (print_sort_compare_ordinals):
* print.c (print_gensym_or_circle):
* print.c (nsubst_structures_descend):
* print.c (nsubst_structures):
* print.c (print_internal):
* print.c (print_symbol):
* print.c (vars_of_print):
* rangetab.c:
* rangetab.c (range_table_print_preprocess):
* rangetab.c (range_table_nsubst_structures_descend):
* rangetab.c (rangetab_objects_create):
* rangetab.c (syms_of_rangetab):
* symbols.c:
* symbols.c (symbol_print_preprocess):
* symbols.c (Fintern):
* symbols.c (Funintern):
* symbols.c (reinit_symbol_objects_early):
* symbols.c (init_symbols_once_early):
* symsinit.h:
Implement print-circle, printing circular structures in a readable
fashion, and treating them appropriately on read. This is by means
of two new object methods, print_preprocess (detecting
circularities), and nsubst_structures_descend (replacing
placeholders with the read objects).
Expose the substitution to Lisp via #'nsubst and its new
:descend-structures keyword.
Store information as to whether symbols are interned in obarray or
not in their header, making checking for keywords and uninterned
symbols (and thus printing) cheaper.
Default print_gensym to t, as Common Lisp does, and as a
more-than-decade old comment suggests.
lisp/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-output-file-form):
* bytecomp.el (byte-compile-output-docform):
Bind print-circle, print-continuous-numbering in these functions,
now those variables are available.
* lisp.el (forward-sexp):
* lisp.el (backward-sexp):
Recognise leading #N= as being part of an expression.
tests/ChangeLog addition:
2011-09-04 Aidan Kehoe <kehoea@parhasard.net>
* automated/lisp-reader-tests.el:
* automated/lisp-tests.el (literal-with-uninterned):
* automated/symbol-tests.el (foo):
Test print-circle, for printing (mutually-)recursive and circular
structures.
Bind print-continuous-numbering where appropriate.
author | Aidan Kehoe <kehoea@parhasard.net> |
---|---|
date | Sun, 04 Sep 2011 19:51:35 +0100 |
parents | 308d34e9f07d |
children | 574f0cded429 |
line wrap: on
line source
/* Tabs Widget for XEmacs. Copyright (C) 1999 Edward A. Falk 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 3 of the License, 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. If not, see <http://www.gnu.org/licenses/>. */ /* Synched up with: Gcs.c 1.7 */ /* #### This code is duplicated many times within lwlib and XEmacs. It should be modularised. */ /* * Gcs.c - Utility functions to allocate GCs. * * Author: Edward A. Falk * falk@falconer.vip.best.com * * Date: Sept 29, 1998 */ /* Functions: * * GC AllocFgGC(w, fg, font) * Return a GC with foreground set as specified. * If font is None, then the returned GC is allocated with font specified * as a "don't care" value. * * GC * AllocBackgroundGC(w, font) * Return a GC with the foreground set to the widget's background color. * * GC * AllocGreyGC(w, fg, font, contrast, be_nice_to_cmap) * Widget w ; * Pixel fg ; * Font font ; * int contrast ; * int be_nice_to_cmap ; * * Return a GC suitable for rendering a widget in its "inactive" color. * Normally returns a GC with a color somewhere between the widget's * background color and the specified foreground. If font is None, then * the returned GC is allocated with font specified as "don't care". * If be_nice_to_cmap is True, the returned GC is created using a 50% * dither instead of a new color. * * * GC * AllocShadeGC(w, fg, bg, font, contrast, be_nice_to_cmap) * Widget w ; * Pixel fg, bg ; * Font font ; * int contrast ; * int be_nice_to_cmap ; * * Return a GC suitable for rendering in a shade somewhere between * bg and fg, as determined by contrast (0 = bg, 100 = fg) * If font is None, then the returned GC is allocated with * font specified as "don't care". If be_nice_to_cmap * is True, the returned GC is created using a 50% dither * instead of a new color. * * * GC * AllocTopShadowGC(w, contrast, be_nice_to_cmap) * Return a GC suitable for rendering the "top shadow" decorations of * a widget. Returns a GC with foreground computed from widget's * background color and contrast. If be_nice_to_cmap is True, the * returned GC will use a foreground color of white. If widget depth * is 1, this function will use a foreground color of black. * * GC * AllocBotShadowGC(w, contrast, be_nice_to_cmap) * Return a GC suitable for rendering the "bottom shadow" decorations * of a widget. Returns a GC with foreground computed from widget's * background color and contrast. If be_nice_to_cmap is True, the * returned GC will use a foreground color of black. * * GC * AllocArmGC(w, contrast, be_nice_to_cmap) * Return a GC suitable for rendering the "armed" decorations of a * widget. This GC would typically be used to fill in the widget's * background. Returns a GC with foreground computed from widget's * background color and contrast. If be_nice_to_cmap is True, the * returned GC will use a foreground color of black and a 50% dither. * * * void * Draw3dBox(w, x,y,wid,hgt,s, topgc, botgc) * Utility function. Draws a raised shadow box with outside dimensions * as specified by x,y,wid,hgt and shadow width specified by s. * A lowered shadow box may be generated by swapping topgc and botgc. * */ #include <config.h> #include <stdio.h> #include <X11/Xlib.h> #include <X11/IntrinsicP.h> #include <X11/StringDefs.h> #include <X11/Xmu/Drawing.h> #include <X11/Xmu/Misc.h> #include "xlwgcs.h" /* Color & GC allocation. * * Frame widgets use the following graphics contexts: * * Foreground tab label text drawn this way * Insensitive Fg foreground color greyed out. * Background frame background color * Top shadow upper-left highlight around widget * Bottom shadow lower-right highlight around widget * Arm shadow button pressed and ready to be released * * * GC's are defined as follows, depending on attributes and * window depth: * * Monochrome: * Foreground = foreground color attribute or BlackPixel() * Grey = Foreground color + 50% dither * Background = background color attribute or WhitePixel() * top shadow = foreground * bottom shadow = foreground * arm shadow = (what?) * * Color, beNiceToColormap=true: * Foreground = foreground color attribute or BlackPixel() * Grey = Foreground color + 50% dither * Background = background color attribute or WhitePixel() * top shadow = white * bottom shadow = black * arm shadow = (what?) * * Color, beNiceToColormap=false: * Foreground = foreground color attribute or BlackPixel() * Grey = (foreground color + background color)/2 * Background = background color attribute or WhitePixel() * top shadow = background * 1.2 * bottom shadow = background * .6 * arm shadow = background * .8 * * Special cases: * If background is white, ?? * if background is black, ?? * * * If the widget's background is solid white or solid black, * this code just picks some numbers. (The choice is designed * to be compatible with ThreeD interface.) */ #if NeedFunctionPrototypes static Pixmap getDitherPixmap(Widget, int contrast) ; #else static Pixmap getDitherPixmap() ; #endif /* return a GC with the specified foreground and optional font */ GC AllocFgGC(Widget w, Pixel fg, Font font) { XGCValues values ; unsigned long vmask, dcmask ; values.foreground = fg ; values.font = font ; if( font != None ) { vmask = GCForeground|GCFont ; dcmask = GCSubwindowMode|GCDashOffset| GCDashList|GCArcMode|GCBackground|GCGraphicsExposures ; } else { vmask = GCForeground ; dcmask = GCFont|GCSubwindowMode|GCDashOffset| GCDashList|GCArcMode|GCBackground|GCGraphicsExposures ; } return XtAllocateGC(w, w->core.depth, vmask, &values, 0L, dcmask) ; } /* return gc with widget background color as the foreground */ GC AllocBackgroundGC(Widget w, Font font) { return AllocFgGC(w, w->core.background_pixel, font) ; } /* Allocate an "inactive" GC. Color is grey (possibly via * dither pattern). */ GC AllocGreyGC(Widget w, Pixel fg, Font font, int contrast, Bool be_nice_to_cmap) { return AllocShadeGC(w, fg, w->core.background_pixel, font, contrast, be_nice_to_cmap) ; } /* Allocate a GC somewhere between two colors. */ GC AllocShadeGC(Widget w, Pixel fg, Pixel bg, Font font, int contrast, Bool be_nice_to_cmap) { XGCValues values ; unsigned long vmask, dcmask ; values.foreground = fg ; values.background = bg ; values.font = font ; if( font != None ) { vmask = GCForeground|GCFont ; dcmask = GCSubwindowMode|GCDashOffset| GCDashList|GCArcMode|GCGraphicsExposures ; } else { vmask = GCForeground; dcmask = GCFont|GCSubwindowMode|GCDashOffset| GCDashList|GCArcMode|GCGraphicsExposures ; } if( be_nice_to_cmap || w->core.depth == 1) { if( contrast <= 5 ) values.foreground = bg ; else if( contrast >= 95 ) values.foreground = fg ; else { vmask |= GCBackground|GCStipple|GCFillStyle ; values.fill_style = FillOpaqueStippled ; values.stipple = getDitherPixmap(w, contrast) ; } return XtAllocateGC(w, w->core.depth, vmask, &values, 0L, dcmask) ; } else { dcmask |= GCBackground ; values.foreground = AllocGreyPixel(w, fg, bg, contrast) ; return XtAllocateGC(w, w->core.depth, vmask, &values, 0L, dcmask) ; } } /* return top-shadow gc. */ GC AllocTopShadowGC(Widget w, int contrast, Bool be_nice_to_cmap) { Screen *scr = XtScreen (w); XGCValues values ; if( w->core.depth == 1 ) values.foreground = BlackPixelOfScreen(scr) ; else if( be_nice_to_cmap ) values.foreground = WhitePixelOfScreen(scr) ; else values.foreground = AllocShadowPixel(w, 100+contrast) ; return XtAllocateGC(w, w->core.depth, GCForeground, &values, 0L, GCBackground|GCFont|GCSubwindowMode|GCGraphicsExposures| GCDashOffset|GCDashList|GCArcMode) ; } /* return bottom-shadow gc. */ GC AllocBotShadowGC(Widget w, int contrast, Bool be_nice_to_cmap) { Screen *scr = XtScreen (w); XGCValues values ; if( w->core.depth == 1 || be_nice_to_cmap ) values.foreground = BlackPixelOfScreen(scr) ; else values.foreground = AllocShadowPixel(w, 100-contrast) ; return XtAllocateGC(w, w->core.depth, GCForeground, &values, 0L, GCBackground|GCFont|GCSubwindowMode|GCGraphicsExposures| GCDashOffset|GCDashList|GCArcMode) ; } /* return arm-shadow gc. */ GC AllocArmGC(Widget w, int contrast, Bool be_nice_to_cmap) { Screen *scr = XtScreen (w); XGCValues values ; /* Not clear exactly what we should do here. Take a look at * Xaw3d to see what they do. */ if( w->core.depth == 1 || be_nice_to_cmap ) { values.background = w->core.background_pixel ; if( values.background == BlackPixelOfScreen(scr) ) values.foreground = WhitePixelOfScreen(scr) ; else values.foreground = BlackPixelOfScreen(scr) ; values.fill_style = FillStippled ; values.stipple = XmuCreateStippledPixmap(XtScreen(w), 1L, 0L, 1) ; return XtAllocateGC(w, w->core.depth, GCForeground|GCBackground|GCStipple|GCFillStyle, &values, 0L, GCFont|GCSubwindowMode|GCGraphicsExposures| GCDashOffset|GCDashList|GCArcMode) ; } else { values.foreground = AllocShadowPixel(w, 100-contrast) ; return XtAllocateGC(w, w->core.depth, GCForeground, &values, 0L, GCBackground|GCFont|GCSubwindowMode|GCGraphicsExposures| GCDashOffset|GCDashList|GCArcMode) ; } } Pixel AllocShadowPixel(Widget w, int scale) { XColor get_c, set_c ; Display *dpy = XtDisplay(w) ; Screen *scr = XtScreen(w) ; Colormap cmap ; Pixel maxColor ; cmap = w->core.colormap ; get_c.pixel = w->core.background_pixel ; if( get_c.pixel == WhitePixelOfScreen(scr) || get_c.pixel == BlackPixelOfScreen(scr) ) { /* what we *ought* to do is choose gray75 as the base color, * or perhaps gray83. Instead, we choose colors that are * the same as ThreeD would choose. */ if( scale > 100 ) scale = 200 - scale ; set_c.red = set_c.green = set_c.blue = 65535*scale/100 ; } else { XQueryColor(dpy, cmap, &get_c) ; /* adjust scale so that brightest component does not * exceed 65535; otherwise hue would change. */ if( scale > 100 ) { maxColor = Max(get_c.red, Max(get_c.green, get_c.blue)) ; if( scale*maxColor > 65535*100 ) scale = 65535*100/maxColor ; } set_c.red = scale * get_c.red / 100 ; set_c.green = scale * get_c.green / 100 ; set_c.blue = scale * get_c.blue / 100 ; } set_c.flags = DoRed | DoGreen | DoBlue ; if( XAllocColor(dpy, cmap, &set_c) ) return set_c.pixel ; else if( scale > 100 ) return WhitePixelOfScreen(scr) ; else return BlackPixelOfScreen(scr) ; } /* Allocate a pixel partway between foreground and background */ Pixel AllocGreyPixel(Widget w, Pixel fg, Pixel bg, int scale) { XColor get_cf, get_cb ; Display *dpy = XtDisplay(w) ; Colormap cmap ; cmap = w->core.colormap ; get_cf.pixel = fg ; get_cb.pixel = bg ; XQueryColor(dpy, cmap, &get_cf) ; XQueryColor(dpy, cmap, &get_cb) ; return AllocGreyPixelC(w, &get_cf, &get_cb, scale) ; } /* Allocate a pixel partway between foreground and background */ Pixel AllocGreyPixelC(Widget w, XColor *fg, XColor *bg, int scale) { XColor set_c ; Display *dpy = XtDisplay(w) ; int r,g,b ; Colormap cmap = w->core.colormap ; r = (fg->red * scale + bg->red * (100-scale)) / 100 ; g = (fg->green * scale + bg->green * (100-scale)) / 100 ; b = (fg->blue * scale + bg->blue * (100-scale)) / 100 ; if( scale > 100 || scale < 0 ) /* look out for overflow */ { int minc, maxc ; maxc = Max(r, Max(g,b)) ; minc = Min(r, Min(g,b)) ; if( maxc > 65535 ) { maxc /= 16 ; r = r*(65535/16) / maxc ; g = g*(65535/16) / maxc ; b = b*(65535/16) / maxc ; } if( minc < 0 ) { r = Max(r,0) ; g = Max(g,0) ; b = Max(b,0) ; } } set_c.red = r ; set_c.green = g ; set_c.blue = b ; set_c.flags = DoRed | DoGreen | DoBlue ; (void)XAllocColor(dpy, cmap, &set_c) ; return set_c.pixel ; } /* draw a 3-d box */ void Draw3dBox(Widget w, int x, int y, int wid, int hgt, int s, GC topgc, GC botgc) { Display *dpy = XtDisplay(w) ; Window win = XtWindow(w) ; if( s == 0 ) return ; if( s == 1 ) { XDrawLine(dpy,win,botgc, x,y+hgt-1, x+wid-1,y+hgt-1) ; XDrawLine(dpy,win,botgc, x+wid-1,y, x+wid-1,y+hgt-1) ; XDrawLine(dpy,win,topgc, x,y, x,y+hgt-1) ; XDrawLine(dpy,win,topgc, x,y, x+wid-1,y) ; } else { XPoint pts[6] ; /* bottom-right shadow */ pts[0].x = x ; pts[0].y = y + hgt ; pts[1].x = s ; pts[1].y = -s ; pts[2].x = wid-2*s ; pts[2].y = 0 ; pts[3].x = 0 ; pts[3].y = -(hgt-2*s) ; pts[4].x = s ; pts[4].y = -s ; pts[5].x = 0 ; pts[5].y = hgt ; XFillPolygon(dpy,win,botgc, pts,6, Nonconvex,CoordModePrevious) ; /* top-left shadow */ pts[0].x = x ; pts[0].y = y ; pts[1].x = wid ; pts[1].y = 0 ; pts[2].x = -s ; pts[2].y = s ; pts[3].x = -wid+2*s ; pts[3].y = 0 ; pts[4].x = 0 ; pts[4].y = hgt-2*s ; pts[5].x = -s ; pts[5].y = s ; XFillPolygon(dpy,win,topgc, pts,6, Nonconvex,CoordModePrevious) ; } } static unsigned char screen0[2] = {0,0} ; static unsigned char screen25[2] = {0,0xaa} ; static unsigned char screen75[2] = {0xaa,0xff} ; static unsigned char screen100[2] = {0xff,0xff} ; static Pixmap getDitherPixmap(Widget w, int contrast) { Display *dpy = XtDisplay(w) ; Window win = XtWindow(w) ; if( contrast <= 5 ) return XCreateBitmapFromData(dpy,win, (char *)screen0, 2,2) ; else if( contrast <= 37 ) return XCreateBitmapFromData(dpy,win, (char *)screen25, 2,2) ; else if( contrast <= 62 ) return XmuCreateStippledPixmap(XtScreen(w), 1L, 0L, 1) ; else if( contrast <= 95 ) return XCreateBitmapFromData(dpy,win, (char *)screen75, 2,2) ; else return XCreateBitmapFromData(dpy,win, (char *)screen100, 2,2) ; }