--- /dev/null
+#| -*-Scheme-*-
+
+Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
+ 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
+ 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 Massachusetts
+ Institute of Technology
+
+This file is part of MIT/GNU Scheme.
+
+MIT/GNU Scheme is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or (at
+your option) any later version.
+
+MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
+Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
+USA.
+
+|#
+
+;;;; Support for the FACE text property.
+;;; package: (edwin screen gtk-screen)
+
+(define-command add-text-property
+ "Adds a text property to the current region."
+ (lambda ()
+ (let* ((key (prompt-for-expression "Key"))
+ (val (prompt-for-expression "Value")))
+ (list key val (current-region))))
+ (lambda (key val region)
+ (add-text-property (mark-group (region-start region))
+ (mark-index (region-start region))
+ (mark-index (region-end region))
+ key val)))
+
+(define-structure markup-context
+ image image-index image-end
+ column tab-width char-image-strings)
+
+(define (markup-add-char! context char)
+ ;; Does NOT increment column.
+ (let ((image-index (markup-context-image-index context))
+ (image-end (markup-context-image-end context)))
+ (if (fix:< image-index image-end)
+ (let ((image (markup-context-image context)))
+ (string-set! image image-index char)
+ (set-markup-context-image-index! context (fix:1+ image-index))))))
+
+(define (markup-add-string! context string)
+ ;; Does NOT increment column.
+ (let ((image-index (markup-context-image-index context))
+ (image-end (markup-context-image-end context)))
+ (if (fix:< image-index image-end)
+ (let ((image (markup-context-image context))
+ (nchars (fix:min (string-length string)
+ (fix:- image-end image-index))))
+ (substring-move! string 0 nchars image image-index)
+ (set-markup-context-image-index! context
+ (fix:+ image-index nchars))))))
+
+(define (markup-image-char! context char)
+ ;; DOES increment column and escape CHAR.
+ (let ((escape (case char
+ ((#\<) "<")
+ ((#\&) "&")
+ (else #f))))
+ (if escape
+ (markup-add-string! context escape)
+ (markup-add-char! context char)))
+ (set-markup-context-column! context (fix:1+ (markup-context-column context))))
+
+(define (markup-image-string! context string)
+ ;; DOES increment column and escape characters.
+ (let ((end (string-length string)))
+ (let loop ((i 0))
+ (if (fix:< i end)
+ (begin
+ (markup-image-char! context (string-ref string i))
+ (loop (fix:1+ i)))))))
+
+(define (gtk-group-line-image! group start end
+ image image-start image-end
+ tab-width column-offset char-image-strings
+ receiver)
+ ;; Like GROUP-LINE-IMAGE!, but includes Pango markup. RECEIVER will
+ ;; be called with the start of the next line or END, and the number
+ ;; of characters of markup generated.
+ (let* ((context (make-markup-context image image-start image-end
+ column-offset
+ tab-width char-image-strings))
+ (index (markup-line! group start end context)))
+ (receiver index (markup-context-image-index context))))
+
+(define (markup-line! group start end context)
+
+ (define-syntax define-integrable-operator
+ (rsc-macro-transformer
+ (lambda (form environment)
+ (declare (ignore environment))
+ (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
+ `(BEGIN
+ (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
+ (DEFINE ,@(cdr form)))
+ (ill-formed-syntax form)))))
+
+ (define-integrable-operator (start-face! face)
+ (if face (markup-add-string! context (face-markup face))))
+
+ (define-integrable-operator (stop-face! face)
+ (if face (markup-add-string! context "</span>")))
+
+ (define-integrable-operator (image-char! char)
+ (let ((char-image (vector-ref (markup-context-char-image-strings context)
+ (char->integer char))))
+ (if char-image
+ (markup-image-string! context char-image)
+ (markup-image-char! context char))))
+
+ (define-integrable (image-tab!)
+ (let ((tab-width (markup-context-tab-width context))
+ (column (markup-context-column context)))
+ (let ((n (fix:- tab-width (fix:remainder column tab-width))))
+ (let tab-loop ((i 0))
+ (if (fix:< i n)
+ (begin
+ (markup-image-char! context #\space)
+ (tab-loop (fix:1+ i))))))))
+
+ (define-integrable (overflow?)
+ (not (fix:< (markup-context-image-index context)
+ (markup-context-image-end context))))
+
+ (let loop ((index start) (face #f))
+ (cond ((overflow?)
+ index)
+ ((fix:= index end)
+ (stop-face! face)
+ end)
+ ((get-text-property group index 'INVISIBLE #f)
+ (let ((next (next-specific-property-change group index end
+ 'INVISIBLE)))
+ (if next
+ (loop next face)
+ (begin
+ (stop-face! face)
+ end))))
+ (else
+ (let ((char (group-right-char group index)))
+ (cond ((char=? char #\newline)
+ (stop-face! face)
+ (fix:1+ index))
+ ((char=? char #\tab)
+ (image-tab!)
+ (loop (fix:1+ index) face))
+ (else
+ (let ((face* (get-text-property group index 'FACE #f)))
+ (if (not (eq? face* face))
+ (begin
+ (stop-face! face)
+ (start-face! face*)))
+ (image-char! char)
+ (loop (fix:1+ index) face*)))))))))
+
+(define (face-markup face)
+ (if (string? face)
+ (string-append "<span "face">")
+ "<span>"))
\ No newline at end of file
projects / mit-scheme.git / commitdiff