├── .gitignore ├── load.scm ├── edwin48 ├── scsh │ ├── fixme.scm │ ├── key-test.scm │ ├── regexp.scm │ ├── io-support.scm │ ├── errors.scm │ ├── fixnum.scm │ ├── keystroke-modifiers.scm │ ├── rbtree.scm │ ├── macros-helpers.scm │ ├── 1d-table.scm │ ├── weak-pair.scm │ ├── char-support.scm │ ├── event-distributor.scm │ ├── pathname-scsh.scm │ ├── aliases.scm │ ├── terminal-support.scm │ └── records.scm ├── input-event.scm ├── srfi-89.scm ├── rename.scm ├── winren.scm ├── xmodef.scm ├── nvector.scm ├── make.scm ├── dosproc.scm ├── srfi-69.scm ├── srfi-66.scm ├── paths.scm ├── strpad.scm ├── buttons.scm ├── scrcom.scm ├── ring.scm ├── midas.scm ├── edtstr.scm ├── modwin.scm ├── comman.scm ├── bufout.scm ├── bufinp.scm ├── display.scm ├── variable.scm ├── clscon.scm ├── srfi-packages.scm ├── mousecom.scm ├── class.scm ├── doscom.scm ├── htmlmode.scm ├── bufset.scm ├── dirunx.scm ├── modes.scm ├── winout.scm ├── diros2.scm ├── dirw32.scm ├── clsmac.scm ├── old-packages.scm ├── os2com.scm ├── utlwin.scm ├── telnet.scm ├── comhst.scm ├── key-w32.scm ├── argred.scm ├── win32com.scm ├── reccom.scm ├── comatch.scm └── compile.scm ├── cosmacs ├── cosmacs.scm ├── load.scm └── packages.scm ├── tests ├── terminal-mode.scm ├── packages.scm ├── keystroke-printer.scm ├── load.scm ├── test-buffer.scm ├── 1d-table-tests.scm └── test-comtab.scm ├── TODO ├── .gitmodules ├── docs └── keystroke-notation.txt ├── README.md ├── config-macros.scm ├── scratch └── test-groups.scm └── missing /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | \#*\# 3 | .#* 4 | TAGS 5 | -------------------------------------------------------------------------------- /load.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scheme/edwin48/HEAD/load.scm -------------------------------------------------------------------------------- /edwin48/scsh/fixme.scm: -------------------------------------------------------------------------------- 1 | (define (procedure-arity-valid? procedure n) #t) 2 | 3 | -------------------------------------------------------------------------------- /cosmacs/cosmacs.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scheme/edwin48/HEAD/cosmacs/cosmacs.scm -------------------------------------------------------------------------------- /tests/terminal-mode.scm: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/scheme/edwin48/HEAD/tests/terminal-mode.scm -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | FIXME 2 | ======= 3 | 4 | o Implement re-string-search-forward 5 | o Write a real implementation of system-library-directory-pathname 6 | o Figure out the event framework. 7 | o Output-port/x-size 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "pantene"] 2 | path = pantene 3 | url = https://github.com/roderyc/pantene.git 4 | [submodule "terminfo"] 5 | path = terminfo 6 | url = https://github.com/scheme/terminfo.git 7 | [submodule "soosy"] 8 | path = soosy 9 | url = https://github.com/scheme/soosy.git 10 | -------------------------------------------------------------------------------- /tests/packages.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: (config) -*- 2 | 3 | (define-structure 1d-table-tests 4 | (export run-1d-table-test) 5 | (open scheme formats 1d-table) 6 | (files 1d-table-tests)) 7 | 8 | (define-structure comtab-tests 9 | (export check-report) 10 | (open scheme edwin:command-table srfi-78) 11 | (files test-comtab)) 12 | 13 | -------------------------------------------------------------------------------- /edwin48/scsh/key-test.scm: -------------------------------------------------------------------------------- 1 | (define equivalent-keys-alist 2 | (list 3 | (list (kbd a) (kbd #\a)) 4 | (list (kbd backspace) (kbd #\backspace)) 5 | (list (kbd space) (kbd #\space)) 6 | (list (kbd return) (kbd #\return)) 7 | (list (kbd abc) (kbd "abc")))) 8 | 9 | (for-each 10 | (lambda (key-pair) 11 | (display (apply key=? key-pair)) 12 | (newline)) 13 | equivalent-keys-alist) 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /docs/keystroke-notation.txt: -------------------------------------------------------------------------------- 1 | Edwin uses a keystroke notation different from Emacs, here's its 2 | grammar. 3 | 4 | := (kbd +) 5 | 6 | := | | | 7 | 8 | := char-set:printing 9 | 10 | := "*" 11 | 12 | := | return | space | tab 13 | | backspace | delete 14 | | left | right | up | down 15 | 16 | := (+ ) 17 | 18 | := control | meta | super 19 | -------------------------------------------------------------------------------- /tests/keystroke-printer.scm: -------------------------------------------------------------------------------- 1 | (define (start-printer) 2 | (receive (halt-update? peek-no-hang peek read) 3 | (get-console-input-operations) 4 | (with-current-input-terminal-mode 'raw 5 | (let ((term (setup-terminal))) 6 | (tputs (keypad-xmit term)) 7 | (let loop ((k (read))) 8 | (if (key=? k (kbd (ctrl #\q))) 9 | (begin (display "bye") 10 | (newline) 11 | (tputs (keypad-local term))) 12 | (begin (display (key->name k)) 13 | (newline) 14 | (loop (read))))))))) 15 | 16 | 17 | -------------------------------------------------------------------------------- /edwin48/input-event.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: scheme; scheme48-package: edwin:input-event -*- 2 | 3 | (define-record-type input-event 4 | (really-make-input-event type operator operands) 5 | input-event? 6 | (type input-event/type) 7 | (operator input-event/operator) 8 | (operands input-event/operands)) 9 | 10 | (define (make-input-event type operator . operands) 11 | (really-make-input-event type operator operands)) 12 | 13 | (define (apply-input-event input-event) 14 | (if (not (input-event? input-event)) 15 | (error:wrong-type-argument input-event "input event" apply-input-event)) 16 | (apply (input-event/operator input-event) 17 | (input-event/operands input-event))) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # EDWIN48 2 | This is an effort to modernize the Edwin codebase in MIT Scheme. The goal is to make it run on 3 | modern Schemes. 4 | 5 | ## Dependencies 6 | Edwin48 depends on a set of libraries that are referenced by this git repo using the git submodule 7 | mechanism. To download those dependencies, after the initial checkout, please run 8 | 9 | git submodule init 10 | git submodule update 11 | 12 | In order to load the edwin48 code, you'll need an up to date installation of 13 | [scsh](https://github.com/scheme/scsh). See the installation instructions there for details. 14 | 15 | ## Running Edwin48 16 | See the `load.scm` script in the top level directory or `cosmacs/load.scm`. 17 | -------------------------------------------------------------------------------- /tests/load.scm: -------------------------------------------------------------------------------- 1 | (user) 2 | 3 | (translate "=base" "..") 4 | 5 | (config '(load "=base/config-macros.scm")) 6 | 7 | (config '(load "=base/edwin48/srfi-packages.scm" 8 | "=base/edwin48/scsh/packages.scm")) 9 | 10 | (config '(load "=base/terminfo/interfaces.scm" 11 | "=base/terminfo/scsh-packages.scm")) 12 | 13 | (config '(load "=base/soosy/interfaces.scm" 14 | "=base/soosy/packages.scm")) 15 | 16 | (config '(load "=base/pantene/edwin-interfaces.scm" 17 | "=base/pantene/edwin-packages.scm")) 18 | 19 | (config '(load "=base/edwin48/scratch-interfaces.scm" 20 | "=base/edwin48/scratch-packages.scm")) 21 | 22 | (config '(load "packages.scm")) -------------------------------------------------------------------------------- /edwin48/scsh/regexp.scm: -------------------------------------------------------------------------------- 1 | (define (re-compile-pattern . arg) (error "Not implemented" re-compile-pattern)) 2 | (define (re-string-match . arg) (error "Not implemented" re-string-match)) 3 | (define (re-substring-match . arg) (error "Not implemented" re-substring-match)) 4 | (define (re-string-search-forward . arg) (error "Not implemented" re-string-search-forward)) 5 | (define (re-match-start-index . arg) (error "Not implemented" re-match-start-index)) 6 | (define (re-match-end-index . arg) (error "Not implemented" re-match-end-index)) 7 | (define (re-match-extract . arg) (error "Not implemented" re-match-extract)) 8 | (define (regexp-group . arg) (error "Not implemented" regexp-group)) 9 | -------------------------------------------------------------------------------- /edwin48/scsh/io-support.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: scheme; scheme48-package: io-support -*- 2 | 3 | (define (input-available-on-port? port block?) 4 | (receive (rvec wvec evec) 5 | (select (vector port) 6 | (vector) 7 | (vector) 8 | (if block? #f 0)) 9 | (> 0 (vector-length rvec)))) 10 | 11 | (define (file-eq? filename1 filename2) 12 | (let ((info1 (file-info filename1)) 13 | (info2 (file-info filename2))) 14 | (= (file-info:inode info1) 15 | (file-info:inode info2)))) 16 | 17 | (define (file-modification-time filename) 18 | (file-info:mtime (file-info filename))) 19 | 20 | (define (call-with-binary-input-file filename thunk) 21 | (call-with-input-file filename thunk)) 22 | 23 | (define (call-with-binary-output-file filename thunk) 24 | (call-with-output-file filename thunk)) 25 | -------------------------------------------------------------------------------- /edwin48/scsh/errors.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: s48-errors -*- 2 | 3 | (define (error:bad-range-argument datum operator) 4 | (error "bad range argument" 5 | `(,datum) 6 | `(is out of range for ,operator))) 7 | 8 | (define (error:datum-out-of-range datum) 9 | (error "out of range" datum)) 10 | 11 | (define (error:file-operation filename verb noun reason operator operands) 12 | (error "file operation" 13 | `(,filename) 14 | `(unable to ,verb ,noun because ,reason))) 15 | 16 | (define (error:wrong-type-argument datum type operator) 17 | (error "wrong type argument" 18 | `(,operator) 19 | `(expects ,datum) 20 | `(to be type ,type))) 21 | 22 | (define (error:not-list datum operator) 23 | (error "not a list" 24 | `(,datum) 25 | `(,operator))) 26 | 27 | (define (error:not-weak-list datum operator) 28 | (error "not a weak list" 29 | `(,datum) 30 | `(,operator))) 31 | -------------------------------------------------------------------------------- /config-macros.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Macro used to exporting edwin-specific bindings. 3 | ;;; 4 | ;;; (edwin:export (variable a) 5 | ;;; (command b) 6 | ;;; (mode c)) 7 | ;;; This is equivalent to 8 | ;;; 9 | ;;; (export edwin-variable$a 10 | ;;; edwin-command$b 11 | ;;; edwin-mode$c) 12 | ;;; 13 | (define-syntax edwin:export 14 | (lambda (form rename compare) 15 | `(,(rename 'export) 16 | ,@(apply append 17 | (map (lambda (specifier) 18 | (let ((category (car specifier)) 19 | (names (cdr specifier))) 20 | (map (lambda (name) 21 | (string->symbol 22 | (apply string-append 23 | (map symbol->string 24 | `(edwin - ,category $ ,name))))) 25 | names))) 26 | (cdr form))))) 27 | (export)) 28 | -------------------------------------------------------------------------------- /edwin48/scsh/fixnum.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; Fixnum operations 3 | ;;; 4 | 5 | (define (fix:= a b) (= a b)) 6 | (define (fix:< a b) (< a b)) 7 | (define (fix:> a b) (> a b)) 8 | (define (fix:<= a b) (<= a b)) 9 | (define (fix:>= a b) (>= a b)) 10 | 11 | (define (fix:fixnum? n) (integer? n)) 12 | (define (fix:zero? n) (zero? n)) 13 | (define (fix:positive? n) (positive? n)) 14 | (define (fix:negative? n) (negative? n)) 15 | 16 | (define (fix:+ a b) (+ a b)) 17 | (define (fix:- a b) (- a b)) 18 | (define (fix:* a b) (* a b)) 19 | (define (fix:min a b) (min a b)) 20 | (define (fix:max a b) (max a b)) 21 | (define (fix:quotient a b) (quotient a b)) 22 | (define (fix:remainder a b) (remainder a b)) 23 | (define (fix:1+ n) (+ n 1)) 24 | (define (fix:-1+ n) (- n 1)) 25 | 26 | 27 | (define (fix:not n) (bitwise-not n)) 28 | (define (fix:and a b) (bitwise-and a b)) 29 | (define (fix:andc a b) (bitwise-and a (bitwise-not b))) 30 | (define (fix:or a b) (bitwise-ior a b)) 31 | (define (fix:xor a b) (bitwise-xor a b)) 32 | (define (fix:lsh a b) (arithmetic-shift a b)) 33 | 34 | 35 | -------------------------------------------------------------------------------- /cosmacs/load.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: (exec) -*- 2 | ;;; 3 | ;;; Copyright © 2007 Duncan Mak 4 | ;;; 5 | ;;; This code is placed in the Public Domain. All warranties are 6 | ;;; disclaimed. 7 | ;;; 8 | ;;; This script loads the code for cosmacs and its dependencies. To run it, execute the following on 9 | ;;; the scsh repl from this directory: 10 | ;;; 11 | ;;; > ,exec ,load load.scm 12 | 13 | (user) 14 | 15 | (translate "=base" "..") 16 | 17 | (config '(load "=base/config-macros.scm")) 18 | 19 | (config '(load "=base/edwin48/srfi-packages.scm" 20 | "=base/edwin48/scsh/packages.scm")) 21 | 22 | (config '(load "=base/terminfo/interfaces.scm" 23 | "=base/terminfo/scsh-packages.scm")) 24 | 25 | (config '(load "=base/soosy/interfaces.scm" 26 | "=base/soosy/packages.scm")) 27 | 28 | (config '(load "=base/pantene/interfaces.scm" 29 | "=base/pantene/packages.scm")) 30 | 31 | (config '(load "=base/edwin48/interfaces.scm" 32 | "=base/edwin48/packages.scm")) 33 | 34 | (config '(load "packages.scm")) 35 | -------------------------------------------------------------------------------- /edwin48/scsh/keystroke-modifiers.scm: -------------------------------------------------------------------------------- 1 | (define-enumerated-type key-modifier :key-modifier 2 | key-modifier? 3 | all-key-modifiers 4 | key-modifier-name 5 | key-modifier-index 6 | (shift ctrl meta alt)) 7 | 8 | (define-enumerated-type named-keystroke :named-keystroke 9 | named-keystroke? 10 | all-named-keystrokes 11 | named-keystroke-name 12 | named-keystroke-value 13 | (up down left right backspace)) 14 | 15 | (define-enum-set-type key-modifier-set :key-modifier-set 16 | key-modifier-set? make-key-modifier-set 17 | key-modifier key-modifier? all-key-modifiers key-modifier-index) 18 | 19 | (define all-named-keys 20 | '((#\backspace . backspace) 21 | (#\del . delete) 22 | (#\escape . escape) 23 | (#\newline . newline) 24 | (#\return . return) 25 | (#\rubout . rubout) 26 | (#\space . space) 27 | (#\tab . tab) 28 | (#\vtab . vtab))) 29 | 30 | (define (key-modifier-set=? set1 set2) (enum-set=? set1 set2)) 31 | (define (key-modifier-set->list set) (enum-set->list set)) 32 | (define (key-modifier-set-union set key) (enum-set-union set key)) -------------------------------------------------------------------------------- /edwin48/srfi-89.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: srfi-89 -*- 2 | ;;; (open scheme srfi-1 let-opt) 3 | ;;; (for-syntax (open scheme let-opt (subset signals (syntax-error)) srfi-1)) 4 | 5 | (define-syntax define* 6 | (lambda (form rename compare) 7 | (let* ((signature (cadr form)) 8 | (body (cddr form)) 9 | (name (car signature)) 10 | (arguments (cdr signature)) 11 | (required (lambda (args) (take-while symbol? args))) 12 | (optional (lambda (args) (drop-while symbol? args))) 13 | (required-args (required arguments)) 14 | (optional-args (optional arguments)) 15 | (args (rename 'args)) 16 | (%define (rename 'define)) 17 | (%let-optionals (rename 'let-optionals))) 18 | (cond 19 | ((null? optional-args) 20 | `(,%define (,name ,@required-args) ,@body)) 21 | ((not (every pair? optional-args)) 22 | (syntax-error "all required arguments must come before optional arguments")) 23 | (else 24 | `(,%define (,name ,@required-args . ,args) 25 | (,%let-optionals ,args ,optional-args 26 | ,@body))))))) -------------------------------------------------------------------------------- /edwin48/rename.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: rename.scm,v 1.14 2008/01/30 20:02:05 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Edwin Interpackage Renames 29 | 30 | 31 | -------------------------------------------------------------------------------- /edwin48/winren.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: winren.scm,v 1.12 2008/01/30 20:02:07 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Window System Rename Exports 29 | 30 | -------------------------------------------------------------------------------- /edwin48/xmodef.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: xmodef.scm,v 1.9 2008/01/30 20:02:07 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Fundamental Mode, additional X bindings 29 | 30 | 31 | -------------------------------------------------------------------------------- /cosmacs/packages.scm: -------------------------------------------------------------------------------- 1 | ;; (define-interface cosmacs:command-reader/interface 2 | ;; (export dispatch-on-key)) 3 | 4 | ;; (define-structures 5 | ;; ((cosmacs:command-reader cosmacs:command-reader/interface) 6 | ;; (edwin:mode edwin:mode/interface)) 7 | ;; (open scheme aliases edwin:command srfi-1 srfi-69 srfi-89 srfi-78 srfi-14 8 | ;; define-record-type* errors keystroke aliases keystroke-discloser 9 | ;; edwin:string-table edwin:doc-string sorting ascii) 10 | ;; (for-syntax (open scheme macro-helpers)) 11 | ;; (files (../edwin48/scsh macros) 12 | ;; ../edwin48/modes 13 | ;; ../edwin48/comtab)) 14 | 15 | (define-interface cosmetic-emacs-interface 16 | (export start 17 | wait-for-key 18 | %read-char 19 | make-cosmacs-port 20 | input-terminal-raw-mode 21 | input-terminal-cooked-mode)) 22 | 23 | (define-structure cosmacs cosmetic-emacs-interface 24 | (open scsh scheme 25 | extended-ports 26 | handle 27 | keystroke 28 | i/o 29 | edwin:mode 30 | errors 31 | (subset edwin:command-table (define-key comtab-entry)) 32 | edwin:command 33 | edwin:fundamental) 34 | (files cosmacs)) 35 | 36 | -------------------------------------------------------------------------------- /edwin48/scsh/rbtree.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: scheme; scheme48-package: rbtree -*- 2 | 3 | (define (make-rb-tree key=? keyalist rb-tree) 19 | (let ((alist '())) 20 | (walk-search-tree 21 | (lambda (k v) (cons (list k v) alist)) 22 | rb-tree) 23 | alist)) 24 | 25 | (define (alist->rb-tree alist key=? keyscheme-name name) 2 | (symbol-append 'edwin-command$ name)) 3 | 4 | (define (variable-name->scheme-name name) 5 | (symbol-append 'edwin-variable$ name)) 6 | 7 | (define (mode-name->scheme-name name) 8 | (symbol-append 'edwin-mode$ name)) 9 | 10 | (define (list-ref/default list index default-value) 11 | (if (> (length list) index) 12 | (list-ref list index) 13 | default-value)) 14 | 15 | (define (expand-variable-definition buffer-local?) 16 | (lambda (form rename compare) 17 | (if (not (<= (length form) 6)) 18 | (syntax-error "DEFINE-VARIABLE name description value test normalization")) 19 | (let* ((%define (rename 'define)) 20 | (%make-variable (rename 'make-variable)) 21 | (name (list-ref form 1)) 22 | (scheme-name (variable-name->scheme-name name)) 23 | (description (list-ref/default form 2 #f)) 24 | (value (list-ref/default form 3 #f)) 25 | (test (list-ref/default form 4 #f)) 26 | (normalization (list-ref/default form 5 #f))) 27 | `(,%define ,scheme-name 28 | (,%make-variable ',name ,description ,value 29 | ,buffer-local? ,test ,normalization))))) 30 | 31 | (define (expand-variable-assignment form generator) 32 | (if (not (<= (length form) 4)) 33 | (syntax-error "ill-formed syntax" form) 34 | (generator (list-ref form 1) 35 | (list-ref/default form 2 #f) 36 | (list-ref/default form 3 #f)))) 37 | -------------------------------------------------------------------------------- /edwin48/dosproc.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: dosproc.scm,v 1.15 2008/01/30 20:02:00 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Dummy subprocess support 29 | ;; package: (edwin process) 30 | 31 | 32 | (define subprocesses-available? 33 | #f) 34 | 35 | (define (process-list) 36 | '()) 37 | 38 | (define (get-buffer-process buffer) 39 | buffer 40 | #f) 41 | 42 | (define (buffer-processes buffer) 43 | buffer 44 | '()) 45 | 46 | (define (process-operation name) 47 | (lambda (process) 48 | (editor-error "Processes not implemented" name process))) 49 | 50 | (define delete-process 51 | (process-operation 'DELETE-PROCESS)) 52 | 53 | (define (process-status-changes?) 54 | #f) 55 | 56 | (define (process-output-available?) 57 | #f) -------------------------------------------------------------------------------- /edwin48/scsh/1d-table.scm: -------------------------------------------------------------------------------- 1 | ;;; 2 | ;;; -*- Mode: Scheme; scheme48-package: 1d-table -*- 3 | ;;; 4 | ;;; An implementation of MIT Scheme's 1D Tables 5 | ;;; http://www.gnu.org/software/mit-scheme/documentation/mit-scheme-ref/1D-Tables.html 6 | ;;; 7 | 8 | (define (make-1d-table) (list "1D table")) 9 | 10 | (define (1d-table? obj) 11 | (and (list? obj) 12 | (string=? (car obj) "1D table"))) 13 | 14 | (define (1d-table/put! table key value) 15 | (if (not (1d-table? table)) 16 | (error "not a 1d-table" table) 17 | (let* ((alist (cdr table)) 18 | (pair (weak-assq key alist))) 19 | (if pair 20 | (weak-set-cdr! pair value) 21 | (set-cdr! table 22 | (cons (weak-cons key value) 23 | alist)))))) 24 | 25 | (define (1d-table/remove! table key) 26 | (if (not (1d-table? table)) 27 | (error "not a 1d-table" table) 28 | (let* ((alist (cdr table)) 29 | (pair (weak-assq key alist))) 30 | (if pair 31 | (set-cdr! table (delete pair alist))) 32 | unspecific))) 33 | 34 | (define (1d-table/get table key default) 35 | (if (not (1d-table? table)) 36 | (error "not a 1d-table" table) 37 | (let ((pair (weak-assq key (cdr table)))) 38 | (if (not pair) 39 | default 40 | (weak-cdr pair))))) 41 | 42 | (define (1d-table/lookup table key if-found if-not-found) 43 | (if (not (1d-table? table)) 44 | (error "not a 1d-table" table) 45 | (let ((pair (weak-assq key (cdr table)))) 46 | (if pair 47 | (if-found (weak-cdr pair)) 48 | (if-not-found))))) 49 | 50 | (define (1d-table/alist table) 51 | (reverse (map (lambda (pair) 52 | (cons (weak-car pair) 53 | (weak-cdr pair))) 54 | (cdr table)))) 55 | -------------------------------------------------------------------------------- /tests/test-buffer.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: tests:buffer -*- 2 | ;;; 3 | ;;; Buffer tests 4 | ;;; 5 | 6 | ;;;; Running in Scheme48: 7 | ;;;; Run in edwin48/tests/ 8 | ;;;; ,exec ,load load.scm 9 | ;;;; ,in edwin:buffer 10 | ;;;; ,open srfi-78 11 | ;;;; ,load test-buffer.scm 12 | 13 | (define (buff-string buff) 14 | (let ((cur-group (buffer-group buff))) 15 | (group-extract-string cur-group 16 | (group-start-index cur-group) 17 | (group-end-index cur-group)))) 18 | 19 | ;;; Make a mode for the buffer 20 | (define-major-mode buffer-editor #f "Edit Buffers" (lambda (buffer) buffer unspecific)) 21 | (check (major-mode? (name->mode 'buffer-editor)) => #t) 22 | 23 | ;;; Make a buffer 24 | (define foo-buff (make-buffer "test-case" (name->mode 'buffer-editor) "/tmp/foo.txt")) 25 | (check (buffer? foo-buff) => #t) 26 | 27 | ;;; Insert us some chars 28 | (group-insert-char! (buffer-group foo-buff) 0 #\H) 29 | (group-insert-char! (buffer-group foo-buff) 1 #\e) 30 | (group-insert-char! (buffer-group foo-buff) 2 #\l) 31 | (group-insert-char! (buffer-group foo-buff) 3 #\l) 32 | (group-insert-char! (buffer-group foo-buff) 4 #\o) 33 | 34 | ;;; Add a string and a touch of salt 35 | (group-insert-string! (buffer-group foo-buff) 5 " World!") 36 | 37 | ;;; Take it out of the oven ... 38 | (check (string=? (buff-string foo-buff) "Hello World!") => #t) 39 | 40 | ;;; Make up for the fact that we don't have the giant 'state soup' 41 | (define (current-point) (make-mark (buffer-group foo-buff) 0)) 42 | 43 | ;;; Undo! 44 | (undo-one-step foo-buff (undo-start foo-buff)) 45 | 46 | ;;; And we're back 47 | (check (string=? (buff-string foo-buff) "") => #t) 48 | 49 | ;;; Do some more talkie 50 | (group-insert-string! (buffer-group foo-buff) 0 "Watson Come Here, I Want You") 51 | 52 | ;;; Did he come over? 53 | (check (string=? (buff-string foo-buff) "Watson Come Here, I Want You") => #t) -------------------------------------------------------------------------------- /tests/1d-table-tests.scm: -------------------------------------------------------------------------------- 1 | (define (message caller expect result) 2 | (newline) 3 | (display (format #f "~a should return ~a, returned ~a instead.~%" 4 | caller expect result))) 5 | 6 | (define table (make-1d-table)) 7 | 8 | (define (run-1d-table-test) 9 | (let ((expect #t) 10 | (result (1d-table? table))) 11 | (if (not result) 12 | (message '1d-table? expect result))) 13 | 14 | (1d-table/put! table 'foo 'bar) 15 | (1d-table/put! table 'abc 'def) 16 | (let* ((value (1d-table/alist table)) 17 | (expect '((foo . bar) (abc . def))) 18 | (result (equal? expect value))) 19 | (if (not result) 20 | (message '1d-table/alist expect result))) 21 | 22 | (1d-table/remove! table 'foo) 23 | (let* ((value (1d-table/alist table)) 24 | (expect '((abc . def))) 25 | (result (equal? expect value))) 26 | (if (not result) 27 | (message '1d-table/remove! expect result))) 28 | 29 | (let* ((value (1d-table/get table 'abc 'discard)) 30 | (expect 'def) 31 | (result (equal? expect value))) 32 | (if (not result) 33 | (message '1d-table/get expect result))) 34 | 35 | (let* ((value (1d-table/get table 'foo 'default)) 36 | (expect 'default) 37 | (result (equal? expect value))) 38 | (if (not result) 39 | (message '1d-table/get-with-default expect result))) 40 | 41 | (let* ((if-found (lambda (x) 'success)) 42 | (if-not-found (lambda (x) 'fail)) 43 | (value (1d-table/lookup 44 | table 'abc if-found if-not-found)) 45 | (expect 'success) 46 | (result (equal? expect value))) 47 | (if (not result) 48 | (message '1d-table/lookup expect result))) 49 | 50 | (1d-table/remove! table 'abc) 51 | (let* ((value (1d-table/alist table)) 52 | (result (null? value))) 53 | (if (not result) 54 | (message '1d-table/remove! '() result)))) -------------------------------------------------------------------------------- /edwin48/srfi-69.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: srfi-69 -*- 2 | ;;; 3 | ;;; SRFI 69: Basic hash tables 4 | ;;; 5 | 6 | (define* (make-hash-table (equal? equal?) (hash hash)) 7 | ((make-table-maker equal? hash))) 8 | 9 | (define (hash-table? t) (table? t)) 10 | 11 | (define* (alist->hash-table alist (equal? equal?) (hash hash)) 12 | (let ((table (make-hash-table equal? hash))) 13 | (for-each (lambda (x) (hash-table-set! table (car x) (cdr x))) 14 | alist) 15 | table)) 16 | 17 | (define (hash-table-ref table key . thunk) 18 | (let ((value (table-ref table key))) 19 | (if (eq? value #f) 20 | (if (null? thunk) (error "key not found") ((car thunk))) 21 | value))) 22 | 23 | (define (hash-table-ref/default table key default) 24 | (hash-table-ref table key (lambda () default))) 25 | 26 | (define (hash-table-set! table key value) 27 | (table-set! table key value)) 28 | 29 | (define (hash-table-delete! table key) 30 | (table-set! table key #f)) 31 | 32 | (define (hash-table-exists? table key) 33 | (hash-table-ref table key (lambda () #f))) 34 | 35 | (define (hash-table-size table) 36 | (let ((size 0)) 37 | (table-walk 38 | (lambda (k v) (set! size (+ size 1))) 39 | table) 40 | size)) 41 | 42 | (define (hash-table-keys table) 43 | (let ((keys '())) 44 | (table-walk 45 | (lambda (k v) (set! keys (cons k keys))) 46 | table) 47 | keys)) 48 | 49 | (define (hash-table-values table) 50 | (let ((values '())) 51 | (table-walk 52 | (lambda (k v) (set! values (cons v values))) 53 | table) 54 | values)) 55 | 56 | (define (hash-table-walk table proc) 57 | (table-walk proc table)) 58 | 59 | (define (hash-table->alist table) 60 | (let ((alist '())) 61 | (table-walk 62 | (lambda (k v) (set! alist (cons (list k v) alist))) 63 | table) 64 | alist)) 65 | 66 | (define (hash-table-copy table) 67 | (let ((copy (make-hash-table))) 68 | (table-walk 69 | (lambda (k v) (hash-table-set! copy k v)) 70 | table) 71 | copy)) 72 | -------------------------------------------------------------------------------- /edwin48/scsh/weak-pair.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: weak-pair -*- 2 | 3 | (define-record-type* weak-pair 4 | (make-weak-pair (car) (cdr)) 5 | ()) 6 | 7 | (define (weak-cons car cdr) 8 | (make-weak-pair (make-weak-pointer car) cdr)) 9 | 10 | (define (weak-pair/car? pair) 11 | (weak-pointer-ref (weak-pair-car pair))) 12 | 13 | (define (weak-car pair) 14 | (if (weak-pair/car? pair) 15 | (weak-pointer-ref (weak-pair-car pair)) 16 | #f)) 17 | 18 | (define (weak-set-car! pair obj) 19 | (if (weak-pair? pair) 20 | (set-weak-pair-car! pair (make-weak-pointer obj)))) 21 | 22 | (define (weak-cdr pair) (weak-pair-cdr pair)) 23 | 24 | (define (weak-set-cdr! pair obj) 25 | (set-weak-pair-cdr! pair obj)) 26 | 27 | (define (weak-memq x weaks) 28 | (if (null? weaks) 29 | #f 30 | (if (eq? x (weak-pointer-ref (weak-car weaks))) 31 | weaks 32 | (weak-memq x (weak-cdr weaks))))) 33 | 34 | (define (weak-assq item alist) 35 | (let loop ((alist alist)) 36 | (and (not (null? alist)) 37 | (if (eq? (weak-car (car alist)) item) 38 | (car alist) 39 | (loop (cdr alist)))))) 40 | 41 | (define weak-pair/false "weak-pair/false") 42 | 43 | (define (weak-list->list items) 44 | (let loop ((items* items) (result '())) 45 | (if (weak-pair? items*) 46 | (loop (cdr items*) 47 | (let ((item (car items*))) 48 | (if (not item) 49 | result 50 | (cons (if (eq? item weak-pair/false) #f item) 51 | result)))) 52 | (begin 53 | (if (not (null? items*)) 54 | (error:not-weak-list items 'WEAK-LIST->LIST)) 55 | (reverse! result))))) 56 | 57 | (define (list->weak-list items) 58 | (let loop ((items* (reverse items)) (result '())) 59 | (if (pair? items*) 60 | (loop (cdr items*) 61 | (weak-cons (car items*) result)) 62 | (begin 63 | (if (not (null? items*)) 64 | (error:not-list items 'LIST->WEAK-LIST)) 65 | result)))) 66 | -------------------------------------------------------------------------------- /edwin48/srfi-66.scm: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 1993-2007 by Richard Kelsey and Jonathan Rees. See file COPYING. 2 | 3 | ; SRFI 66: Octet vectors 4 | 5 | (define (make-u8vector k fill) 6 | (make-byte-vector k fill)) 7 | 8 | (define u8vector? byte-vector?) 9 | 10 | (define (list->u8vector octets) 11 | (let* ((size (length octets)) 12 | (v (make-byte-vector size 0))) 13 | (do ((i 0 (+ 1 i)) 14 | (l octets (cdr l))) 15 | ((>= i size)) 16 | (byte-vector-set! v i (car l))) 17 | v)) 18 | 19 | (define (u8vector->list octets) 20 | (let loop ((n (byte-vector-length octets)) (r '())) 21 | (if (zero? n) 22 | r 23 | (loop (- n 1) (cons (byte-vector-ref octets (- n 1)) r))))) 24 | 25 | (define u8vector byte-vector) 26 | 27 | (define u8vector-length byte-vector-length) 28 | 29 | (define u8vector-ref byte-vector-ref) 30 | 31 | (define u8vector-set! byte-vector-set!) 32 | 33 | (define (u8vector-copy! source source-start target target-start count) 34 | (copy-bytes! source source-start target target-start count)) 35 | 36 | (define (u8vector-copy u8vector) 37 | (let* ((size (byte-vector-length u8vector)) 38 | (copy (make-byte-vector size 0))) 39 | (u8vector-copy! u8vector 0 copy 0 size) 40 | copy)) 41 | 42 | (define (u8vector=? u8vector-1 u8vector-2) 43 | (let ((size (byte-vector-length u8vector-1))) 44 | (and (= size (byte-vector-length u8vector-2)) 45 | (let loop ((i 0)) 46 | (or (>= i size) 47 | (and (= (byte-vector-ref u8vector-1 i) 48 | (byte-vector-ref u8vector-2 i)) 49 | (loop (+ 1 i)))))))) 50 | 51 | (define (u8vector-compare u8vector-1 u8vector-2) 52 | (let ((length-1 (u8vector-length u8vector-1)) 53 | (length-2 (u8vector-length u8vector-2))) 54 | (cond 55 | ((< length-1 length-2) -1) 56 | ((> length-1 length-2) 1) 57 | (else 58 | (let loop ((i 0)) 59 | (if (= i length-1) 60 | 0 61 | (let ((elt-1 (u8vector-ref u8vector-1 i)) 62 | (elt-2 (u8vector-ref u8vector-2 i))) 63 | (cond ((< elt-1 elt-2) -1) 64 | ((> elt-1 elt-2) 1) 65 | (else (loop (+ i 1))))))))))) 66 | -------------------------------------------------------------------------------- /edwin48/paths.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: paths.scm,v 1.23 2008/01/30 20:02:04 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Edwin Pathnames 29 | 30 | 31 | (define (edwin-library-directory-pathname envvar required?) 32 | (let ((envval (get-environment-variable envvar))) 33 | (if envval 34 | (pathname-as-directory (merge-pathnames envval)) 35 | (or (system-library-directory-pathname "edwin") 36 | (and required? 37 | (error "Can't find edwin library directory.")))))) 38 | 39 | (define (edwin-binary-directory) 40 | (edwin-library-directory-pathname "EDWIN_BINARY_DIRECTORY" #t)) 41 | 42 | (define (edwin-info-directory) 43 | (edwin-library-directory-pathname "EDWIN_INFO_DIRECTORY" #f)) 44 | 45 | (define (edwin-etc-directory) 46 | (edwin-library-directory-pathname "EDWIN_ETC_DIRECTORY" #t)) 47 | 48 | (define (edwin-etc-pathname filename) 49 | (let ((pathname (merge-pathnames filename (edwin-etc-directory)))) 50 | (if (not (file-exists? pathname)) 51 | (error "Unable to find file:" (->namestring pathname))) 52 | pathname)) 53 | 54 | (define (edwin-tutorial-pathname) 55 | (edwin-etc-pathname "TUTORIAL")) 56 | 57 | (define default-homedir-pathname 58 | ;; This binding exists to allow uses of the "home" directory as a 59 | ;; default directory to be overridden. 60 | user-homedir-pathname) -------------------------------------------------------------------------------- /edwin48/strpad.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: strpad.scm,v 1.14 2008/01/30 20:02:06 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; String Padding Stuff 29 | 30 | 31 | (define (pad-on-right-to string n) 32 | (let ((l (string-length string))) 33 | (if (> n l) 34 | (let ((result (make-string n))) 35 | (string-copy! result 0 string 0 l) 36 | (string-fill! result #\space l n) 37 | result) 38 | string))) 39 | 40 | (define (pad-on-left-to string n) 41 | (let ((l (string-length string))) 42 | (let ((delta (- n l))) 43 | (if (positive? delta) 44 | (let ((result (make-string n))) 45 | (string-fill! result #\space 0 delta) 46 | (string-copy! result delta string 0 l) 47 | result) 48 | string)))) 49 | 50 | (define* (write-strings-densely strings (port (current-output-port)) (x-size (terminal-x-size))) 51 | (let* ((n (reduce max 0 (map string-length strings))) 52 | (n-per-line (max 1 (quotient (+ x-size 1) (+ 2 n))))) 53 | (if (not (null? strings)) 54 | (let loop ((strings strings) (i 0)) 55 | (write-string (pad-on-right-to (car strings) n) port) 56 | (let ((strings (cdr strings)) 57 | (i (+ i 1))) 58 | (if (not (null? strings)) 59 | (if (< i n-per-line) 60 | (begin 61 | (write-string " " port) 62 | (loop strings i)) 63 | (begin 64 | (newline port) 65 | (loop strings 0))))))))) -------------------------------------------------------------------------------- /edwin48/scsh/char-support.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: char-support -*- 2 | ;;; 3 | ;;; Copies of some procedures on characters from MIT Scheme 4 | ;;; 5 | 6 | (define char-set/atom-delimiters 7 | (char-set-union char-set:whitespace 8 | ;; Note that #\, may break older code. 9 | (string->char-set "()[]{}\";'`,") 10 | ;; (char-set #\U+00AB #\U+00BB) 11 | )) 12 | 13 | (define (->name entries n) 14 | (let ((entry (assv n entries))) 15 | (and entry 16 | (cadr entry)))) 17 | 18 | (define* (char->name char (slashify? #f)) 19 | (let ((code (char->ascii char))) 20 | (string-append 21 | (cond ((->name named-codes code)) 22 | ((and slashify? 23 | (or (char=? char #\\) 24 | (char-set-contains? char-set/atom-delimiters char))) 25 | (string-append "\\" (string char))) 26 | ((char-set-contains? char-set:graphic char) 27 | (string char)) 28 | (else 29 | (string-append "U+" 30 | (let ((s (number->string code 16))) 31 | (string-pad s 32 | (let ((l (string-length s))) 33 | (let loop ((n 2)) 34 | (if (fix:<= l n) 35 | n 36 | (loop (fix:* 2 n))))) 37 | #\0)))))))) 38 | 39 | (define named-codes 40 | '((#x00 #f "null" "nul") 41 | (#x01 #f "soh") 42 | (#x02 #f "stx") 43 | (#x03 #f "etx") 44 | (#x04 #f "eot") 45 | (#x05 #f "enq") 46 | (#x06 #f "ack") 47 | (#x07 #f "bel") 48 | (#x08 "backspace" "bs") 49 | (#x09 "tab" "ht") 50 | (#x0A "newline" "linefeed" "lfd" "lf") 51 | (#x0B #f "vt") 52 | (#x0C "page" "ff" "np") 53 | (#x0D "return" "ret" "cr") 54 | (#x0E #f "so") 55 | (#x0F #f "si") 56 | (#x10 #f "dle") 57 | (#x11 #f "dc1") 58 | (#x12 #f "dc2") 59 | (#x13 #f "dc3") 60 | (#x14 #f "dc4") 61 | (#x15 #f "nak") 62 | (#x16 #f "syn") 63 | (#x17 #f "etb") 64 | (#x18 #f "can") 65 | (#x19 #f "em") 66 | (#x1A #f "sub" "call") 67 | (#x1B "escape" "esc" "altmode") 68 | (#x1C #f "fs") 69 | (#x1D #f "gs") 70 | (#x1E #f "rs") 71 | (#x1F #f "us" "backnext") 72 | (#x20 "space" "spc" "sp") 73 | (#x7F "delete" "del" "rubout") 74 | (#xA0 "nbsp") 75 | (#xFEFF "bom"))) 76 | -------------------------------------------------------------------------------- /edwin48/buttons.scm: -------------------------------------------------------------------------------- 1 | ;;;; Buttons 2 | 3 | (define-record-type button 4 | (%%make-button number bits down? symbol) 5 | button? 6 | (number button-number) 7 | (bits button-bits) 8 | (down? button-down?) 9 | (symbol button-symbol)) 10 | 11 | (define* (make-down-button number (bits 0)) 12 | (%make-button number bits #t 'make-down-button)) 13 | 14 | (define* (make-up-button number (bits 0)) 15 | (%make-button number bits #f 'make-up-button)) 16 | 17 | (define (%make-button number bits down? caller) 18 | (let ((name 19 | (symbol (bucky-bits->prefix bits) 20 | 'button- 21 | number 22 | (if down? '-down '-up)))) 23 | (hash-table/intern! buttons-table name 24 | (lambda () 25 | (%%make-button number bits down? name))))) 26 | 27 | (define buttons-table 28 | (make-hash-table eq?)) 29 | 30 | (define (down-button? object) 31 | (and (button? object) 32 | (button-down? object))) 33 | 34 | (define (up-button? object) 35 | (and (button? object) 36 | (not (button-down? object)))) 37 | 38 | (define (button-name button) 39 | (symbol-name (button-symbol button))) 40 | 41 | (define-record-type button-event 42 | (make-button-event window x y) 43 | button-event? 44 | (window button-event/window) 45 | (x button-event/x) 46 | (y button-event/y)) 47 | 48 | (define (current-button-event) 49 | (or (editor-button-event current-editor) 50 | ;; Create a "dummy" event at point. 51 | (let ((window (current-window))) 52 | (let ((coordinates (window-point-coordinates window))) 53 | (make-button-event window 54 | (car coordinates) 55 | (cdr coordinates)))))) 56 | 57 | (define (with-current-button-event button-event thunk) 58 | (let ((old-button-event unspecific)) 59 | (dynamic-wind 60 | (lambda () 61 | (set! old-button-event (editor-button-event current-editor)) 62 | (set-editor-button-event! current-editor button-event) 63 | (set! button-event #f) 64 | unspecific) 65 | thunk 66 | (lambda () 67 | (set-editor-button-event! current-editor old-button-event))))) 68 | 69 | (define button1-down (make-down-button 0)) 70 | (define button2-down (make-down-button 1)) 71 | (define button3-down (make-down-button 2)) 72 | (define button4-down (make-down-button 3)) 73 | (define button5-down (make-down-button 4)) 74 | (define button1-up (make-up-button 0)) 75 | (define button2-up (make-up-button 1)) 76 | (define button3-up (make-up-button 2)) 77 | (define button4-up (make-up-button 3)) 78 | (define button5-up (make-up-button 4)) -------------------------------------------------------------------------------- /edwin48/scrcom.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: scrcom.scm,v 1.14 2008/01/30 20:02:05 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Screen Commands 29 | 30 | 31 | (define-command delete-frame 32 | "Delete the frame that point is in." 33 | () 34 | (lambda () 35 | (if (null? (cdr (screen-list))) 36 | (editor-error "Can't delete the only frame.")) 37 | (delete-screen! (selected-screen)))) 38 | 39 | (define-command make-frame 40 | "Create a new frame, displaying the current buffer." 41 | () 42 | (lambda () (select-buffer-other-screen (current-buffer)))) 43 | 44 | (define-command other-frame 45 | "Select the ARG'th different visible frame, and raise it. 46 | All frames are arranged in a cyclic order. 47 | This command selects the frame ARG steps away in that order. 48 | A negative ARG moves in the opposite order." 49 | "p" 50 | (lambda (arg) 51 | (let ((screen (other-screen (selected-screen) arg))) 52 | (if (not screen) 53 | (editor-error "No other visible frame.")) 54 | (select-screen screen)))) 55 | 56 | (define-variable frame-name-format 57 | "If not false, template for displaying frame name. 58 | Has same format as `mode-line-format'." 59 | 'mode-line-buffer-identification) 60 | 61 | (define-variable frame-name-length 62 | "Maximum length of frame name. 63 | Used only if `frame-name-format' is non-false." 64 | 64 65 | exact-nonnegative-integer?) 66 | 67 | ;; For upwards compatibility: 68 | (define edwin-command$delete-screen edwin-command$delete-frame) 69 | (define edwin-variable$x-screen-name-format edwin-variable$frame-name-format) 70 | (define edwin-variable$x-screen-name-length edwin-variable$frame-name-length) -------------------------------------------------------------------------------- /edwin48/ring.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: ring.scm,v 1.18 2008/01/30 20:02:05 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Rings 29 | 30 | 31 | (define (ring-list ring) 32 | (list-copy (vector-ref ring 2))) 33 | 34 | (define (list-ref l i) 35 | (cond ((null? l) (error "Index too large" 'LIST-REF)) 36 | ((zero? i) (car l)) 37 | (else (list-ref (cdr l) (-1+ i))))) 38 | 39 | (define (list-set! l i o) 40 | (let loop ((l l) (i i)) 41 | (cond ((null? l) (error "index too large" i)) 42 | ((zero? i) (set-car! l o)) 43 | (else (list-ref (cdr l) (-1+ i))))) 44 | unspecific) 45 | 46 | (define (list-truncate! l i) 47 | (cond ((null? l) unspecific) 48 | ((= i 1) (set-cdr! l '())) 49 | (else (list-truncate! (cdr l) (-1+ i)))) 50 | unspecific) 51 | 52 | (define (make-ring size) 53 | (if (< size 1) 54 | (error "Ring size too small" size) 55 | (vector "Ring" size '()))) 56 | 57 | (define (ring-size ring) 58 | (length (vector-ref ring 2))) 59 | 60 | (define (ring-clear! ring) 61 | (vector-set! ring 2 '()) 62 | unspecific) 63 | 64 | (define (ring-empty? ring) 65 | (null? (vector-ref ring 2))) 66 | 67 | 68 | (define (ring-push! ring object) 69 | (vector-set! ring 2 (cons object (vector-ref ring 2))) 70 | (list-truncate! (vector-ref ring 2) (vector-ref ring 1))) 71 | 72 | (define (ring-pop! ring) 73 | (let ((l (vector-ref ring 2))) 74 | (if (null? l) 75 | (error "Ring empty" ring) 76 | (let ((object (car l))) 77 | (vector-set! ring 2 (append! (cdr l) (list object))) 78 | object)))) 79 | 80 | (define (ring-ref ring index) 81 | (list-ref (vector-ref ring 2) (modulo index (ring-size ring)))) 82 | 83 | (define (ring-set! ring index object) 84 | (list-set! (vector-ref ring 2) (modulo index (ring-size ring)) object)) 85 | -------------------------------------------------------------------------------- /edwin48/midas.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: midas.scm,v 1.28 2008/01/30 20:02:03 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Midas Mode 29 | 30 | 31 | (define-command midas-mode 32 | "Enter Midas mode." 33 | () 34 | (lambda () (set-current-major-mode! (ref-mode-object midas)))) 35 | 36 | (define-major-mode midas fundamental "Midas" 37 | "Major mode for editing assembly code." 38 | (lambda (buffer) 39 | (local-set-variable! syntax-table midas-mode:syntax-table buffer) 40 | (local-set-variable! comment-column 40 buffer) 41 | (local-set-variable! comment-locator-hook lisp-comment-locate buffer) 42 | (local-set-variable! comment-indent-hook midas-comment-indentation buffer) 43 | (local-set-variable! comment-start ";" buffer) 44 | (local-set-variable! comment-end "" buffer) 45 | (standard-alternate-paragraph-style! buffer) 46 | (local-set-variable! indent-line-procedure (ref-command insert-tab) buffer) 47 | (local-set-variable! local-abbrev-table 48 | (ref-variable midas-mode-abbrev-table buffer) 49 | buffer) 50 | (event-distributor/invoke! (ref-variable midas-mode-hook buffer) buffer))) 51 | 52 | (define midas-mode:syntax-table (make-char-syntax-table)) 53 | (set-char-syntax! midas-mode:syntax-table #\; "< ") 54 | (set-char-syntax! midas-mode:syntax-table #\newline "> ") 55 | (set-char-syntax! midas-mode:syntax-table #\. "w ") 56 | (set-char-syntax! midas-mode:syntax-table #\' "' ") 57 | (set-char-syntax! midas-mode:syntax-table #\$ "' ") 58 | (set-char-syntax! midas-mode:syntax-table #\% "' ") 59 | (set-char-syntax! midas-mode:syntax-table #\# "' ") 60 | 61 | (define (midas-comment-indentation mark) 62 | (if (match-forward ";;;" mark) 63 | 0 64 | (max (+ (mark-column (horizontal-space-start mark)) 1) 65 | (ref-variable comment-column mark)))) -------------------------------------------------------------------------------- /edwin48/scsh/event-distributor.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: scheme; scheme48-package: event-distributor -*- 2 | ;;; 3 | ;;; Port MIT Scheme's event distributor (events.scm) to Scheme48 4 | ;;; 5 | 6 | (define-record-type* event-distributor 7 | (%make-event-distributor events (lock) (receivers)) 8 | ()) 9 | 10 | (define (make-event-distributor) 11 | (%make-event-distributor (make-queue) #f '())) 12 | 13 | (define (make-receiver-modifier keyword) 14 | (lambda (event-distributor receiver) 15 | (if (not (event-distributor? event-distributor)) 16 | (error "Not an event distributor" event-distributor)) 17 | (enqueue! (event-distributor-events event-distributor) 18 | (cons keyword receiver)) 19 | (process-events! event-distributor))) 20 | 21 | (define (event-distributor/invoke! event-distributor . arguments) 22 | (enqueue! (event-distributor-events event-distributor) 23 | (cons 'INVOKE-RECEIVERS arguments)) 24 | (process-events! event-distributor)) 25 | 26 | (define add-event-receiver! (make-receiver-modifier 'ADD-RECEIVER)) 27 | (define remove-event-receiver! (make-receiver-modifier 'REMOVE-RECEIVER)) 28 | 29 | (define (process-events! event-distributor) 30 | (let ((old-lock unspecific)) 31 | (dynamic-wind 32 | (lambda () 33 | (let ((lock (event-distributor-lock event-distributor))) 34 | (set-event-distributor-lock! event-distributor #t) 35 | (set! old-lock lock) 36 | unspecific)) 37 | (lambda () 38 | (if (not old-lock) 39 | (queue-map! (event-distributor-events event-distributor) 40 | (lambda (event) 41 | (case (car event) 42 | ((INVOKE-RECEIVERS) 43 | (do ((receivers 44 | (event-distributor-receivers event-distributor) 45 | (cdr receivers))) 46 | ((null? receivers)) 47 | (apply (car receivers) (cdr event)))) 48 | ((ADD-RECEIVER) 49 | (let ((receiver (cdr event)) 50 | (receivers 51 | (event-distributor-receivers event-distributor))) 52 | (if (not (memv receiver receivers)) 53 | (set-event-distributor-receivers! 54 | event-distributor 55 | (append! receivers (list receiver)))))) 56 | ((REMOVE-RECEIVER) 57 | (set-event-distributor-receivers! 58 | event-distributor 59 | (delete! (cdr event) 60 | (event-distributor-receivers event-distributor) 61 | eqv?))) 62 | (else 63 | (error "Illegal event" event))))))) 64 | (lambda () 65 | (set-event-distributor-lock! event-distributor old-lock))))) 66 | 67 | (define (queue-map! queue procedure) 68 | (let ((empty (list 'EMPTY))) 69 | (let loop () 70 | (let ((item 71 | (without-interrupts 72 | (lambda () 73 | (if (queue-empty? queue) 74 | empty 75 | (dequeue! queue)))))) 76 | (if (not (eq? item empty)) 77 | (begin 78 | (procedure item) 79 | (loop))))))) -------------------------------------------------------------------------------- /edwin48/edtstr.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: edtstr.scm,v 1.36 2008/01/30 20:02:00 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Editor Data Abstraction 29 | 30 | 31 | (define-record-type* editor 32 | (%make-editor name 33 | display-type 34 | (screens) 35 | (selected-screen) 36 | bufferset 37 | char-history 38 | halt-update? 39 | peek-no-hang 40 | peek 41 | read 42 | (button-event) 43 | (select-time)) 44 | ()) 45 | 46 | 47 | (define (make-editor name display-type make-screen-args) 48 | (let ((initial-buffer 49 | (make-buffer initial-buffer-name 50 | (ref-mode-object fundamental) 51 | (working-directory-pathname)))) 52 | (let ((bufferset (make-bufferset initial-buffer)) 53 | (screen (display-type/make-screen display-type make-screen-args))) 54 | (initialize-screen-root-window! screen bufferset initial-buffer) 55 | (call-with-values 56 | (lambda () (display-type/get-input-operations display-type screen)) 57 | (lambda (halt-update? peek-no-hang peek read) 58 | (%make-editor name 59 | display-type 60 | (list screen) 61 | screen 62 | bufferset 63 | (make-ring 100) 64 | halt-update? 65 | peek-no-hang 66 | peek 67 | read 68 | #f 69 | 1)))))) 70 | 71 | (define (current-display-type) 72 | (editor-display-type current-editor)) 73 | 74 | (define (with-editor-interrupts-enabled thunk) 75 | (display-type/with-interrupts-enabled (current-display-type) thunk)) 76 | 77 | (define (with-editor-interrupts-disabled thunk) 78 | (display-type/with-interrupts-disabled (current-display-type) thunk)) 79 | 80 | (define (current-bufferset) 81 | (editor-bufferset current-editor)) 82 | 83 | (define (current-char-history) 84 | (editor-char-history current-editor)) 85 | 86 | (define (increment-select-time!) 87 | (let ((time (editor-select-time current-editor))) 88 | (set-editor-select-time! current-editor (1+ time)) 89 | time)) 90 | 91 | -------------------------------------------------------------------------------- /edwin48/scsh/pathname-scsh.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: pathname -*- 2 | 3 | (initialize-pathnames! 'unix unix/origin-expansion unix/origin-expander) 4 | 5 | (define (->namestring pathname) 6 | (pathname-namestring pathname)) 7 | 8 | (define (->pathname object) 9 | (maybe-object->pathname object)) 10 | 11 | (define (pathname=? pathname1 pathname2) 12 | (pathname-eq? pathname1 pathname2)) 13 | 14 | (define (pathname-name pathname) 15 | (pathname-filename pathname)) 16 | 17 | (define (pathname-absolute? pathname) 18 | (if (pathname-origin pathname) #t #f)) 19 | 20 | (define (pathname-wild? pathname) 21 | (let ((wild? (lambda (name) (string=? "*" name)))) 22 | (any wild? (pathname-namelist pathname)))) 23 | 24 | (define (file-pathname pathname) 25 | (make-pathname #f #f (pathname-filename pathname))) 26 | 27 | (define (directory-pathname pathname) 28 | (make-pathname #f (pathname-directory pathname) #f)) 29 | 30 | (define (directory-pathname-as-file pathname) 31 | (make-filename )) 32 | 33 | (define (pathname-new-directory pathname directory) 34 | (pathname-with-directory pathname directory)) 35 | 36 | (define (pathname-new-type pathname type) 37 | (let* ((base (filename-base pathname)) 38 | (new-name (make-filename base type))) 39 | (pathname-with-filename pathname new-name))) 40 | 41 | (define (pathname-default-name pathname name) 42 | (if (eq? #f (pathname-filename pathname)) 43 | (pathname-with-filename pathname name) 44 | pathname)) 45 | 46 | (define (pathname-default-directory pathname directory) 47 | (if (eq? #f (pathname-directory pathname)) 48 | (pathname-with-directory pathname directory) 49 | pathname)) 50 | 51 | (define (pathname-type pathname) 52 | (if (filename? pathname) 53 | (filename-type pathname) 54 | (error "type is not available" pathname))) 55 | 56 | (define (pathname-version pathname) 57 | (if (filename? pathname) 58 | (filename-version pathname) 59 | (error "version is not available" pathname))) 60 | 61 | (define (user-homedir-pathname) 62 | (let ((user (user-id->user-info (get-user-id)))) 63 | (user-info-home-directory-pathname user))) 64 | 65 | (define (system-library-directory-pathname pathname) 66 | (->pathname "edwin")) 67 | 68 | (define (working-directory-pathname) 69 | (->pathname (cwd))) 70 | 71 | ;;; Originally from MIT Scheme 72 | (define (pathname-simplify pathname) 73 | (define (delete-up directory p) 74 | (let loop ((p* directory)) 75 | (if (eq? p* p) 76 | (cddr p*) 77 | (cons (car p*) (loop (cdr p*)))))) 78 | (if (pair? (pathname-directory pathname)) 79 | (let loop ((pathname pathname) (np 1)) 80 | (let ((directory (pathname-directory pathname))) 81 | (let scan ((p (drop directory np)) (np np)) 82 | (if (pair? p) 83 | (if (and (not (equal? (car p) "..")) 84 | (pair? (cdr p)) 85 | (equal? (cadr p) "..")) 86 | (let ((pathname* 87 | (pathname-new-directory pathname 88 | (delete-up directory p)))) 89 | (if (file-eq? (directory-pathname pathname) 90 | (directory-pathname pathname*)) 91 | (loop pathname* np) 92 | (scan (cddr p) (+ np 2)))) 93 | (scan (cdr p) (+ np 1))) 94 | pathname)))) 95 | pathname)) 96 | 97 | -------------------------------------------------------------------------------- /edwin48/modwin.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: modwin.scm,v 1.48 2008/01/30 20:02:03 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Modeline Window 29 | 30 | 31 | (define-class modeline-window vanilla-window 32 | (shows-buffer-modified?)) 33 | 34 | (define (modeline-window/shows-buffer-modified? window) 35 | (with-instance-variables modeline-window window (shows-buffer-modified?) 36 | shows-buffer-modified?)) 37 | 38 | (define (set-modeline-window/shows-buffer-modified?! window value) 39 | (with-instance-variables modeline-window window (shows-buffer-modified?) 40 | (set! shows-buffer-modified? value))) 41 | 42 | (define-method modeline-window (:initialize! window window*) 43 | (with-instance-variables modeline-window window (y-size shows-buffer-modified?) 44 | (usual==> window :initialize! window*) 45 | (set! y-size 1) 46 | (set! shows-buffer-modified? #f))) 47 | 48 | (define (modeline-window:update-display! window screen x-start y-start 49 | xl xu yl yu display-style) 50 | display-style ;ignore 51 | (if (and (fix:= yl 0) (fix:< yl yu)) 52 | (let ((superior (window-superior window)) 53 | (xl (fix:+ x-start xl)) 54 | (xu (fix:+ x-start xu))) 55 | (let ((buffer (window-buffer superior))) 56 | (modeline-string! 57 | superior 58 | (screen-get-output-line 59 | screen y-start xl xu 60 | (ref-variable mode-line-inverse-video buffer)) 61 | xl xu) 62 | (set-modeline-window/shows-buffer-modified?! 63 | window 64 | (buffer-modified? buffer))))) 65 | #t) 66 | 67 | (define-method modeline-window :update-display! 68 | modeline-window:update-display!) 69 | 70 | (define-variable mode-line-inverse-video 71 | "True means use inverse video, or other suitable display mode, for the mode line." 72 | #t 73 | boolean?) 74 | 75 | (define (modeline-window:event! window type) 76 | type ;ignored 77 | (window-needs-redisplay! window)) 78 | 79 | (define (modeline-window:notice-changes! window) 80 | (if (not (boolean=? (buffer-modified? 81 | (window-buffer (window-superior window))) 82 | (modeline-window/shows-buffer-modified? window))) 83 | (window-needs-redisplay! window))) 84 | 85 | ;; 86 | ;; Local Variables: 87 | ;; eval: (put 'with-instance-variables 'scheme-indent-function 3) 88 | ;; End: 89 | ;; -------------------------------------------------------------------------------- /edwin48/comman.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: comman.scm,v 1.92 2008/01/30 20:01:59 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Commands and Variables 29 | 30 | 31 | (define-record-type* command 32 | (%make-command) 33 | (name 34 | %description 35 | interactive-specification 36 | procedure)) 37 | 38 | (define (command-description command) 39 | (let ((desc (command-%description command))) 40 | (if (description? desc) 41 | desc 42 | (let ((new (->doc-string (symbol-name (command-name command)) desc))) 43 | (if new 44 | (set-command-%description! command new)) 45 | new)))) 46 | 47 | (define (command-name-string command) 48 | (editor-name/internal->external (symbol-name (command-name command)))) 49 | 50 | (define (editor-name/internal->external string) 51 | string) 52 | 53 | (define (editor-name/external->internal string) 54 | string) 55 | 56 | (define (make-command name description specification procedure) 57 | (let* ((sname (symbol-name name)) 58 | (command 59 | (or (string-table-get editor-commands sname) 60 | (let ((command (%make-command))) 61 | (string-table-put! editor-commands sname command) 62 | command)))) 63 | (set-command-name! command name) 64 | (set-command-%description! command (doc-string->posn sname description)) 65 | (set-command-interactive-specification! command specification) 66 | (set-command-procedure! command procedure) 67 | command)) 68 | 69 | (define editor-commands 70 | (make-string-table 500)) 71 | 72 | (define* (name->command name (if-undefined 'INTERN)) 73 | (or (string-table-get editor-commands (symbol-name name)) 74 | (case if-undefined 75 | ((#F) #f) 76 | ((ERROR) (error "Undefined command:" name)) 77 | ((INTERN) 78 | (letrec ((command 79 | (make-command 80 | name 81 | "undefined command" 82 | '() 83 | (lambda () (editor-error "Undefined command:" name))))) 84 | command)) 85 | (else 86 | (error:bad-range-argument if-undefined 'NAME->COMMAND))))) 87 | 88 | (define (->command object) 89 | (if (command? object) 90 | object 91 | (name->command object))) 92 | 93 | (define (copy-command new-name command) 94 | (make-command new-name 95 | (command-%description command) 96 | (command-interactive-specification command) 97 | (command-procedure command))) 98 | 99 | -------------------------------------------------------------------------------- /edwin48/bufout.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: bufout.scm,v 1.20 2008/01/30 20:01:58 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Buffer Output Ports 29 | ;;; Package: (edwin buffer-output-port) 30 | 31 | 32 | (define (with-output-to-mark mark thunk) 33 | (call-with-output-mark mark 34 | (lambda (port) 35 | (with-output-to-port port thunk)))) 36 | 37 | (define (call-with-output-mark mark procedure) 38 | (let ((port (mark->output-port mark))) 39 | (let ((value (procedure port))) 40 | (operation/close port) 41 | value))) 42 | 43 | (define (mark->output-port mark #!optional buffer) 44 | (make-port mark-output-port-type 45 | (cons (mark-left-inserting-copy mark) 46 | (if (default-object? buffer) 47 | #f 48 | buffer)))) 49 | 50 | (define (output-port->mark port) 51 | (mark-temporary-copy (port/mark port))) 52 | 53 | (define (port/mark port) 54 | (car (port/state port))) 55 | 56 | (define (port/buffer port) 57 | (cdr (port/state port))) 58 | 59 | (define (operation/flush-output port) 60 | (let ((mark (port/mark port)) 61 | (buffer (port/buffer port))) 62 | (if buffer 63 | (for-each (if (mark= mark (buffer-point buffer)) 64 | (lambda (window) 65 | (set-window-point! window mark) 66 | (window-direct-update! window #f)) 67 | (lambda (window) 68 | (window-direct-update! window #f))) 69 | (buffer-windows buffer))))) 70 | 71 | (define (operation/write-self port output) 72 | (write-string " to buffer at " output) 73 | (write (port/mark port) output)) 74 | 75 | (define (operation/write-char port char) 76 | (guarantee-8-bit-char char) 77 | (region-insert-char! (port/mark port) char) 78 | 1) 79 | 80 | (define (operation/write-substring port string start end) 81 | (region-insert-substring! (port/mark port) string start end) 82 | (fix:- end start)) 83 | 84 | (define (operation/close port) 85 | (mark-temporary! (port/mark port))) 86 | 87 | (define (operation/x-size port) 88 | (mark-x-size (port/mark port))) 89 | 90 | (define mark-output-port-type 91 | (make-port-type `((CLOSE ,operation/close) 92 | (FLUSH-OUTPUT ,operation/flush-output) 93 | (WRITE-CHAR ,operation/write-char) 94 | (WRITE-SELF ,operation/write-self) 95 | (WRITE-SUBSTRING ,operation/write-substring) 96 | (X-SIZE ,operation/x-size)) 97 | #f)) -------------------------------------------------------------------------------- /scratch/test-groups.scm: -------------------------------------------------------------------------------- 1 | (define-structure test-groups 2 | (export run-test) 3 | (open scheme 4 | formats 5 | srfi-13 6 | edwin:group 7 | edwin:region 8 | edwin:mark 9 | edwin:buffer 10 | edwin:motion) 11 | (begin 12 | 13 | (define (print . stuff) 14 | (for-each 15 | (lambda (s) (display s) (newline)) 16 | stuff)) 17 | 18 | (define (print-group group) 19 | (print 20 | (group-extract-string group 21 | (group-start-index group) 22 | (group-end-index group)))) 23 | 24 | (define (run-test) 25 | (newline) 26 | (display "Should print \"Hello\": ") 27 | (test-group-insert-char) 28 | (newline) 29 | 30 | (display "Should print \"Hello World.\": ") 31 | (test-group-region-transform) 32 | (newline) 33 | 34 | (display "Should print \"Hello!(x3)\": ") 35 | (test-region-insert) 36 | (newline) 37 | 38 | (display "Testing line-start+end:\n") 39 | (test-line-start+end) 40 | (newline)) 41 | 42 | (define (test-group-insert-char) 43 | (let* ((buffer (make-buffer)) 44 | (group (make-group buffer))) 45 | (set-buffer-group! buffer group) 46 | (group-insert-char! (buffer-group buffer) 0 #\H) 47 | (group-insert-char! (buffer-group buffer) 1 #\e) 48 | (group-insert-char! (buffer-group buffer) 2 #\l) 49 | (group-insert-char! (buffer-group buffer) 3 #\l) 50 | (group-insert-char! (buffer-group buffer) 4 #\o) 51 | (print-group group))) 52 | 53 | (define (test-group-region-transform) 54 | (let* ((buffer (make-buffer)) 55 | (group (make-group buffer)) 56 | (_ (set-buffer-group! buffer group)) 57 | (_ (group-insert-string! group 0 "Hello dlroW.")) 58 | (left-mark (make-mark group 6)) 59 | (right-mark (make-mark group 11)) 60 | (region (make-region left-mark right-mark)) 61 | (_ (region-transform! region string-reverse))) 62 | (print-group group))) 63 | 64 | (define (test-region-insert) 65 | (let* ((buffer (make-buffer)) 66 | (group (make-group buffer)) 67 | (_ (set-buffer-group! buffer group)) 68 | (_ (group-insert-string! group 0 "Hello!")) 69 | (left-mark (make-mark group 0)) 70 | (right-mark (make-mark group 6)) 71 | (region (make-region left-mark right-mark))) 72 | (region-insert! right-mark region) 73 | (region-insert! right-mark region) 74 | (region-insert! right-mark region) 75 | (print-group group))) 76 | 77 | (define (test-line-start+end) 78 | (let* ((buffer (make-buffer)) 79 | (group (make-group buffer)) 80 | (_ (set-buffer-group! buffer group)) 81 | (_ (group-insert-string! group 0 "aaaaa\nbbbbb\nccccc\nddddd")) 82 | (left-mark (make-mark group 3)) 83 | (right-mark (make-mark group 14))) 84 | (cond ((not (equal? (mark-index (line-start right-mark 0)) 12)) 85 | (display "Error, should have been 12\n")) 86 | ((not (equal? (mark-index (line-end right-mark -1)) 11)) 87 | (display "Error, should have been 11\n")) 88 | ((not (equal? (mark-index (line-start left-mark 2)) 12)) 89 | (display "Error, should have been 12\n")) 90 | ((not (equal? (mark-index (line-end left-mark 3)) 23)) 91 | (display "Error, should have been 23\n")) 92 | (else 93 | (display "All line-start+end tests passed"))))) 94 | ) 95 | ) -------------------------------------------------------------------------------- /edwin48/bufinp.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: bufinp.scm,v 1.17 2008/01/30 20:01:58 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Buffer Input Ports 29 | 30 | 31 | (define (with-input-from-mark mark thunk #!optional receiver) 32 | (let ((port (make-buffer-input-port mark (group-end mark)))) 33 | (let ((value (with-input-from-port port thunk))) 34 | (if (default-object? receiver) 35 | value 36 | (receiver value (input-port/mark port)))))) 37 | 38 | (define (with-input-from-region region thunk) 39 | (with-input-from-port 40 | (make-buffer-input-port (region-start region) (region-end region)) 41 | thunk)) 42 | 43 | (define (call-with-input-mark mark procedure) 44 | (procedure (make-buffer-input-port mark (group-end mark)))) 45 | 46 | (define (call-with-input-region region procedure) 47 | (procedure 48 | (make-buffer-input-port (region-start region) (region-end region)))) 49 | 50 | (define (make-buffer-input-port start end) 51 | ;; This uses indices, so it can only be used locally 52 | ;; where there is no buffer-modification happening. 53 | (make-port buffer-input-port-type 54 | (make-bstate (mark-group start) 55 | (mark-index start) 56 | (mark-index end)))) 57 | 58 | (define (input-port/mark port) 59 | (let ((operation (port/operation port 'BUFFER-MARK))) 60 | (if (not operation) 61 | (error:bad-range-argument port 'INPUT-PORT/MARK)) 62 | (operation port))) 63 | 64 | (define-structure bstate 65 | (group #f read-only #t) 66 | (start #f) 67 | (end #f read-only #t)) 68 | 69 | (define buffer-input-port-type 70 | (make-port-type 71 | `((BUFFER-MARK 72 | ,(lambda (port) 73 | (let ((state (port/state port))) 74 | (make-mark (bstate-group state) 75 | (if (port/unread port) 76 | (- (bstate-start state) 1) 77 | (bstate-start state)))))) 78 | (CHAR-READY? 79 | ,(lambda (port) 80 | (let ((state (port/state port))) 81 | (fix:< (bstate-start state) 82 | (bstate-end state))))) 83 | (READ-CHAR 84 | ,(lambda (port) 85 | (let ((state (port/state port))) 86 | (let ((start (bstate-start state))) 87 | (if (fix:< start (bstate-end state)) 88 | (let ((char (group-right-char (bstate-group state) start))) 89 | (set-bstate-start! state (fix:+ start 1)) 90 | char) 91 | (eof-object)))))) 92 | (WRITE-SELF 93 | ,(lambda (port output) 94 | (write-string " from buffer at " output) 95 | (write (input-port/mark port) output)))) 96 | #f)) -------------------------------------------------------------------------------- /edwin48/display.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: display.scm,v 1.13 2008/01/30 20:02:00 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Display-Type Abstraction 29 | ;;; package: (edwin display-type) 30 | 31 | 32 | (define-record-type* display-type 33 | (%make-display-type 34 | name 35 | multiple-screens? 36 | operation/available? 37 | operation/make-screen 38 | operation/get-input-operations 39 | operation/with-display-grabbed 40 | operation/with-interrupts-enabled 41 | operation/with-interrupts-disabled) 42 | ()) 43 | 44 | (define (display-type/name display-type) 45 | (display-type-name display-type)) 46 | (define (display-type/multiple-screens? display-type) 47 | (display-type-multiple-screens? display-type)) 48 | 49 | (define (make-display-type name 50 | multiple-screens? 51 | available? 52 | make-screen 53 | get-input-operations 54 | with-display-grabbed 55 | with-interrupts-enabled 56 | with-interrupts-disabled) 57 | (let ((display-type 58 | (%make-display-type name 59 | multiple-screens? 60 | available? 61 | make-screen 62 | get-input-operations 63 | with-display-grabbed 64 | with-interrupts-enabled 65 | with-interrupts-disabled))) 66 | (set! display-types (cons display-type display-types)) 67 | display-type)) 68 | 69 | (define display-types '()) 70 | 71 | (define (display-type/available? display-type) 72 | ((display-type-operation/available? display-type))) 73 | 74 | (define (display-type/make-screen display-type args) 75 | (apply (display-type-operation/make-screen display-type) args)) 76 | 77 | (define (display-type/get-input-operations display-type screen) 78 | ((display-type-operation/get-input-operations display-type) screen)) 79 | 80 | (define (display-type/with-display-grabbed display-type thunk) 81 | ((display-type-operation/with-display-grabbed display-type) thunk)) 82 | 83 | (define (display-type/with-interrupts-enabled display-type thunk) 84 | ((display-type-operation/with-interrupts-enabled display-type) thunk)) 85 | 86 | (define (display-type/with-interrupts-disabled display-type thunk) 87 | ((display-type-operation/with-interrupts-disabled display-type) thunk)) 88 | 89 | (define (editor-display-types) 90 | (filter display-type/available? display-types)) 91 | 92 | (define (name->display-type name) 93 | (let ((display-type 94 | (find (lambda (display-type) 95 | (eq? name (display-type/name display-type))) 96 | display-types))) 97 | display-type)) -------------------------------------------------------------------------------- /missing: -------------------------------------------------------------------------------- 1 | %exit 2 | *defining-keyboard-macro?* 3 | *executing-keyboard-macro?* 4 | *unparse-with-maximum-readability?* 5 | ->environment 6 | abort-keyboard-macro 7 | add-gc-daemon!/no-restore 8 | auto-fill-break 9 | buffer-processes 10 | button-down? 11 | char-syntax 12 | cmdl-message/active 13 | cmdl-message/append 14 | cmdl-message/null 15 | cmdl-message/strings 16 | cmdl/start 17 | create-thread 18 | current-thread 19 | debug-scheme-error 20 | delete-auto-save-file! 21 | delete-process 22 | detach-thread 23 | do-auto-save 24 | edwin-command$backward-char 25 | edwin-command$end-kbd-macro 26 | edwin-command$expand-abbrev 27 | edwin-command$forward-char 28 | edwin-command$indent-according-to-mode 29 | edwin-mode$abbrev 30 | edwin-mode$auto-fill 31 | edwin-mode$fundamental 32 | edwin-variable$auto-save-interval 33 | edwin-variable$case-fold-search 34 | edwin-variable$editor-default-mode 35 | edwin-variable$enable-transcript-buffer 36 | edwin-variable$fill-prefix 37 | edwin-variable$indent-tabs-mode 38 | edwin-variable$syntax-table 39 | error-irritant/noise 40 | eval-with-history 41 | event:after-restore 42 | exit-current-thread 43 | get-buffer-process 44 | guarantee-command-loaded 45 | hangup-process 46 | identify-world 47 | initial-buffer-name 48 | interrupt-mask/gc-ok 49 | keyboard-macro-disable 50 | keyboard-macro-finalize-keys 51 | keyboard-macro-peek-key 52 | keyboard-macro-read-key 53 | keyboard-macro-write-key 54 | kill-buffer-interactive 55 | load-edwin-file 56 | make-button-event 57 | make-cmdl 58 | make-port 59 | make-port-type 60 | nearest-cmdl 61 | nearest-cmdl/port 62 | nearest-repl/environment 63 | os/init-file-name 64 | os/interprogram-cut 65 | os/interprogram-paste 66 | os/quit 67 | os/scheme-can-quit? 68 | os/truncate-filename-for-modeline 69 | process-kill-without-query 70 | process-list 71 | process-runnable? 72 | process-status 73 | prompt-for-buffer 74 | prompt-for-directory 75 | prompt-for-existing-buffer 76 | prompt-for-existing-file 77 | prompt-for-expression 78 | prompt-for-expression-value 79 | prompt-for-file 80 | re-compile-char-set 81 | read-from-string 82 | remap-alias-key 83 | save-buffer 84 | save-some-buffers 85 | set-process-buffer! 86 | signal-thread-event 87 | sleep-current-thread 88 | standard-error-handler 89 | start-inferior-repl! 90 | string->temporary-buffer 91 | substring-find-next-char-not-of-syntax 92 | thread-dead? 93 | ucode-primitive 94 | unblock-thread-events 95 | window? 96 | with-current-button-event 97 | with-interrupt-mask 98 | with-keyboard-macro-disabled 99 | with-notification-output-port 100 | with-output-to-temporary-buffer 101 | with-output-to-transcript-buffer 102 | within-continuation 103 | x-display-flush 104 | x-display-process-events 105 | -------------------------------------------------------------------------------- /edwin48/variable.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: edwin48:variable -*- 2 | ;;; 3 | ;;; Edwin variables 4 | ;;; 5 | 6 | (define-record-type* variable 7 | (%make-variable) 8 | (name 9 | %description 10 | %value 11 | buffer-local? 12 | initial-value 13 | %default-value 14 | assignment-daemons 15 | value-validity-test 16 | value-normalization)) 17 | 18 | (define (variable-description variable) 19 | (let ((desc (variable-%description variable))) 20 | (if (description? desc) 21 | desc 22 | (let ((new (->doc-string (symbol-name (variable-name variable)) desc))) 23 | (if new 24 | (set-variable-%description! variable new)) 25 | new)))) 26 | 27 | (define variable-value variable-%value) 28 | (define variable-default-value variable-%default-value) 29 | 30 | (define (variable-name-string variable) 31 | (editor-name/internal->external (symbol-name (variable-name variable)))) 32 | 33 | (define* (make-variable name description value buffer-local? 34 | (test #f) (normalization #f)) 35 | (let* ((sname (symbol-name name)) 36 | (variable 37 | (or (string-table-get editor-variables sname) 38 | (let ((variable (%make-variable))) 39 | (string-table-put! editor-variables sname variable) 40 | variable)))) 41 | (set-variable-name! variable name) 42 | (set-variable-%description! variable (doc-string->posn sname description)) 43 | (set-variable-%value! variable value) 44 | (set-variable-buffer-local?! variable buffer-local?) 45 | (set-variable-initial-value! variable value) 46 | (set-variable-%default-value! variable value) 47 | (set-variable-assignment-daemons! variable '()) 48 | (set-variable-value-validity-test! variable test) 49 | (set-variable-value-normalization! variable normalization) 50 | variable)) 51 | 52 | (define (make-variable-buffer-local! variable) 53 | (set-variable-buffer-local?! variable #t)) 54 | 55 | (define (normalize-variable-value variable value) 56 | (if (and (variable-value-validity-test variable) 57 | (not ((variable-value-validity-test variable) value))) 58 | (editor-error "Invalid value for " (variable-name-string variable) 59 | ": " value)) 60 | (if (variable-value-normalization variable) 61 | ((variable-value-normalization variable) value) 62 | value)) 63 | 64 | (define (add-variable-assignment-daemon! variable daemon) 65 | (let ((daemons (variable-assignment-daemons variable))) 66 | (if (not (memq daemon daemons)) 67 | (set-variable-assignment-daemons! variable (cons daemon daemons))))) 68 | 69 | (define (invoke-variable-assignment-daemons! buffer variable) 70 | (if within-editor? 71 | (do ((daemons (variable-assignment-daemons variable) (cdr daemons))) 72 | ((null? daemons)) 73 | ((car daemons) buffer variable)))) 74 | 75 | (define editor-variables 76 | (make-string-table 50)) 77 | 78 | (define* (name->variable name (if-undefined 'INTERN)) 79 | (or (string-table-get editor-variables (symbol-name name)) 80 | (case if-undefined 81 | ((#F) #f) 82 | ((ERROR) (error "Undefined variable:" name)) 83 | ((INTERN) (make-variable name "" #f #f)) 84 | (else (error:bad-range-argument if-undefined 'NAME->VARIABLE))))) 85 | 86 | (define (->variable object) 87 | (if (variable? object) 88 | object 89 | (name->variable object))) 90 | 91 | (define (variable-permanent-local! variable) 92 | (hash-table-set! permanent-local-variables variable #t)) 93 | 94 | (define (variable-permanent-local? variable) 95 | (hash-table-ref/default permanent-local-variables variable #f)) 96 | 97 | (define permanent-local-variables 98 | (make-hash-table eq?)) 99 | 100 | -------------------------------------------------------------------------------- /tests/test-comtab.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: tests:comtab -*- 2 | ;;; 3 | ;;; Comtab tests 4 | ;;; 5 | 6 | ; Running in Scheme48: 7 | ; Run in edwin48/tests/ 8 | ; ,exec ,load load.scm 9 | ; ,config ,open edwin:command-table 10 | 11 | ;;; On the first day he created comtabs 12 | (define ass-mode (make-comtab)) 13 | (check (comtab? ass-mode) => #t) 14 | 15 | (define fundamental (make-comtab)) 16 | (check (comtab? fundamental) => #t) 17 | ;;; and it was good ... 18 | 19 | 20 | ;;; On the second day he created commands 21 | (define-command do-something "Does something" () (lambda () (display "Did something\n"))) 22 | (check (command? (name->command 'do-something)) => #t) 23 | 24 | (define-command do-nothing "Does nada" () (lambda () (display "Did nothing\n"))) 25 | (check (command? (name->command 'do-nothing)) => #t) 26 | 27 | (define-command do-me "Does Moi" () (lambda () (display "Did Moi\n"))) 28 | (check (command? (name->command 'do-me)) => #t) 29 | 30 | (define-command do-be "Or Not To Be" () (lambda () (display "To Be\n"))) 31 | (check (command? (name->command 'do-be)) => #t) 32 | 33 | (define-command prefix-key "Loops back for more keys" () (lambda () (display "Keyboard HUNGRY!\n"))) 34 | (check (command? (name->command 'prefix-key)) => #t) 35 | ;;; and it was good ... 36 | 37 | 38 | ;;; On the third day he created keys 39 | (define-key fundamental (kbd #\s) 'do-something) 40 | (check (comtab-get fundamental (kbd #\s)) => (name->command 'do-something)) 41 | 42 | (define-key ass-mode (kbd (ctrl #\s)) 'do-something) 43 | (check (comtab-get ass-mode (kbd (ctrl #\s))) => (name->command 'do-something)) 44 | 45 | (define-key fundamental (kbd #\n) 'do-nothing) 46 | (check (comtab-get fundamental (kbd #\n)) => (name->command 'do-nothing)) 47 | 48 | (define-key fundamental (kbd (ctrl #\n)) 'do-nothing) 49 | (check (comtab-get fundamental (kbd (ctrl #\n))) => (name->command 'do-nothing)) 50 | 51 | (define-key ass-mode (kbd (ctrl #\q)) 'do-nothing) 52 | (check (comtab-get ass-mode (kbd (ctrl #\q))) => (name->command 'do-nothing)) 53 | 54 | (define-key fundamental (kbd #\m) 'do-me) 55 | (check (comtab-get fundamental (kbd #\m)) => (name->command 'do-me)) 56 | 57 | (define-key ass-mode (kbd #\n) 'do-be) 58 | (check (comtab-get ass-mode (kbd #\n)) => (name->command 'do-be)) 59 | ;;; and it was good ... 60 | 61 | 62 | ;;; On the forth day he created prefix keys 63 | (define-prefix-key ass-mode (kbd (ctrl #\x))) 64 | (check (comtab? (hash-table-ref (comtab-table ass-mode) (kbd (ctrl #\x)))) => #t) 65 | 66 | (define-command find-file "Find file" () (lambda () (display "find\n"))) 67 | (check (command? (name->command 'find-file)) => #t) 68 | 69 | (define-prefix-key ass-mode (kbd (ctrl #\x) #\v)) 70 | (check (comtab? (comtab-get ass-mode (kbd (ctrl #\x) #\v))) => #t) 71 | 72 | (define-command vc-dir "Version Control Dir" () (lambda () (display "VC Dir\n"))) 73 | (check (command? (name->command 'vc-dir)) => #t) 74 | 75 | (define-key ass-mode (kbd (ctrl #\x) #\v #\v) 'vc-dir) 76 | (check (comtab-get ass-mode (kbd (ctrl #\x) #\v #\v)) => (name->command 'vc-dir)) 77 | ;;; and it was good ... 78 | 79 | 80 | ;;; On the fifth day he asked for help 81 | (check (comtab-key-bindings (list ass-mode fundamental) (name->command 'do-nothing)) 82 | (=> key=?) 83 | (list (kbd (ctrl #\n)) (kbd (ctrl #\q)))) 84 | ;;; The order of the comtabs determines the shadowing. So => 85 | ;;; C-q ass-mode 86 | ;;; C-n fundamental ('do-be in ass-mode shadows (kbd n) in fundamental) 87 | 88 | (check (comtab-key-bindings (list fundamental ass-mode) (name->command 'do-nothing)) 89 | (=> key=?) 90 | (list (kbd #\n) (kbd (ctrl #\n)) (kbd (ctrl #\q)))) 91 | ;;; Flipping them gets us different results => 92 | ;;; n fundamental 93 | ;;; C-n fundamental 94 | ;;; C-q ass-mode 95 | 96 | 97 | (check-report) -------------------------------------------------------------------------------- /edwin48/clscon.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: clscon.scm,v 1.17 2008/01/30 20:01:59 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Class/Object System: Class Constructor 29 | 30 | 31 | ;;; ****************************************************************** 32 | ;;; This software is intended for use in the Edwin window system only. 33 | ;;; Don't think about using it for anything else, since it is not, and 34 | ;;; likely will not ever, be supported as a part of the Scheme system. 35 | ;;; ****************************************************************** 36 | 37 | (define (make-class name superclass variables) 38 | (let ((entry (assq name class-descriptors)) 39 | (object-size 40 | (+ (length variables) 41 | (if superclass (class-object-size superclass) 1))) 42 | (transforms (make-instance-transforms superclass variables))) 43 | (let ((make-class 44 | (lambda () 45 | (let ((class 46 | (%make-class name 47 | superclass 48 | object-size 49 | transforms 50 | (cons '() 51 | (and superclass 52 | (class-methods superclass)))))) 53 | (named-structure/set-tag-description! class 54 | (make-define-structure-type 55 | 'VECTOR 56 | name 57 | (list->vector (map car transforms)) 58 | (list->vector (map cdr transforms)) 59 | (make-vector (length transforms) (lambda () #f)) 60 | (standard-unparser-method name #f) 61 | class 62 | object-size)) 63 | class)))) 64 | (if (not entry) 65 | (let ((class (make-class))) 66 | (set! class-descriptors (cons (cons name class) class-descriptors)) 67 | class) 68 | (let ((class (cdr entry))) 69 | (cond ((not (eq? (class-superclass class) superclass)) 70 | (let ((class (make-class))) 71 | (set-cdr! entry class) 72 | class)) 73 | ((and (= object-size (class-object-size class)) 74 | (equal? transforms (class-instance-transforms class))) 75 | class) 76 | (else 77 | (warn "Redefining class:" name) 78 | (set-class-object-size! class object-size) 79 | (set-class-instance-transforms! class transforms) 80 | class))))))) 81 | 82 | (define (make-instance-transforms superclass variables) 83 | (define (generate variables n) 84 | (if (pair? variables) 85 | (cons (cons (car variables) n) 86 | (generate (cdr variables) (+ n 1))) 87 | '())) 88 | (if superclass 89 | (append (class-instance-transforms superclass) 90 | (generate variables (class-object-size superclass))) 91 | (generate variables 1))) 92 | 93 | (define (name->class name) 94 | (let ((entry (assq name class-descriptors))) 95 | (if (not entry) 96 | (error "Unknown class name:" name)) 97 | (cdr entry))) 98 | 99 | (define class-descriptors 100 | '()) -------------------------------------------------------------------------------- /edwin48/scsh/aliases.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- Mode: Scheme; scheme48-package: aliases -*- 2 | ;;; 3 | ;;; Aliases for MIT Scheme 4 | ;;; 5 | 6 | (define (without-interrupts thunk) 7 | (with-interrupts-inhibited thunk)) 8 | 9 | (define unspecific (unspecific)) 10 | (define *the-non-printing-object* unspecific) 11 | 12 | (define (1+ z) (+ z 1)) 13 | (define (-1+ z) (- z 1)) 14 | 15 | (define (integer-divide n d) 16 | (cons (quotient n d) 17 | (remainder n d))) 18 | 19 | (define (integer-divide-quotient qr) 20 | (if (and (pair? qr) (= 2 (length qr))) 21 | (car qr))) 22 | 23 | (define (integer-divide-remainder qr) 24 | (if (and (pair? qr) (= 2 (length qr))) 25 | (cdr qr))) 26 | 27 | (define (list-deletor! predicate) 28 | (lambda (items) (remove! predicate items))) 29 | 30 | (define (vector-grow vec k) 31 | (let ((difference (- k (vector-length vec)))) 32 | (vector-append vec (make-vector difference #f)))) 33 | 34 | (define (string-head string end) 35 | (substring string 0 end)) 36 | 37 | (define (string-tail string start) 38 | (substring string start (string-length string))) 39 | 40 | (define* (string-index-right-ci string char (start 0) (end (string-length string))) 41 | (string-index-right string (lambda (c) (char-ci=? c char)) start end)) 42 | 43 | (define* (string-index-ci string char (start 0) (end (string-length string))) 44 | (string-index string (lambda (c) (string-ci= c char)) start end)) 45 | 46 | (define (symbol-append . symbols) 47 | (string->symbol (apply string-append (map symbol->string symbols)))) 48 | 49 | (define (symbolstring symbol1) 51 | (symbol->string symbol2))) 52 | 53 | (define (symbol-name s) 54 | (symbol->string s)) 55 | 56 | (define (vector-8b-ref string k) 57 | (char->ascii (string-ref string k))) 58 | 59 | (define (vector-8b-set! string k code) 60 | (if (<= code 128) 61 | (string-set! string k (ascii->char code)))) 62 | 63 | (define (vector-8b-fill! string start end ascii) 64 | (string-fill! string ascii start end)) 65 | 66 | (define (vector-8b-find-next-char string start end ascii) 67 | (string-index string ascii start end)) 68 | 69 | (define (beep) unspecific) 70 | 71 | (define (exact-nonnegative-integer? obj) 72 | (and (integer? obj) (> obj 0) (exact? obj))) 73 | 74 | (define (exact-integer? obj) 75 | (and (integer? obj) (exact? obj))) 76 | 77 | (define (char->digit c) 78 | (if (char-set-contains? char-set:digit c) 79 | (- (char->ascii c) (char->ascii #\0)) 80 | (error "this is not a digit" c))) 81 | 82 | (define (char-ascii? c) (char? c)) 83 | 84 | (define (alist? object) 85 | (and (list? object) 86 | (every pair? object))) 87 | 88 | (define (write-to-string obj) 89 | (let ((port (open-output-string))) 90 | (write obj port) 91 | (get-output-string port))) 92 | 93 | (define* (write-string s (port (current-output-port))) 94 | (string-for-each (lambda (c) (write-char s port)) s)) 95 | 96 | (define-syntax fluid-let 97 | (syntax-rules () 98 | ((fluid-let ((variable init) ...) body0 body1 ...) 99 | (*fluid-let ((variable init) ...) body0 body1 ...)))) 100 | 101 | (define-syntax *fluid-let 102 | (syntax-rules () 103 | ((*fluid-let ((bindings ...) ...) . body) 104 | (let-fluids bindings ... ... . body)))) 105 | 106 | (define (integer-round n1 n2) (round (/ n1 n2))) 107 | 108 | (define (round->exact x) (inexact->exact (round x))) 109 | 110 | (define (real-time-clock) 111 | (receive (secs ticks) 112 | (time+ticks) 113 | ticks)) 114 | 115 | (define (boolean=? x y) 116 | (or (and (eq? x #t) (eq? y #t)) 117 | (and (eq? x #f) (eq? y #f)))) 118 | 119 | (define* (make-circular-list k (element '())) 120 | (circular-list element)) 121 | 122 | (define (identity-procedure x) x) 123 | -------------------------------------------------------------------------------- /edwin48/srfi-packages.scm: -------------------------------------------------------------------------------- 1 | ;;; -*- mode: scheme; scheme48-package: (config) -*- 2 | 3 | ;;; SRFI 43: Vector library 4 | ;;; This is now available in SCSH 0.7 so lets get rid of it 5 | ;;; 6 | ;;; Comment this out if you are using nuscsh 7 | ;;; 8 | ;; (define-interface srfi-43-interface 9 | ;; (export make-vector vector vector-unfold vector-unfold-right 10 | ;; vector-copy vector-reverse-copy vector-append vector-concatenate 11 | ;; vector? vector-empty? vector= vector-ref vector-length 12 | ;; vector-fold vector-fold-right vector-map vector-map! 13 | ;; vector-for-each vector-count vector-index vector-skip 14 | ;; vector-index-right vector-skip-right 15 | ;; vector-binary-search vector-any vector-every 16 | ;; vector-set! vector-swap! vector-fill! vector-reverse! 17 | ;; vector-copy! vector-reverse-copy! vector-reverse! 18 | ;; vector->list reverse-vector->list list->vector reverse-list->vector)) 19 | 20 | ;; (define-structure srfi-43 srfi-43-interface 21 | ;; (open (modify scheme 22 | ;; (rename (vector-fill! %vector-fill!)) 23 | ;; (rename (vector->list %vector->list)) 24 | ;; (rename (list->vector %list->vector))) 25 | ;; (modify util (rename (unspecific unspecified-value))) 26 | ;; (subset srfi-8 (receive)) 27 | ;; (subset signals (error))) 28 | ;; (files srfi-43)) 29 | 30 | ;;; SRFI 66: Octet Vectors 31 | ;;; This is now available in SCSH 0.7 so lets get rid of it 32 | ;;; 33 | ;;; Comment this out if you are using nuscsh 34 | ;;; 35 | ;; (define-interface srfi-66-interface 36 | ;; (export make-u8vector 37 | ;; u8vector? 38 | ;; list->u8vector u8vector->list 39 | ;; u8vector 40 | ;; u8vector-length 41 | ;; u8vector-ref u8vector-set! 42 | ;; u8vector-copy! u8vector-copy 43 | ;; u8vector=? 44 | ;; u8vector-compare)) 45 | 46 | ;; (define-structure srfi-66 srfi-66-interface 47 | ;; (open scheme 48 | ;; byte-vectors 49 | ;; (subset primitives (copy-bytes!))) 50 | ;; (files srfi-66)) 51 | 52 | 53 | ;;; SRFI 69: Basic hash tables 54 | ;;; 55 | ;;; Implement this using the tables module 56 | 57 | (define-interface srfi-69-interface 58 | (export make-hash-table hash-table? alist->hash-table 59 | ;; hash-table-equivalence-function, hash-table-hash-function 60 | hash-table-ref hash-table-ref/default 61 | hash-table-set! hash-table-delete! hash-table-exists? 62 | ;; hash-table-update! hash-table-update!/default 63 | hash-table-size hash-table-keys hash-table-values 64 | hash-table-walk ;; hash-table-fold 65 | hash-table->alist hash-table-copy ;; hash-table-merge! 66 | hash string-hash ;; string-ci-hash hash-by-identity 67 | )) 68 | 69 | (define-structure srfi-69 srfi-69-interface 70 | (open scheme 71 | (subset signals (error)) 72 | (modify tables (rename (default-hash-function hash))) 73 | srfi-89) 74 | (files srfi-69)) 75 | 76 | ;; 77 | ;; SRFI-89 78 | ;; 79 | (define-structure srfi-89 80 | (export (define* :syntax)) 81 | (open scheme srfi-1 let-opt) 82 | (for-syntax (open scheme let-opt (subset signals (syntax-error)) srfi-1)) 83 | (files srfi-89)) 84 | 85 | 86 | ;;; This is now available in SCSH 0.7 so lets get rid of it 87 | ;;; 88 | ;;; Comment this out if you are using nuscsh 89 | ;;; 90 | 91 | ;; ;; 92 | ;; ;; SRFI-78 93 | ;; ;; Lightweight Testing 94 | ;; ;; 95 | ;; (define-interface srfi-78-interface 96 | ;; (export (check :syntax) 97 | ;; (check-ec :syntax) 98 | ;; check-report 99 | ;; check-set-mode! 100 | ;; check-reset! 101 | ;; check-passed?)) 102 | 103 | ;; (define-structure srfi-78 srfi-78-interface 104 | ;; (open scheme srfi-23 srfi-42 pp) 105 | ;; (files srfi-78) 106 | ;; (begin (define check:write p))) 107 | -------------------------------------------------------------------------------- /edwin48/mousecom.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: mousecom.scm,v 1.11 2008/01/30 20:02:04 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Mouse Commands 29 | 30 | 31 | (define-command mouse-select 32 | "Select window the mouse is on." 33 | () 34 | (lambda () 35 | (select-window (button-event/window (current-button-event))))) 36 | 37 | (define-command mouse-keep-one-window 38 | "Select window mouse is on, then kill all other windows." 39 | () 40 | (lambda () 41 | ((ref-command mouse-select)) 42 | ((ref-command delete-other-windows)))) 43 | 44 | (define-command mouse-select-and-split 45 | "Select window mouse is on, then split it vertically in half." 46 | () 47 | (lambda () 48 | ((ref-command mouse-select)) 49 | ((ref-command split-window-vertically) #f))) 50 | 51 | (define-command mouse-set-point 52 | "Select window mouse is on, and move point to mouse position." 53 | () 54 | (lambda () 55 | (let ((button-event (current-button-event))) 56 | (let ((window (button-event/window button-event))) 57 | (select-window window) 58 | (set-current-point! 59 | (or (window-coordinates->mark window 60 | (button-event/x button-event) 61 | (button-event/y button-event)) 62 | (buffer-end (window-buffer window)))))))) 63 | 64 | (define-command mouse-set-mark 65 | "Select window mouse is on, and set mark at mouse position. 66 | Display cursor at that position for a second." 67 | () 68 | (lambda () 69 | (let ((button-event (current-button-event))) 70 | (let ((window (button-event/window button-event))) 71 | (select-window window) 72 | (let ((mark 73 | (or (window-coordinates->mark window 74 | (button-event/x button-event) 75 | (button-event/y button-event)) 76 | (buffer-end (window-buffer window))))) 77 | (push-current-mark! mark) 78 | (mark-flash mark)))))) 79 | 80 | (define-command mouse-show-event 81 | "Show the mouse position in the minibuffer." 82 | () 83 | (lambda () 84 | (let ((button-event (current-button-event))) 85 | (message "window: " (button-event/window button-event) 86 | " x: " (button-event/x button-event) 87 | " y: " (button-event/y button-event))))) 88 | 89 | (define-command mouse-scroll-up 90 | "Scroll up mouse-scroll-increment lines." 91 | () 92 | (lambda () 93 | (scroll-window (selected-window) 94 | (ref-variable mouse-scroll-increment) 95 | (lambda () unspecific)))) 96 | 97 | (define-command mouse-scroll-down 98 | "Scroll down mouse-scroll-increment lines." 99 | () 100 | (lambda () 101 | (scroll-window (selected-window) 102 | (- (ref-variable mouse-scroll-increment)) 103 | (lambda () unspecific)))) 104 | 105 | (define-variable mouse-scroll-increment 106 | "Number of lines by which a mouse-scroll event moves." 107 | 5 108 | exact-nonnegative-integer?) 109 | 110 | (define-command mouse-ignore 111 | "Don't do anything." 112 | () 113 | (lambda () unspecific)) 114 | -------------------------------------------------------------------------------- /edwin48/class.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: class.scm,v 1.78 2008/01/30 20:01:59 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Class/Object System 29 | 30 | 31 | ;;; ****************************************************************** 32 | ;;; This software is intended for use in the Edwin window system only. 33 | ;;; Don't think about using it for anything else, since it is not, and 34 | ;;; likely will not ever, be supported as a part of the Scheme system. 35 | ;;; ****************************************************************** 36 | 37 | (define-structure (class (constructor %make-class)) 38 | (name #f read-only #t) 39 | (superclass #f read-only #t) 40 | object-size 41 | instance-transforms 42 | (methods #f read-only #t)) 43 | 44 | (define (class-method class name) 45 | (class-methods/ref (class-methods class) name)) 46 | 47 | (define (class-methods/ref methods name) 48 | (or (method-lookup methods name) 49 | (error "Unknown method:" name))) 50 | 51 | (define (method-lookup methods name) 52 | (let loop ((methods methods)) 53 | (and methods 54 | (let ((entry (assq name (car methods)))) 55 | (if entry 56 | (cdr entry) 57 | (loop (cdr methods))))))) 58 | 59 | (define (class-method-define class name method) 60 | (let ((methods (class-methods class))) 61 | (let ((entry (assq name (car methods)))) 62 | (if entry 63 | (set-cdr! entry method) 64 | (set-car! methods (cons (cons name method) (car methods)))))) 65 | name) 66 | 67 | (define (usual-method class name) 68 | (class-method (class-superclass class) name)) 69 | 70 | (define (subclass? class class*) 71 | (or (eq? class class*) 72 | (let loop ((class (class-superclass class))) 73 | (and class 74 | (or (eq? class class*) 75 | (loop (class-superclass class))))))) 76 | 77 | (define (make-object class) 78 | (if (not (class? class)) 79 | (error:wrong-type-argument class "class" 'MAKE-OBJECT)) 80 | (let ((object (make-vector (class-object-size class) #f))) 81 | (vector-set! object 0 class) 82 | object)) 83 | 84 | (define (object? object) 85 | (and (vector? object) 86 | (not (zero? (vector-length object))) 87 | (class? (vector-ref object 0)))) 88 | 89 | (define (object-of-class? class object) 90 | (and (vector? object) 91 | (not (zero? (vector-length object))) 92 | (eq? class (vector-ref object 0)))) 93 | 94 | (define (object-class object) 95 | (vector-ref object 0)) 96 | 97 | (define (object-methods object) 98 | (class-methods (object-class object))) 99 | 100 | (define (object-method object name) 101 | (class-method (object-class object) name)) 102 | 103 | (define (send object operation . args) 104 | (apply (object-method object operation) object args)) 105 | 106 | (define (send-if-handles object operation . args) 107 | (let ((method (method-lookup (object-methods object) operation))) 108 | (and method (apply method object args)))) 109 | 110 | (define (send-usual class object operation . args) 111 | (apply (usual-method class operation) object args)) -------------------------------------------------------------------------------- /edwin48/doscom.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: doscom.scm,v 1.9 2008/01/30 20:02:00 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Shell commands for DOS 29 | 30 | 31 | (load-option 'DOSPROCESS) 32 | 33 | (define-command shell-command 34 | "Execute string COMMAND in inferior shell; display output, if any. 35 | Optional second arg #t (prefix arg, if interactive) means 36 | insert output in current buffer after point (leave mark after it)." 37 | "sShell command\nP" 38 | (lambda (command insert-at-point?) 39 | (let ((directory (buffer-default-directory (current-buffer)))) 40 | (if insert-at-point? 41 | (begin 42 | (if (buffer-read-only? (current-buffer)) 43 | (barf-if-read-only)) 44 | (let ((point (current-point))) 45 | (push-current-mark! point) 46 | (shell-command #f point directory command)) 47 | ((ref-command exchange-point-and-mark))) 48 | (shell-command-pop-up-output 49 | (lambda (output-mark) 50 | (shell-command #f output-mark directory command))))))) 51 | 52 | (define-command shell-command-on-region 53 | "Execute string COMMAND in inferior shell with region as input. 54 | Normally display output (if any) in temp buffer; 55 | Prefix arg means replace the region with it." 56 | "r\nsShell command on region\nP" 57 | (lambda (region command replace-region?) 58 | (let ((directory (buffer-default-directory (current-buffer)))) 59 | (if replace-region? 60 | (let ((point (current-point)) 61 | (mark (current-mark))) 62 | (let ((swap? (mark< point mark)) 63 | (temp)) 64 | (dynamic-wind 65 | (lambda () 66 | (set! temp (temporary-buffer " *shell-output*")) 67 | unspecific) 68 | (lambda () 69 | (shell-command (make-region point mark) 70 | (buffer-start temp) 71 | directory 72 | command) 73 | (without-interrupts 74 | (lambda () 75 | (delete-string point mark) 76 | (insert-region (buffer-start temp) 77 | (buffer-end temp) 78 | (current-point))))) 79 | (lambda () 80 | (kill-buffer temp) 81 | (set! temp) 82 | unspecific)) 83 | (if swap? ((ref-command exchange-point-and-mark))))) 84 | (shell-command-pop-up-output 85 | (lambda (output-mark) 86 | (shell-command region output-mark directory command))))))) 87 | 88 | (define (shell-command-pop-up-output generate-output) 89 | (let ((buffer (temporary-buffer "*Shell Command Output*"))) 90 | (let ((start (buffer-start buffer))) 91 | (generate-output start) 92 | (set-buffer-point! buffer start) 93 | (if (mark< start (buffer-end buffer)) 94 | (pop-up-buffer buffer #f) 95 | (message "(Shell Command completed with no output)"))))) 96 | 97 | (define (shell-command input-region output-mark directory command) 98 | (with-real-working-directory-pathname directory 99 | (lambda () 100 | (let ((core 101 | (lambda (input-port) 102 | (run-subprocess command 103 | input-port 104 | (mark->output-port output-mark))))) 105 | (if input-region 106 | (core (make-buffer-input-port (region-start input-region) 107 | (region-end input-region))) 108 | (call-with-input-file "\\dev\\nul" core)))))) -------------------------------------------------------------------------------- /edwin48/htmlmode.scm: -------------------------------------------------------------------------------- 1 | #| -*-Scheme-*- 2 | 3 | $Id: htmlmode.scm,v 1.17 2008/01/30 20:02:02 cph Exp $ 4 | 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, 2008 Massachusetts Institute of Technology 8 | 9 | This file is part of MIT/GNU Scheme. 10 | 11 | MIT/GNU Scheme is free software; you can redistribute it and/or modify 12 | it under the terms of the GNU General Public License as published by 13 | the Free Software Foundation; either version 2 of the License, or (at 14 | your option) any later version. 15 | 16 | MIT/GNU Scheme is distributed in the hope that it will be useful, but 17 | WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19 | General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with MIT/GNU Scheme; if not, write to the Free Software 23 | Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, 24 | USA. 25 | 26 | |# 27 | 28 | ;;;; Major Mode for XML 29 | 30 | 31 | (define-major-mode xml text "XML" 32 | "Major mode for editing XML. 33 | 34 | \\{xml}" 35 | (lambda (buffer) 36 | (local-set-variable! syntax-table xml-syntax-table buffer) 37 | (local-set-variable! indent-line-procedure 38 | (ref-command indent-relative) 39 | buffer) 40 | (local-set-variable! paragraph-separate xml-paragraph-separator buffer) 41 | (local-set-variable! paragraph-start xml-paragraph-separator buffer) 42 | (local-set-variable! syntax-ignore-comments-backwards #f buffer) 43 | (local-set-variable! comment-locator-hook xml-comment-locate buffer) 44 | (local-set-variable! comment-indent-hook xml-comment-indentation buffer) 45 | (local-set-variable! comment-start "" buffer) 47 | (local-set-variable! comment-multi-line #t buffer) 48 | (local-set-variable! 49 | sentence-end 50 | "[.?!][]\"')}]*\\(<[^>]*>\\)*\\($\\| $\\|\t\\| \\)[ \t\n]*" 51 | buffer) 52 | (local-set-variable! local-abbrev-table 53 | (ref-variable xml-mode-abbrev-table buffer) 54 | buffer) 55 | (event-distributor/invoke! (ref-variable xml-mode-hook buffer) buffer))) 56 | 57 | (define xml-paragraph-separator 58 | (let ((lwsp (rexp* (char-set #\space #\tab #\U+A0)))) 59 | (rexp->regexp 60 | (rexp-sequence 61 | (rexp-optional lwsp 62 | "<" 63 | (rexp* (char-set-difference char-set:graphic 64 | (string->char-set ">"))) 65 | ">") 66 | lwsp 67 | (rexp-line-end))))) 68 | 69 | (define-command xml-mode 70 | "Enter XML mode." 71 | () 72 | (lambda () (set-current-major-mode! (ref-mode-object xml)))) 73 | 74 | (define-variable xml-mode-abbrev-table 75 | "Mode-specific abbrev table for XML.") 76 | (define-abbrev-table 'xml-mode-abbrev-table '()) 77 | 78 | (define-variable xml-mode-hook 79 | "An event distributor that is invoked when entering XML mode." 80 | (make-event-distributor)) 81 | 82 | (define xml-syntax-table 83 | (let ((syntax-table (make-char-syntax-table text-mode:syntax-table))) 84 | (set-char-syntax! syntax-table #\< "(>") 85 | (set-char-syntax! syntax-table #\! ". ") 86 | (set-char-syntax! syntax-table #\- "_ 1234") 87 | (set-char-syntax! syntax-table #\> ")<") 88 | (set-char-syntax! syntax-table #\" "\"\"") 89 | (set-char-syntax! syntax-table #\. "_") 90 | (set-char-syntax! syntax-table #\_ "_") 91 | (set-char-syntax! syntax-table #\: "_") 92 | syntax-table)) 93 | 94 | (define (xml-comment-locate mark) 95 | (and (re-search-forward "