← Back to branch summary

~ubuntu-branches/ubuntu/karmic/mit-scheme/karmic

« back to all changes in this revision

Viewing changes to src/edwin/edtstr.scm

  • Committer: Bazaar Package Importer
  • Author(s): Soren Hansen
  • Date: 2007-05-09 10:57:57 UTC
  • mfrom: (1.1.5 upstream)
  • Revision ID: james.westby@ubuntu.com-20070509105757-p8focimovgqxaaed
Tags: 7.7.90+20070205-1ubuntu1
* Merge from debian unstable, remaining changes:
  * Bootstrapping done via supplied binary package. See log entry for
    7.7.90+20060906-3ubuntu1 for details.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/edwin/edtstr.scm
1
1
#| -*-Scheme-*-
2
2
 
3
 
$Id: edtstr.scm,v 1.31 2003/03/06 05:14:21 cph Exp $
 
3
$Id: edtstr.scm,v 1.35 2007/01/05 21:19:23 cph Exp $
4
4
 
5
 
Copyright 1989,1990,1991,1992,2003 Massachusetts Institute of Technology
 
5
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
 
6
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
 
7
    2006, 2007 Massachusetts Institute of Technology
6
8
 
7
9
This file is part of MIT/GNU Scheme.
8
10
 
18
20
 
19
21
You should have received a copy of the GNU General Public License
20
22
along with MIT/GNU Scheme; if not, write to the Free Software
21
 
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
 
23
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
22
24
USA.
23
25
 
24
26
|#
87
89
 
88
90
;;;; Buttons
89
91
 
 
92
(define-record-type <button>
 
93
    (%%make-button number bits down? symbol)
 
94
    button?
 
95
  (number button-number)
 
96
  (bits button-bits)
 
97
  (down? button-down?)
 
98
  (symbol button-symbol))
 
99
 
 
100
(define (make-down-button number #!optional bits)
 
101
  (%make-button number bits #t 'MAKE-DOWN-BUTTON))
 
102
 
 
103
(define (make-up-button number #!optional bits)
 
104
  (%make-button number bits #f 'MAKE-UP-BUTTON))
 
105
 
 
106
(define (%make-button number bits down? caller)
 
107
  (let ((bits (if (default-object? bits) 0 bits)))
 
108
    (guarantee-limited-index-fixnum number #x100 caller)
 
109
    (guarantee-limited-index-fixnum bits #x10 caller)
 
110
    (let ((name
 
111
           (symbol (bucky-bits->prefix bits)
 
112
                   'BUTTON-
 
113
                   number
 
114
                   (if down? '-DOWN '-UP))))
 
115
      (hash-table/intern! buttons-table name
 
116
        (lambda ()
 
117
          (%%make-button number bits down? name))))))
 
118
 
 
119
(define buttons-table
 
120
  (make-strong-eq-hash-table))
 
121
 
 
122
(define (down-button? object)
 
123
  (and (button? object)
 
124
       (button-down? object)))
 
125
 
 
126
(define (up-button? object)
 
127
  (and (button? object)
 
128
       (not (button-down? object))))
 
129
 
 
130
(define (button-name button)
 
131
  (symbol-name (button-symbol button)))
 
132
 
 
133
(set-record-type-unparser-method! <button>
 
134
  (simple-unparser-method (record-type-name <button>)
 
135
    (lambda (button)
 
136
      (list (button-symbol button)))))
 
137
 
90
138
(define-structure (button-event (conc-name button-event/))
91
139
  (window #f read-only #t)
92
140
  (x #f read-only #t)
111
159
       unspecific)
112
160
     thunk
113
161
     (lambda ()
114
 
       (set-editor-button-event! current-editor old-button-event)))))
115
 
 
116
 
(define-record-type <button>
117
 
  (%%make-button number down?)
118
 
  button?
119
 
  (number button/number)
120
 
  (down? button/down?))
121
 
 
122
 
(define make-down-button)
123
 
(define make-up-button)
124
 
(let ((%make-button
125
 
       (lambda (buttons number down?)
126
 
         (or (vector-ref buttons number)
127
 
             (let ((button (%%make-button number down?)))
128
 
               (vector-set! buttons number button)
129
 
               button))))
130
 
      (down-buttons '#())
131
 
      (up-buttons '#()))
132
 
  (set! make-down-button
133
 
        (lambda (number)
134
 
          (if (>= number (vector-length down-buttons))
135
 
              (set! down-buttons (vector-grow down-buttons (+ number 1) #f)))
136
 
          (%make-button down-buttons number #t)))
137
 
  (set! make-up-button
138
 
        (lambda (number)
139
 
          (if (>= number (vector-length up-buttons))
140
 
              (set! up-buttons (vector-grow up-buttons (+ number 1) #f)))
141
 
          (%make-button up-buttons number #f))))
142
 
 
143
 
(define (down-button? object)
144
 
  (and (button? object)
145
 
       (button/down? object)))
146
 
 
147
 
(define (up-button? object)
148
 
  (and (button? object)
149
 
       (not (button/down? object))))
150
 
 
151
 
(define (button/bucky-bits button)
152
 
  button
153
 
  0)
154
 
 
155
 
(set-record-type-unparser-method! <button>
156
 
  (standard-unparser-method (record-type-name <button>)
157
 
    (lambda (button port)
158
 
      (write-string (if (button/down? button) "down" "up") port)
159
 
      (write-char #\space port)
160
 
      (write (button/number button) port))))
 
 
b'\\ No newline at end of file'
 
162
       (set-editor-button-event! current-editor old-button-event)))))
 
 
b'\\ No newline at end of file'