conservatory
/
pcs
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Unpack disk1.tgz

This commit is contained in:
Lassi Kortela 2023-05-20 12:57:04 +03:00
commit e5f37aa173
108 changed files with 14396 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

248
class.scm Normal file
View File

@ -0,0 +1,248 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/29/85 ;;;
;;; ;;;
;;; File : class.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains class creation and function to access ;;;
;;; various fields. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(define %%class-tag '#!class)
(define %sc-make-class
(lambda (name cv allivs mixins method-values)
(let ((method-structure
(mapcar (lambda (a) (list (car a) (cons name name)))
method-values))
(class (make-vector 15)))
(vector-set! class 0 %%class-tag)
(vector-set! class 1 name)
(vector-set! class 2 cv)
(vector-set! class 3 cv)
(vector-set! class 4 allivs)
(vector-set! class 5 mixins)
(vector-set! class 6 (%uncompiled-make-instance class))
(vector-set! class 9 method-structure)
(vector-set! class 13 method-values)
(vector-set! class 14 allivs)
(putprop name class '%class)
class)))
(define %scoops-chk-class
(lambda (class)
(and (not (and (vector? class)
(> (vector-length class) 0)
(equal? %%class-tag (vector-ref class 0))))
(error-handler class 6 #!TRUE))))
;;;
(define-integrable %sc-name
(lambda (class)
(vector-ref class 1)))
;;;
(define-integrable %sc-cv
(lambda (class)
(vector-ref class 2)))
;;;
(define-integrable %sc-allcvs
(lambda (class)
(vector-ref class 3)))
;;;
(define-integrable %sc-allivs
(lambda (class)
(vector-ref class 4)))
;;;
(define-integrable %sc-mixins
(lambda (class)
(vector-ref class 5)))
;;;
(define-integrable %sc-inst-template
(lambda (class)
(vector-ref class 6)))
;;;
(define-integrable %sc-method-env
(lambda (class)
(vector-ref class 7)))
;;;
(define-integrable %sc-class-env
(lambda (class)
(vector-ref class 8)))
;;;
(define-integrable %sc-method-structure
(lambda (class)
(vector-ref class 9)))
;;;
(define-integrable %sc-subclasses
(lambda (class)
(vector-ref class 10)))
;;;
(define-integrable %sc-class-compiled
(lambda (class)
(vector-ref class 11)))
;;;
(define-integrable %sc-class-inherited
(lambda (class)
(vector-ref class 12)))
;;;
(define-integrable %sc-method-values
(lambda (class)
(vector-ref class 13)))
(define-integrable %sc-iv
(lambda (class)
(vector-ref class 14)))
;;;
(define-integrable %sc-set-name
(lambda (class val)
(vector-set! class 1 val)))
;;;
(define-integrable %sc-set-cv
(lambda (class val)
(vector-set! class 2 val)))
;;;
(define-integrable %sc-set-allcvs
(lambda (class val)
(vector-set! class 3 val)))
;;;
(define-integrable %sc-set-allivs
(lambda (class val)
(vector-set! class 4 val)))
;;;
(define-integrable %sc-set-mixins
(lambda (class val)
(vector-set! class 5 val)))
;;;
(define-integrable %sc-set-inst-template
(lambda (class val)
(vector-set! class 6 val)))
;;;
(define-integrable %sc-set-method-env
(lambda (class val)
(vector-set! class 7 val)))
;;;
(define-integrable %sc-set-class-env
(lambda (class val)
(vector-set! class 8 val)))
;;;
(define-integrable %sc-set-method-structure
(lambda (class val)
(vector-set! class 9 val)))
;;;
(define-integrable %sc-set-subclasses
(lambda (class val)
(vector-set! class 10 val)))
;;;
(define-integrable %sc-set-class-compiled
(lambda (class val)
(vector-set! class 11 val)))
;;;
(define-integrable %sc-set-class-inherited
(lambda (class val)
(vector-set! class 12 val)))
;;;
(define-integrable %sc-set-method-values
(lambda (class val)
(vector-set! class 13 val)))
;;;
(define-integrable %sc-set-iv
(lambda (class val)
(vector-set! class 14 val)))
;;;
(define %sc-name->class
(lambda (name)
(apply-if (getprop name '%class)
(lambda (a) a)
(error-handler name 2 #!TRUE))))
;;;
(define-integrable %sc-get-meth-value
(lambda (meth-name class)
(cdr (assq meth-name (%sc-method-values class)))))
;;;
(define-integrable %sc-get-cv-value
(lambda (var class)
(cadr (assq var (%sc-cv class)))))
;;;
(define-integrable %sc-concat
(lambda (str sym)
(string->symbol (string-append str (symbol->string sym)))))


6
compile.dem Normal file
View File

@ -0,0 +1,6 @@
(fast-load (%system-file-name "pboot.fsl"))
(compile-file "tutorial.scm" "tutorial.so")
(compile-file "frame.scm" "frame.so")
(pcs-compile-file "demstart.scm" "demstart.so")
(exit)


18
coscoops.scm Normal file
View File

@ -0,0 +1,18 @@
(compile-file "class.scm" "class.so")
(compile-file "methods.scm" "methods.so")
(gc)
(compile-file "meth2.scm" "meth2.so")
(compile-file "instance.scm" "instance.so")
(compile-file "inht.scm" "inht.so")
(gc)
(compile-file "interf.scm" "interf.so")
(compile-file "send.scm" "send.so")
(compile-file "scsend.scm" "scsend.so")
(gc)
(compile-file "utl.scm" "utl.so")
(compile-file "debug.scm" "debug.so")
(fast-load (%system-file-name "pboot.fsl"))
(compile-file "expand.scm" "expand.so")
(gc)
(compile-file "ldscoop.scm" "ldscoop.so")
(exit)

42
debug.scm Normal file
View File

@ -0,0 +1,42 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 5/16/85 ;;;
;;; ;;;
;;; File : debug.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains routines to help in debugging ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; routines to help in debugging
(define print-class
(lambda (class)
(writeln "class name : " (%sc-name class))
(writeln "class vars : " (%sc-cv class))
(writeln "allcv : " (%sc-allcvs class))
(writeln "inst vars : " (%sc-allivs class))
(writeln "mixins : " (%sc-mixins class))
(writeln "template : " (%sc-inst-template class))
(writeln "method-env : "
(and (%sc-method-env class)
(environment-frame-bindings (%sc-method-env class))))
(writeln "class-env : "
(and (%sc-class-env class)
(environment-frame-bindings (%sc-class-env class))))
(writeln "method-str : " (%sc-method-structure class))
(writeln "subclasses : " (%sc-subclasses class))
(writeln "class-compiled : " (%sc-class-compiled class))
(writeln "class-inherited : "(%sc-class-inherited class))
(writeln "method values : " (%sc-method-values class))
))


4
demstart.scm Normal file
View File

@ -0,0 +1,4 @@
(start-tutorial)
(demo)


40
do_auto.bat Normal file
View File

@ -0,0 +1,40 @@
: =====> DO_AUTO.BAT
:
: command dir: \TOOLS,\PCS (assumed in path)
: source dir : \NEWPCS (the current directory)
: output dir : \EXEC
CD \BUILD\NEWPCS
PATH = \TOOLS;\PCS;\
rem
rem
rem Compile the autoload files
rem
rem
PCS COMPILE.ALL /AUTO
rem
rem
rem Fasl the autoload files
rem
rem
make_fsl edit.so edit.fsl /copyright
make_fsl padvise.so padvise.fsl /copyright
make_fsl pdefstr.so pdefstr.fsl /copyright
make_fsl pdos.so pdos.fsl /copyright
make_fsl pfunarg.so pfunarg.fsl /copyright
make_fsl pgr.so pgr.fsl /copyright
make_fsl pinspect.so pinspect.fsl /copyright
make_fsl pmath.so pmath.fsl /copyright
make_fsl pnum2s.so pnum2s.fsl /copyright
make_fsl pp.so pp.fsl /copyright
make_fsl psort.so psort.fsl /copyright
make_fsl pwindows.so pwindows.fsl /copyright
make_fsl pboot.so pboot.fsl /copyright
make_fsl oldpmath.so oldpmath.fsl /copyright
copy pboot.fsl \exec\misc
del pboot.fsl
copy *.fsl \exec
del *.so
del *.fsl

64
do_edwin.bat Normal file
View File

@ -0,0 +1,64 @@
: =====> DO_EDWIN.BAT
:
: command dir: \TOOLS,\PCS (assumed in path)
: source dir : \BUILD\EDWIN (the current directory)
: output dir : \EXEC
CD \BUILD\EDWIN
PATH = \TOOLS;\PCS;\
rem
rem
rem Build EDWIN (3 phases)
rem
rem (1st phase)
rem
pcs doedwin1.scm
rem
make_fsl charset.so edwin11.fsl /copyright
rem
rem (2nd phase)
rem
pcs doedwin2.scm
rem
rem
rem (phase 2a)
rem
pcs doedwi2a.scm
rem
copy comfun.so+dwind.so+ldchset.so+strcomp.so+nstring.so temp1.so
copy struct.so+regops.so+comtabv.so+initmac.so+initkey.so temp2.so
copy buffer.so+bufset.so+ring.so+motion.so temp3.so
copy main.so+curr.so+redisp1.so+redisp2.so+insert80.so temp35.so
copy messages.so+modeln.so+argred.so+toplevel.so temp4.so
copy allcoms1.so+allcoms2.so+allcoms3.so temp5.so
copy marks.so+io.so+search1.so+things.so+parens.so+autoload.so+edinit.so temp6.so
copy temp1.so+temp2.so+temp3.so+temp35.so+temp4.so+temp5.so+temp6.so edwin0.so
del temp1.so
del temp2.so
del temp3.so
del temp35.so
del temp4.so
del temp5.so
del temp6.so
make_fsl edwin0.so edwin0.fsl /copyright
make_fsl argredp.so edwin1.fsl /copyright
make_fsl bufsetp.so edwin2.fsl /copyright
make_fsl transpos.so edwin3.fsl /copyright
make_fsl kill1.so edwin4.fsl /copyright
make_fsl kill2.so edwin5.fsl /copyright
make_fsl lisp.so edwin6.fsl /copyright
make_fsl incser.so edwin7.fsl /copyright
make_fsl words.so edwin8.fsl /copyright
make_fsl search2.so edwin9.fsl /copyright
make_fsl sentence.so edwin10.fsl /copyright
rem
rem (3rd phase)
rem
pcs doedwin3.scm
rem
make_fsl ldall.so edwin.fsl /copyright
make_fsl dummy.so dummy.fsl /copyright
copy *.fsl \exec
del *.so
del *.fsl

62
do_pcs.bat Normal file
View File

@ -0,0 +1,62 @@
: =====> DO_PCS.BAT
:
: command dir: \TOOLS,\PCS (assumed in path)
: source dir : \NEWPCS (the current directory)
: output dir : \EXEC
CD \BUILD\NEWPCS
PATH = \TOOLS;\PCS;\
rem
rem
rem Compile the Scheme compiler
rem
rem
: make certain we don't accidentally use any COMPILER.APP in current directory
del compiler.app
PCS COMPILE.ALL /SRC
rem
rem
rem Fasl (create the fast-load format of) the compiler
rem
rem
copy pmacros.so+pme.so+psimp.so+pca.so+pgencode.so+ppeep.so+pasm.so+pcomp.so c1.so /v
copy pstd.so+pstd2.so+pio.so+popcodes.so+pdebug.so+pchreq.so+pauto_c.so+pauto_r.so+pstl.so c2.so /v
copy c1.so+c2.so compiler.so /v
MAKE_FSL COMPILER.SO COMPILER.APP /copyright
copy compiler.app \exec
: make same precaution on COMPILER.APP as before
del compiler.app
rem
rem
rem Compile the Scheme runtime compiler
rem
rem
PCS COMPILE.ALL /RT
rem
rem
rem Fasl the runtime compiler
rem
rem
del runtime.app
copy pstd.rto+pstd2.rto+pio.rto+pdebug.so+pchreq.rto+primops.rto rt1.so /v
copy rt1.so+pauto_r.so+autoprim.rto+pstl.so rt.so /v
MAKE_FSL RT.SO RUNTIME.APP /copyright
copy runtime.app \exec
rem
rem Build the autoloadable compiler
rem
rem
copy pmacros.so+pme.so+psimp.so+pca.so+pgencode.so+ppeep.so+pasm.so+pcomp.so c3.so /v
copy c3.so+pauto_c.so+popcodes.so compiler.so
MAKE_FSL COMPILER.SO COMPILER.FSL /copyright
MAKE_FSL PRIMOPS.RTO PRIMOPS.FSL /copyright
MAKE_FSL AUTOCOMP.SO AUTOCOMP.FSL /copyright
MAKE_FSL AUTOPRIM.RTO AUTOPRIM.FSL /copyright
copy compiler.fsl \exec\misc
copy primops.fsl \exec\misc
copy autocomp.fsl \exec\misc
copy autoprim.fsl \exec\misc
del *.so
del *.app
del *.fsl

23
do_scoop.bat Normal file
View File

@ -0,0 +1,23 @@
: =====> DO_SCOOPS.BAT
:
: command dir: \TOOLS,\PCS (assumed in path)
: source dir : \BUILD\SCOOPS (the current directory)
: output dir : \EXEC
CD \BUILD\SCOOPS
PATH = \TOOLS;\PCS;\
PCS COSCOOPS.SCM
copy class.so+methods.so+meth2.so+instance.so+inht.so temp1.so /v
copy temp1.so+interf.so+send.so+scsend.so+utl.so+expand.so+ldscoop.so scoops.so /v
make_fsl scoops.so scoops.fsl /copyright
copy scoops.fsl \exec
rem
rem Compile and build the SCOOPS tutorial
rem
pcs compile.dem
copy tutorial.so+frame.so+demstart.so scpsdemo.so
make_fsl scpsdemo.so tutorial.fsl /copyright
copy tutorial.fsl \exec
del *.so
del *.fsl

81
do_util.bat Normal file
View File

@ -0,0 +1,81 @@
: =====> DO_UTIL.BAT
:
: command dir: \TOOLS (assumed in path)
: source dir : \BUILD (the current directory)
: output dir : \EXEC
CD \BUILD
PATH = \TOOLS;\PCS;\
rem
rem
rem Machine type utility
rem
rem
masm machtype;
link machtype,\exec\machtype;
del machtype.obj
if "%1" == "protected" goto end
rem
rem
rem MAKE_FSL utility
rem
rem
masm MSDOS1;
lc1 make_fsl
lc2 make_fsl
link \TOOLS\C+MAKE_FSL+MSDOS1,\EXEC\MAKE_FSL,\EXEC\MAKE_FSL/M,\TOOLS\LCM+\TOOLS\LC
del make_fsl.obj
del msdos1.obj
rem
rem
rem NEWTRIG - XLI interface to PCS 3.0 transcendental functions
rem
rem
masm glue;
lc1 newtrig
lc2 newtrig
link \TOOLS\C+NEWTRIG+GLUE,\EXEC\NEWTRIG,\EXEC\NEWTRIG/M,\TOOLS\LCM+\TOOLS\LC
del newtrig.obj
: don't delete glue.obj yet
rem
rem
rem Memory utility
rem
rem
masm memtype;
link memtype,\exec\memtype;
del memtype.obj
rem
rem
rem XLI utilities
rem
rem
CD \BUILD\XLI
: note these .EXE's stay in the XLI directory
: (XCALL "exec" ...)
copy \build\dos.h
lc1 exec
lc2 exec
link \tools\c+exec+\build\glue,exec,,\tools\lc
del exec.map
del exec.obj
del dos.h
: (XCALL "sound" ...)
masm sound;
link sound;
del sound.obj
CD \BUILD
: now you can delete glue.obj
del glue.obj
:end

466
edwin/allcoms1.scm Normal file
View File

@ -0,0 +1,466 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This has been done to do most of the stuff at compile time rather
;;; than at load time. The commands and key definition are combined into
;;; one.
;;;
;;; The default key needs to be the first thing defined.
;;; With the current state of edwin (with the absence of extended
;;; commands) we do not need the following files comman.scm strtab.scm
;;; nvector.scm. Some of these may be needed with extended commands.
;;; All the initial commands assume that they are first ones of their
;;; name being defined. No checks are made
;;; instead of flooding the name space with all possible commands
;;; we define only those which are explicitly needed.
(define ^r-insert-self-command '())
(define ^r-argument-digit-command '())
(define ^r-forward-character-command '())
(define ^r-backward-character-command '())
(define ^r-negative-argument-command '())
(define ^r-bad-command '())
;;;
(define alt-char (integer->char 0))
(define meta-char (integer->char 27))
(define ctrl-x-char (integer->char 24))
(define ctrl-z-char (integer->char 26))
;;;
(define *split-screen-mode?* #!false)
;;;
;;;; Basic Commands
(define-initial-command-key ("^R Bad Command" argument)
"This command is used to capture undefined keys."
(
(define-initial-default-key procedure)
(set! ^r-bad-command procedure)
)
(editor-error (string-append "Undefined command: "
(obj->string (current-command-char)))))
(define-initial-command-key ("^R Insert Self" (argument 1))
"Insert the character used to invoke this."
(
(define add-insert-self
(lambda (lower upper)
((rec loop
(lambda (n)
(if (> n upper)
#!false
(begin
(define-initial-key (integer->char n) procedure)
(loop (1+ n))))))
lower)))
(add-insert-self 32 40)
(add-insert-self 42 47)
(add-insert-self 58 64)
(add-insert-self 91 127)
(add-insert-self 128 254) ;;; add new code for internationalize
(set! ^r-insert-self-command procedure)
)
(insert-chars (current-command-char) argument (current-point)))
(define-initial-command-key ("^R Quoted Insert" (argument 1))
"Insert the next character typed"
((define-initial-key (integer->char 17) procedure)) ;;; C-Q
(insert-chars (editor-read-char buffer-screen) argument (current-point)))
(define (insert-newlines n)
(let ((point (current-point)))
(cond ((= n 1) (region-insert-newline! point))
((> n 1) (region-insert-string! point (make-string n #\Newline))))))
(define (insert-chars char n point)
(cond ((= n 1) (region-insert-char! point char))
((> n 1) (region-insert-string! point (make-string n char)))))
(define execute-extended-chars?
#!TRUE)
(define (set-command-prompt-prefix! prefix-string)
(set-command-prompt!
(string-append-with-blanks (command-argument-prompt)
prefix-string)))
(define-initial-command-key ("^R Prefix Character" argument)
"This is a prefix for more commands."
(
(define-initial-prefix-key meta-char procedure)
(define-initial-prefix-key alt-char procedure)
(define-initial-prefix-key ctrl-x-char procedure)
(define-initial-prefix-key (list meta-char alt-char) procedure)
)
(let ((prefix-char (current-command-char)))
(set-command-prompt-prefix!
(string-append (char->name prefix-char) " "))
(let ((char (editor-read-char (window-screen (current-window)))))
(dispatch-on-char (if (atom? prefix-char)
(list prefix-char char)
(append prefix-char (list char)))))))
(define-initial-command-key ("^R Meta Character" argument)
"This is a prefix for more commands."
(
(define-initial-prefix-key ctrl-z-char procedure)
)
(let ((prefix-char meta-char))
(set-command-prompt-prefix!
(string-append (char->name prefix-char) " "))
(let ((char (editor-read-char (window-screen (current-window)))))
(dispatch-on-char (list prefix-char char)))))
(define-initial-command-key ("^R Scheme" argument)
"Stop Edwin and return to Scheme."
(
(define-initial-key (list ctrl-x-char (integer->char 26)) procedure);;;C-X C-Z
)
(save-buffer-changes (current-buffer))
(edwin-exit))
(define-initial-command-key ("^R Exit" argument)
"Stop Edwin, remove internal data structures, and return to scheme."
(
(define-initial-key (list ctrl-x-char (integer->char 3)) procedure) ;;;C-X C-C
)
(%save-buffer-changes (current-buffer))
;;; the following five lines fix an error with vector index out of range
;;; in edwin using C-X ! to split screen, then using C-X C-C to exit edwin
;;; reenter edwin and try C-X ! then error occurs
(if *split-screen-mode?* ;;; 2/14/86
(begin
(set! *split-screen-mode?* #!false)
(move-editor-to-full)
(move-pcs-to-full)))
(set! edwin-editor #!unassigned)
(edwin-exit))
(define-initial-command-key ("^R Redraw Screen" argument)
"Redraw the screen."
(
(define-initial-key (integer->char 12) procedure) ;;; C-L
)
(window-redraw! (current-window))
(reset-modeline-window))
(define (edwin-exit)
(restore-console-contents)
(make-pcs-status-visible)
(reset-typein-window)
(gc)
((fluid editor-continuation) *the-non-printing-object*))
;;;; Command Argument Reader
;;;; Commands
(define-initial-command-key ("^R Universal Argument" argument)
"Increments the argument multiplier and enters Autoarg mode."
(
(define-initial-key (integer->char 21) procedure) ;;; C-U
)
(command-argument-increment-multiplier-exponent!)
(enter-autoargument-mode!)
(update-argument-prompt!)
(read-and-dispatch-on-char))
(define-initial-command-key ("^R Argument Digit" argument)
"Sets the numeric argument for the next command."
(
(set! ^r-argument-digit-command procedure)
)
(command-argument-accumulate-digit! (char-base (current-command-char)))
(update-argument-prompt!)
(read-and-dispatch-on-char))
(define-initial-command-key ("^R Negative Argument" argument)
"Negates the numeric argument for the next command."
(
(set! ^r-negative-argument-command procedure)
)
(command-argument-negate!)
(update-argument-prompt!)
(read-and-dispatch-on-char))
(define-initial-command-key ("^R Autoargument Digit" argument)
"In Autoargument mode, sets numeric argument to the next command."
(
(define-initial-key #\0 procedure)
(define-initial-key #\1 procedure)
(define-initial-key #\2 procedure)
(define-initial-key #\3 procedure)
(define-initial-key #\4 procedure)
(define-initial-key #\5 procedure)
(define-initial-key #\6 procedure)
(define-initial-key #\7 procedure)
(define-initial-key #\8 procedure)
(define-initial-key #\9 procedure)
)
((if (autoargument-mode?)
^r-argument-digit-command
^r-insert-self-command)
argument))
(define-initial-command-key ("^R Auto Negative Argument" argument)
"In Autoargument mode, sets numeric sign to the next command."
(
(define-initial-key #\- procedure)
)
((if (and (autoargument-mode?) (command-argument-beginning?))
^r-negative-argument-command
^r-insert-self-command)
argument))
;;;(define-initial-command-key ("^R Autoargument" argument)
;;; "Used to start a command argument and enter Autoargument mode."
;;;(#!false
;;;)
;;; (%edwin-autoargument argument))
;;;; File Commands
(define-initial-command-key ("^R Visit File" argument)
"Visit new file in selected buffer."
(
(define-initial-key (list ctrl-x-char (integer->char 22)) procedure)
) ;;; C-X C-V
(let ((buffer (current-buffer)))
(let ((pathname
(prompt-for-pathname "Visit File :")))
(save-buffer-changes buffer)
(read-buffer buffer pathname)))
(setup-current-buffer-read-only! argument))
(define-initial-command-key ("^R Save File" argument)
"Save visited file on disk if modified."
(
(define-initial-key (list ctrl-x-char (integer->char 19)) procedure)
) ;;; C-X C-S
(save-file (current-buffer)))
(define-initial-command-key ("Write File" argument)
"Store buffer in specified file."
(
(define-initial-key (list ctrl-x-char (integer->char 23)) procedure)
) ;;; C-X C-W
(let ((buffer (current-buffer)))
(write-buffer
buffer
(prompt-for-pathname "Write buffer to file :"))))
(define-initial-command-key ("Insert File" argument)
"Insert contents of file into existing text."
(
(define-initial-key (list ctrl-x-char (integer->char 9)) procedure)
) ;;; C-X C-I
(let ((pathname
(prompt-for-pathname
"Insert File :")))
(set-current-region! (insert-file (current-point) pathname))))
(define-initial-command-key ("Write Region" argument)
" Write Region to a file."
(
(define-initial-key (list ctrl-x-char (integer->char 16)) procedure)
) ;;; C-X C-P
(let ((pathname (prompt-for-pathname "Put region into file :")))
(write-region (make-region (current-point) (current-mark)) pathname)))
(define-initial-command-key ("^R Newline" argument)
"Insert newline, or move onto blank line."
(
(define-initial-key #\Return procedure)
)
(cond ((not argument)
(if (line-end? (current-point))
(let ((m1 (line-start (current-point) 1 #!false)))
(if (and m1 (line-blank? m1)
(let ((m2 (line-start m1 1 #!false)))
(and m2 (line-blank? m2))))
(begin (set-current-point! m1)
(delete-horizontal-space))
(insert-newlines 1)))
(insert-newlines 1)))
(else
(insert-newlines argument))))
;;;; Motion Commands
(define-initial-command-key ("^R Beginning of Line" (argument 1))
"Move point to beginning of line."
(
(define-initial-key (integer->char 1) procedure) ;;; C-A
)
(set-current-point! (line-start (current-point) (-1+ argument) 'LIMIT)))
(define-initial-command-key ("^R Backward Character" (argument 1))
"Move back one character."
(
(define-initial-key (integer->char 2) procedure) ;;; C-B
(define-initial-key (list alt-char (integer->char 75)) procedure);;; <-
(set! ^r-backward-character-command procedure)
)
(move-thing mark- argument))
(define-initial-command-key ("^R End of Line" (argument 1))
"Move point to end of line."
(
(define-initial-key (integer->char 5) procedure) ;;; C-E
)
(set-current-point! (line-end (current-point) (-1+ argument) 'LIMIT)))
(define-initial-command-key ("^R Forward Character" (argument 1))
"Move forward one character."
(
(define-initial-key (integer->char 6) procedure) ;;; C-F
(define-initial-key (list alt-char (integer->char 77)) procedure) ;;; ->
(set! ^r-forward-character-command procedure)
)
(move-thing mark+ argument))
(define-initial-command-key ("^R Goto Beginning" argument)
"Go to beginning of buffer (leaving mark behind)."
(
(define-initial-key (list meta-char #\<) procedure) ;;; M-<
) ;;; alt is blocked
(cond ((not argument)
(set-current-point! (buffer-start (current-buffer))))
((command-argument-multiplier-only?)
(set-current-point! (buffer-end (current-buffer))))
((and (<= 0 argument) (<= argument 10))
(set-current-point! (region-10ths (buffer-region (current-buffer))
argument)))))
(define-initial-command-key ("^R Goto End" argument)
"Go to end of buffer (leaving mark behind)."
(
(define-initial-key (list meta-char #\>) procedure) ;;; M-> alt is blocked
)
(cond ((not argument)
(set-current-point! (buffer-end (current-buffer))))
((and (<= 0 argument) (<= argument 10)
(set-current-point! (region-10ths (buffer-region (current-buffer))
(- 10 argument)))))))
(define (region-10ths region n)
(mark+ (region-start region)
(quotient (* n (region-count-chars region)) 10)
#!false))
(define goal-column #!FALSE)
(define temporary-goal-column-tag
"Temporary Goal Column")
(define (current-goal-column)
(or goal-column
(command-message-receive temporary-goal-column-tag
identity-procedure
(lambda () (mark-column (current-point))))))
;;; this is temporary as we have not put the image stuff.
;;; this redefines mark-column and make-mark-from-column in struct
(define mark-column
(lambda (mark)
(char->x (line-string (mark-line mark)) (mark-position mark))))
(define make-mark-from-column
(lambda (line column)
(let ((mark (%make-mark line (x->char (line-string line) column) #!true))
(group (line-group line)))
(cond ((mark< mark (%group-start group)) (%group-start group))
((mark> mark (%group-end group)) (%group-end group))
(else mark)))))
(define-initial-command-key ("^R Down Real Line" (argument 1))
"Move down vertically to next real line."
(
(define-initial-key (integer->char 14) procedure) ;;; C-N
(define-initial-key (list alt-char (integer->char 80)) procedure)
)
(let ((column (current-goal-column)))
(line-offset (mark-line (current-point))
argument
(lambda (line)
(set-current-point! (make-mark-from-column line column)))
(lambda (line)
(let ((buffer (current-buffer)))
(region-insert-newline! (buffer-end buffer))
(set-current-point! (buffer-end buffer)))))
(set-command-message! temporary-goal-column-tag column)))
(define-initial-command-key ("^R Up Real Line" (argument 1))
"Move up vertically to next real line."
(
(define-initial-key (integer->char 16) procedure) ;;; C-P
(define-initial-key (list alt-char (integer->char 72)) procedure)
)
(let ((column (current-goal-column)))
(line-offset (mark-line (current-point))
(- argument)
(lambda (line)
(set-current-point! (make-mark-from-column line column)))
(lambda (line)
(set-current-point! (buffer-start (current-buffer)))))
(set-command-message! temporary-goal-column-tag column)))


451
edwin/allcoms2.scm Normal file
View File

@ -0,0 +1,451 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Window Motion Commands
(define next-screen-context-lines 2)
(define-initial-command-key ("^R Next Screen" argument)
"Move down to display next screenful of text."
(
(define-initial-key (integer->char 22) procedure) ;;; C-V
)
(scroll-window (current-window)
(cond ((not argument)
(- (window-y-size (current-window))
next-screen-context-lines))
((command-argument-negative-only?)
(- next-screen-context-lines
(window-y-size (current-window))))
(else argument))))
(define-initial-command-key ("^R Previous Screen" argument)
"Move up to display previous screenful of text."
(
(define-initial-key (list meta-char #\V) procedure) ;;; M-V
(define-initial-key (list alt-char (integer->char 47)) procedure) ;;;alt-v
)
(scroll-window (current-window)
(cond ((not argument)
(- next-screen-context-lines
(window-y-size (current-window))))
((command-argument-negative-only?)
(- (window-y-size (current-window))
next-screen-context-lines))
(else (- 0 argument)))))
(define (scroll-window window n)
(if (if (negative? n)
(window-mark-visible? window
(buffer-start (window-buffer window)))
(window-mark-visible? window
(buffer-end (window-buffer window))))
(if (negative? n)
(editor-error "Beginning of buffer")
(editor-error "End of buffer")))
(window-scroll-y-relative! window n))
;;;; Kill Commands
;;;; Deletion
(define %delete-check
(lambda (mark1 mark2)
(if (not mark2) (editor-error "Delete exceeds buffer bounds"))
(eq? (mark-line mark1) (mark-line mark2))))
(define-initial-command-key ("^R Backward Delete Character" argument)
"Delete character before point."
(
(define-initial-key #\Backspace procedure)
)
(if (not argument)
(let ((m1 (mark-1+ (current-point) #!false)))
(if (%delete-check (current-point) m1)
(%region-delete-char! m1)
(delete-region m1)))
(kill-region (mark- (current-point) argument #!false))))
(define-initial-command-key ("^R Delete Character" argument)
"Delete character after point."
(
(define-initial-key (integer->char 4) procedure) ;;C-D
)
(if (not argument)
(let ((m1 (mark1+ (current-point) #!false)))
(if (%delete-check (current-point) m1)
(%region-delete-char! (current-point))
(delete-region m1)))
(kill-region (mark+ (current-point) argument #!false))))
(define-initial-command-key ("^R Kill Line" argument)
"Kill to end of line, or kill an end of line."
(
(define-initial-key (integer->char 11) procedure) ;;; C-K
)
(let ((point (current-point)))
(kill-region
(cond ((not argument)
(let ((end (line-end point 0 #!false)))
(if (region-blank? (make-region point end))
(mark1+ end #!false)
end)))
((positive? argument)
(conjunction (not (group-end? point))
(line-start point argument 'LIMIT)))
((zero? argument)
(line-start point 0 #!false))
(else
(conjunction (not (group-start? point))
(line-start point
(if (line-start? point)
argument
(1+ argument))
'LIMIT)))))))
(define-initial-command-key ("^R Append Next Kill" argument)
"Make following kill commands append to last batch."
(
(define-initial-key (list meta-char (integer->char 23)) procedure) ;;;M C-W
)
(set-command-message! append-next-kill-tag))
;;;; Un/Killing
(define-initial-command-key ("^R Kill Region" argument)
"Kill from point to mark."
(
(define-initial-key (integer->char 23) procedure) ;;; C-W
)
(kill-region (current-mark)))
(define-initial-command-key ("^R Copy Region" argument)
"Stick region into kill-ring without killing it."
(
(define-initial-key (list meta-char #\W) procedure) ;;; M-W
(define-initial-key (list alt-char (integer->char 17)) procedure);;; alt-W
)
(copy-region (current-mark)))
(define un-kill-tag
"Un-kill")
(define-initial-command-key ("^R Un-Kill" (argument 1))
"Re-insert the last stuff killed."
(
(define-initial-key (integer->char 25) procedure) ;;; C-Y
)
(let ((ring (current-kill-ring)))
(if (or (> argument (ring-size ring))
(ring-empty? ring))
(editor-error "Nothing to un-kill"))
(if (command-argument-multiplier-only?)
(un-kill-region (ring-ref ring 0))
(un-kill-region-reversed (ring-ref ring (-1+ argument)))))
(set-command-message! un-kill-tag))
(define-initial-command-key ("^R Pop Kill Ring" (argument 1))
" Pop kill ring"
(
(define-initial-key (list ctrl-x-char (integer->char 11)) procedure)
)
(let ((ring (current-kill-ring)))
(if (> argument (ring-size ring))
(editor-error "Not enough entries in the kill ring"))
(ring-stack-pop! ring argument)))
(define-initial-command-key ("^R Un-kill Pop" (argument 1))
"Correct after ^R Un-Kill to use an earlier kill."
(
(define-initial-key (list meta-char #\Y) procedure) ;;; M-Y
(define-initial-key (list alt-char (integer->char 21)) procedure);;;Alt-Y
)
(%edwin-un-kill-pop argument))
;;;; Marks
(define-initial-command-key ("^R Set/Pop Mark" argument)
"Sets or pops the mark."
(
(define-initial-key (list alt-char (integer->char 3)) procedure) ;;C-@
)
(let ((n (command-argument-multiplier-exponent)))
(cond ((zero? n) (push-current-mark! (current-point))
(temporary-message "Mark Set"))
((= n 1) (set-current-point! (pop-current-mark!)))
((= n 2) (pop-current-mark!))
(else (editor-error)))))
;;; These are temporarily commented out becuase the C-< and C-> ar blocked
;;; by DSR.
;;;(define-initial-command-key ("^R Mark Beginning" argument)
;;; "Set mark at beginning of buffer."
;;;(
;;;(define-initial-key (list ctrl-^-char #\<) procedure) ;;; C-^ <
;;;)
;;; (push-current-mark! (buffer-start (current-buffer))))
;;;
;;;(define-initial-command-key ("^R Mark End" argument)
;;; "Set mark at end of buffer."
;;;(
;;;(define-initial-key (list ctrl-^-char #\>) procedure) ;;; C-^ >
;;;)
;;; (push-current-mark! (buffer-end (current-buffer))))
(define-initial-command-key ("^R Mark Whole Buffer" argument)
"Set point at beginning and mark at end of buffer."
(
(define-initial-key (list ctrl-x-char #\H) procedure) ;;; C-X H
)
(push-current-mark! (current-point))
((if (not argument) set-current-region! set-current-region-reversed!)
(buffer-region (current-buffer))))
(define-initial-command-key ("^R Exchange Point and Mark" argument)
"Exchange positions of point and mark."
(
(define-initial-key (list ctrl-x-char ctrl-x-char) procedure) ;;; C-X C-X
)
(let ((point (current-point))
(mark (current-mark)))
(if (not mark) (editor-error "No mark to exchange"))
(set-current-point! mark)
(set-current-mark! point)))
;;;; Transposition
(define-initial-command-key ("^R Transpose Characters" (argument 1))
"Transpose the characters before and after the cursor."
(
(define-initial-key (integer->char 20) procedure) ;;; C-T
)
(%edwin-transpose-characters argument))
;;; These are commented out becuase are not bound to any keys. These may be
;;; used with extended commands
;;;; Search Commands
;;;; Character Search
;;;(define-initial-command-key ("^R Character Search" argument)
;;; "Search for a single character."
;;;(#!false)
;;; (let ((mark
;;; (find-next-char (current-point)
;;; (buffer-end (current-buffer))
;;; (prompt-for-char "Character Search"))))
;;; (if (not mark) (editor-error))
;;; (set-current-point! (mark1+ mark #!false))))
;;;
;;;(define-initial-command-key ("^R Reverse Character Search" argument)
;;; "Search backwards for a single character."
;;;(#!false)
;;; (let ((mark
;;; (find-previous-char (current-point)
;;; (buffer-start (current-buffer))
;;; (prompt-for-char "Reverse Character Search"))))
;;; (if (not mark) (editor-error))
;;; (set-current-point! (mark-1+ mark #!false))))
;;;; String Search
;; **** This is a per-editor variable. ****
(define previous-successful-search-string "")
;;;
;;;(define-initial-command-key ("^R String Search" argument)
;;; "Search for a character string."
;;;(#!false)
;;; (let ((string (prompt-for-string "String Search"
;;; previous-successful-search-string)))
;;; (let ((mark
;;; (find-next-string (current-point)
;;; (buffer-end (current-buffer))
;;; string)))
;;; (if (not mark) (editor-error))
;;; (set-current-point! (mark+ mark (string-length string) #!false)))
;;; (set! previous-successful-search-string string)))
;;;
;;;(define-initial-command-key ("^R Reverse String Search" argument)
;;; "Search backwards for a character string."
;;;(#!false)
;;; (let ((string (prompt-for-string "Reverse String Search"
;;; previous-successful-search-string)))
;;; (let ((mark
;;; (find-previous-string (current-point)
;;; (buffer-start (current-buffer))
;;; string)))
;;; (if (not mark) (editor-error))
;;; (set-current-point! mark))
;;; (set! previous-successful-search-string string)))
;;;; Incremental Search
(define-initial-command-key ("^R Incremental Search" argument)
"Search for character string as you type it."
(
(define-initial-key (integer->char 19) procedure) ;;; C-S
)
(incremental-search #!TRUE))
(define-initial-command-key ("^R Reverse Search" argument)
"Incremental Search Backwards."
(
(define-initial-key (integer->char 18) procedure) ;;; C-R
)
(incremental-search #!FALSE))
;;; Word Motion
(define-initial-command-key ("^R Forward Word" (argument 1))
"Move one or more words forward."
(
(define-initial-key (list meta-char #\f) procedure) ;;; M-F
(define-initial-key (list alt-char (integer->char 33)) procedure) ;;; alt-F
)
(move-thing forward-word argument))
(define-initial-command-key ("^R Backward Word" (argument 1))
"Move one or more words forward."
(
(define-initial-key (list alt-char (integer->char 48)) procedure) ;;; alt-B
(define-initial-key (list meta-char #\b) procedure) ;;; M-B
)
(move-thing backward-word argument))
(define-initial-command-key ("^R Mark Word" (argument 1))
"Set mark one or more words from point."
(
(define-initial-key (list meta-char #\@) procedure) ;;; M-@
(define-initial-key (list alt-char (integer->char 121)) procedure) ;;;alt-@
)
(mark-thing forward-word argument))
(define-initial-command-key ("^R Kill Word" (argument 1))
"Kill one or more words forward"
(
(define-initial-key (list meta-char #\d) procedure) ;;;M-D
(define-initial-key (list alt-char (integer->char 32)) procedure);;; Alt D
)
(kill-thing forward-word argument))
(define-initial-command-key ("^R Backward Kill Word" (argument 1))
"Kill one or more words backwards"
(
(define-initial-key (list meta-char #\backspace) procedure)
) ;;; alt is blocked
(kill-thing backward-word argument))
;;; Sentences
(define-initial-command-key ("^R Forward Sentence" (argument 1))
"Move one or more sentences forward."
(
(define-initial-key (list meta-char #\e) procedure) ;;; M-E
(define-initial-key (list alt-char (integer->char 18)) procedure) ;;; alt-E
)
(move-thing forward-sentence argument))
(define-initial-command-key ("^R Backward Sentence" (argument 1))
"Move one or more sentences forward."
(
(define-initial-key (list alt-char (integer->char 30)) procedure) ;;; alt-A
(define-initial-key (list meta-char #\a) procedure) ;;; M-A
)
(move-thing backward-sentence argument))
(define-initial-command-key ("^R Kill Sentence" (argument 1))
"Kill one or more sentences forward"
(
(define-initial-key (list meta-char #\k) procedure) ;;;M-K
(define-initial-key (list alt-char (integer->char 37)) procedure);;; Alt K
)
(kill-thing forward-sentence argument))
(define-initial-command-key ("^R Backward Kill Sentence" (argument 1))
"Kill one or more sentences backwards"
(
(define-initial-key (list ctrl-x-char #\backspace) procedure)
)
(kill-thing backward-sentence argument))
(define-initial-command-key ("^R Forward Paragraph" (argument 1))
"Move one or more paragraph forward."
(
(define-initial-key (list meta-char #\]) procedure) ;;; M-]
)
(move-thing forward-paragraph argument))
(define-initial-command-key ("^R Backward Paragraph" (argument 1))
"Move one or more sentences forward."
(
(define-initial-key (list meta-char #\[) procedure) ;;; M-[
)
(move-thing backward-paragraph argument))
(define-initial-command-key ("^R Mark Paragraph" (argument 1))
"mark the beginning and end of the paragraph"
(
(define-initial-key (list meta-char #\h) procedure)
(define-initial-key (list alt-char (integer->char 35)) procedure)
)
(let ((end (forward-paragraph (current-point) 1 'ERROR)))
(set-current-region! (make-region (backward-paragraph end 1 'ERROR) end))))


346
edwin/allcoms3.scm Normal file
View File

@ -0,0 +1,346 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Lisp commands
(define *current-mode-scheme?* #!true)
(define ^r-lisp-insert-paren-command '()) ;3.02
(define paren-mark '()) ;3.02
(define (cached-paren-mark) paren-mark) ;3.02
(define (cache-paren-mark mark) (set! paren-mark mark)) ;3.02
(define-initial-command-key ("^R Lisp Insert Paren" (argument 1))
"Insert close paren, showing matching parens"
( ;;;;(
(define-initial-key #\) procedure)
(set! ^r-lisp-insert-paren-command procedure) ;3.02
)
(insert-chars (current-command-char) argument (current-point))
(if *current-mode-scheme?*
(if (not (char-ready? buffer-screen))
(let ((mark (if (cached-paren-mark) ;3.02
(backward-sexp:top (cached-paren-mark) ;3.02
(group-start (current-point))
1)
(backward-one-list (current-point)
(group-start (current-point))))))
(if mark
(let ((string (line-string (mark-line mark))))
(cache-paren-mark mark) ;3.02
(set-temp-message-status)
(set-screen-cursor! typein-screen 0 0)
(%substring-display string (mark-position mark)
(string-length string) 0 typein-screen)
(if (window-mark-visible? (current-window) mark)
(let ((old-point (current-point)))
(set-current-point! mark)
(with-reverse-attributes)
(set-current-point! old-point))))
(beep))))))
;;;(define %%temp (lambda () (with-reverse-attributes)))
;;;
;;;
(define-initial-command-key ("^R Forward Sexp" (argument 1))
"Move forward one sexp"
(
(define-initial-key (list meta-char (integer->char 6)) procedure) ;;; M C-F
)
(move-thing forward-sexp argument))
(define-initial-command-key ("^R Backward Sexp" (argument 1))
"Move backward one sexp"
(
(define-initial-key (list meta-char (integer->char 2)) procedure) ;;; M C-B
)
(move-thing backward-sexp argument))
(define-initial-command-key ("^R Mark Sexp" (argument 1))
"Set mark one or more sexp from point."
(
(define-initial-key (list meta-char alt-char (integer->char 3)) procedure)
;;; C-M-@
)
(mark-thing forward-sexp argument))
(define-initial-command-key ("^R Kill Sexp" (argument 1))
"Kill one or more sexp forward"
(
(define-initial-key (list meta-char (integer->char 11)) procedure) ;;; M C-K
)
(kill-thing forward-sexp argument))
;;;(define-initial-command-key ("^R Backward Kill sexp" (argument 1))
;;; "Kill one or more words backwards"
;;;(
;;; (define-initial-key (list ctrl-z-char #\backspace) procedure) ;;; C-Z backsp
;;;)
;;; (kill-thing backward-sexp argument))
(define-initial-command-key ("^R Forward List"(argument 1))
"Move forward over one list"
(
(define-initial-key (list meta-char (integer->char 14)) procedure) ;; M C-N
)
(move-thing forward-list argument))
(define-initial-command-key ("^R Backward List"(argument 1))
"Move backward over one list"
(
(define-initial-key (list meta-char (integer->char 16)) procedure) ;; M C-P
)
(move-thing backward-list argument))
(define-initial-command-key ("^R Forward Down List" (argument 1))
"Move down one level of list structure, forward."
(
(define-initial-key (list meta-char (integer->char 4)) procedure) ;;M C-D
)
(move-thing forward-down-list argument))
;;; (define-initial-command-key ("^R Backward Down List" (argument 1))
;;; "Move down one level of list structure, backward."
;;;(#!false)
;;; (move-thing backward-down-list argument))
;;;(define-initial-command-key ("^R Forward Up List" (argument 1))
;;; "Move up one level of list structure, forward."
;;;( ;;;(
;;; (define-initial-key (list ctrl-z-char #\) ) procedure) ;;; ( C-Z )
;;;)
;;; (move-thing forward-up-list argument))
(define-initial-command-key ("^R Backward Up List" (argument 1))
"Move up one level of list structure, backward."
(
(define-initial-key (list meta-char (integer->char 21)) procedure)
)
(move-thing backward-up-list argument))
;;; New commands added
;;; Some additional commands
;;; File commands
(define-initial-command-key ("^R Set File Read Only" argument)
" Make file read-only, or not."
(
(define-initial-key (list ctrl-x-char (integer->char 17)) procedure);;C-XC-Q
)
(setup-current-buffer-read-only! argument))
(define-initial-command-key ("^R Buffer Not Modified" argument)
"Pretend that buffer has not been Modified."
(
(define-initial-key (list meta-char #\~) procedure) ;; M-~
)
(buffer-not-modified! (current-buffer)))
;;; Line Commands
(define-initial-command-key ("^R Open Line" (argument 1))
"Insert a newline at point. Cursor remains at its position."
(
(define-initial-key (integer->char 15) procedure) ;;;; C-O
)
(let ((m* (mark-right-inserting (current-point))))
(insert-newlines argument )
(set-current-point! m*)))
(define-initial-command-key ("^R Set Goal Column" argument)
"Set (or flush) a permanent goal for vertical motion"
(
(define-initial-key (list ctrl-x-char (integer->char 14)) procedure)
) ;;; C-X C-N
(set! goal-column
(and (not argument)
(mark-column (current-point)))))
(define-initial-command-key ("^R Tab" (argument 1))
"Insert a tab character"
(
(define-initial-key #\tab procedure)
(define-initial-key (integer->char 9) procedure)
(define-initial-key (list meta-char #\tab) procedure)
)
(if *current-mode-scheme?*
(lisp-indent-line (current-point))
(insert-chars #\tab argument (current-point))))
(define-initial-command-key ("^R Indent Sexp" (argument 1))
"Indent a sexp"
(
(define-initial-key (list meta-char (integer->char 17)) procedure) ;;M C-Q
)
(if *current-mode-scheme?*
(lisp-indent-sexp (current-point))))
(define-initial-command-key ("^R Change Mode" argument)
" Change mode to Scheme"
(
(define-initial-key (list ctrl-x-char (integer->char 13)) procedure);;C-X C-M
)
(set! *current-mode-scheme?* (if *current-mode-scheme?* #!false #!true))
(window-modeline-event! '() 'mode-changed))
(define-initial-command-key ("^R Delete Horizontal Space" argument)
" delete all spaces and tab characters around point."
(
(define-initial-key (list meta-char #\\) procedure) ;;; M-\
)
(delete-horizontal-space))
(define-initial-command-key ("^R Just One Space" argument)
" Delete all spaces and tabs around point, leaving one Space."
(
(define-initial-key (list meta-char #\space) procedure) ;;; M-space
)
(delete-horizontal-space)
(insert-chars #\space 1 (current-point)))
(define lisp-indent 2)
(define-initial-command-key ("^R Indent New Line" argument)
"Insert new line then indent the second line"
(
(define-initial-key (integer->char 10) procedure) ;;; C-J
)
(insert-newlines 1)
(if *current-mode-scheme?*
(lisp-indent-line (current-point))
(insert-chars #\tab 1 (current-point))))
;;; compile command
(define-initial-command-key ("^R Compile Region" argument)
" Compile the region"
(
(define-initial-key (list meta-char (integer->char 26)) procedure);;M C-Z
)
(if *current-mode-scheme?*
(%compile-region
(make-region (current-point) (current-mark)))
(^r-bad-command argument)))
(define-initial-command-key ("^R Compile Buffer" argument)
" Compile the buffer"
(
(define-initial-key (list meta-char #\o) procedure) ;;; M-O
(define-initial-key (list alt-char (integer->char 24)) procedure) ;;;alt O
)
(if *current-mode-scheme?*
(%compile-region
(buffer-region (current-buffer)))
(^r-bad-command argument)))
(define-initial-command-key ("^R Compile Sexp" (argument 1))
" Compile the sexp"
(
(define-initial-key (list meta-char (integer->char 24)) procedure);;;M C-X
)
(if *current-mode-scheme?*
(begin
(mark-thing forward-sexp argument)
(%compile-region (current-region)))
(^r-bad-command argument)))
(define (%compile-region region)
(region->file region "edwin.tmp")
(restore-console-contents)
(make-pcs-status-visible)
(reset-typein-window)
(gc)
(load "edwin.tmp")
((fluid editor-continuation) 'OK))
(define-initial-command-key ("^R Toggle windows" argument)
" Display edwin window in upper half and scheme in the lower half"
(
(define-initial-key (list ctrl-x-char #\!) procedure) ;;; C-X !
)
(if *split-screen-mode?*
(begin
(set! *split-screen-mode?* #!false)
(move-editor-to-full)
(move-pcs-to-full)
(make-pcs-status-invisible)
(window-y-size-changed (current-window))
(update-display! (current-window))
(reset-modeline-window)
(reset-typein-window))
(begin
(set! *split-screen-mode?* #!true)
(move-editor-to-upper-half)
(move-pcs-window-lower)
(window-y-size-changed (current-window))
(update-display! (current-window))
(reset-modeline-window)
(reset-typein-window)
(restore-console-contents)
(make-pcs-status-visible)
(gc))))
(define edwin-reset-windows
(lambda ()
(save-console-contents)
(make-pcs-status-visible)
(move-pcs-to-full)
(%clear-window blank-screen)
(restore-console-contents)
(gc)))

105
edwin/argred.scm Normal file
View File

@ -0,0 +1,105 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Command Argument Reader
;; Public
(define (with-command-argument-reader thunk)
(fluid-let ((*magnitude* '())
(*negative?* '())
(*multiplier-exponent* '())
(*autoargument-mode?* '()))
(thunk)))
;; Public
(define (reset-command-argument-reader!)
;; Call this at the beginning of a command cycle.
(set-fluid! *magnitude* #!FALSE)
(set-fluid! *negative?* #!FALSE)
(set-fluid! *multiplier-exponent* 0)
(set-fluid! *autoargument-mode?* #!FALSE))
;; Public
(define (command-argument-prompt)
(let ((prefix (if (autoargument-mode?) "Autoarg" "Arg"))
(value (command-argument-value)))
(cond (value (string-append prefix " " (obj->string value)))
((command-argument-negative?) (string-append prefix " -"))
(else ""))))
;; Public
(define (command-argument-negative?)
(fluid *negative?*))
;; Public
(define (command-argument-value)
;; This returns the numeric value of the argument, or #!FALSE if none.
(let ((m (command-argument-magnitude))
(s (command-argument-multiplier-exponent)))
(and (or m (not (zero? s)))
((if (command-argument-negative?) - identity-procedure)
(* (or m 1)
(integer-expt (command-argument-multiplier-base) s))))))
;; Public
(define (command-argument-magnitude)
(fluid *magnitude*))
;; Public
(define (command-argument-multiplier-exponent)
(fluid *multiplier-exponent*))
;; Public
(define (command-argument-multiplier-base)
*multiplier-base*)
;; Public
(define (autoargument-mode?)
(fluid *autoargument-mode?*))
;;;; Value
(define integer-expt
(lambda (b e)
(if (zero? e)
1
(* b (integer-expt b (sub1 e))))))


198
edwin/argredp.scm Normal file
View File

@ -0,0 +1,198 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Command Argument Reader
;;; This code isn't packaged yet. Public definitions are marked.
;;;; Description
;;;
;;; 1. The reader keeps track of:
;;;
;;; [] The MAGNITUDE of the argument. If there are no digits, the
;;; magnitude is #!FALSE.
;;; [] The SIGN of the argument.
;;; [] The MULTIPLIER-EXPONENT, which is the number of C-U's typed.
;;; [] Whether or not "Autoargument mode" is in effect. In autoarg
;;; mode, ordinary digits are interpreted as part of the argument;
;;; normally they are self-insering.
;;;
;;; 2. It has the following (alterable) parameters:
;;;
;;; [] RADIX, which is between 2 and 36 inclusive. (default: 10)
;;; [] MULTIPLIER-BASE, a non-negative integer. (default: 4)
;;;
;;; 3. From these, it can compute:
;;;
;;; [] VALUE = (* MAGNITUDE MULTIPLIER-EXPONENT MULTIPLIER-BASE).
;;; If the magnitude is #!FALSE, then the value is too.
;;;; Primitives
;; Public
;(define (with-command-argument-reader thunk)
;; Public
;(define (reset-command-argument-reader!)
;; Public
(define (update-argument-prompt!)
(set-command-prompt! (command-argument-prompt)))
;; Public
;(define (command-argument-prompt)
;;;; Argument Number
(define *radix*)
;; Public
(define (command-argument-accumulate-digit! digit-char)
(maybe-reset-multiplier-exponent!)
(let ((digit (or (char->digit digit-char *radix*)
(error "Not a valid digit" digit-char))))
(set-fluid! *magnitude*
(if (not (fluid *magnitude*))
digit
(+ digit (* *radix* (fluid *magnitude*)))))))
;; Public
(define (set-command-argument-radix! n)
(if (not (and (integer? n) (<= 2 n) (<= n 36)))
(error "Radix must be an integer between 2 and 36, inclusive" n))
(set! *radix* n))
;; Public
(define (command-argument-negate!)
(maybe-reset-multiplier-exponent!)
(set-fluid! *negative?* (not (fluid *negative?*))))
;; Public
;(define (command-argument-magnitude)
;; Public
(define (command-argument-radix)
*radix*)
;; Public
;(define (command-argument-negative?)
;; **** Kludge ****
(set-command-argument-radix! 10)
;;;; Argument Multiplier
(define *multiplier-base*)
;; Public
(define (command-argument-increment-multiplier-exponent!)
(set-fluid! *multiplier-exponent* (1+ (fluid *multiplier-exponent*))))
(define (maybe-reset-multiplier-exponent!)
(if (and (not (fluid *magnitude*))
(= (fluid *multiplier-exponent*) 1))
(set-fluid! *multiplier-exponent* 0)))
;; Public
;(define (command-argument-multiplier-exponent)
;; Public
;(define (command-argument-multiplier-base)
;; Public
(define (set-command-argument-multiplier-base! n)
(if (not (and (integer? n) (not (negative? n))))
(error "Multiplier Base" n "must be a non-negative integer."))
(set! *multiplier-base* n))
;; **** Kludge ****
(set-command-argument-multiplier-base! 4)
;;;; Autoargument Mode
;; Public
(define (enter-autoargument-mode!)
(set-fluid! *autoargument-mode?* #!TRUE))
;; *** Is this needed? ***
;;(define (exit-autoargument-mode!)
;; (set-fluid! *autoargument-mode?* #!FALSE))
;; Public
;(define (autoargument-mode?)
;;;; Value
;(define integer-expt
;; Public
;(define (command-argument-value)
;; Public
(define (command-argument-multiplier-only?)
(and (not (fluid *magnitude*))
(not (zero? (fluid *multiplier-exponent*)))
(fluid *multiplier-exponent*)))
;; Public
(define (command-argument-negative-only?)
(and (not (fluid *magnitude*))
(zero? (fluid *multiplier-exponent*))
(fluid *negative?*)))
;; Public
(define (command-argument-beginning?)
(and (not (fluid *magnitude*))
(not (fluid *negative?*))
(< (fluid *multiplier-exponent*) 2)))
(define (%edwin-autoargument argument)
(let ((char (char-base (current-command-char))))
(if (eq? char #\-)
(if (command-argument-beginning?)
(begin (enter-autoargument-mode!)
(^r-negative-argument-command argument))
(insert-chars char argument (current-point)))
(begin (enter-autoargument-mode!)
(^r-argument-digit-command argument)))))


144
edwin/autoload.scm Normal file
View File

@ -0,0 +1,144 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(autoload-from-file
(%system-file-name "edwin1.fsl")
'(%edwin-autoargument
command-argument-increment-multiplier-exponent!
update-argument-prompt!
command-argument-accumulate-digit!
set-command-argument-radix! command-argument-negate!
command-argument-radix
set-command-argument-multiplier-base!
enter-autoargument-mode! command-argument-multiplier-only?
command-argument-negative-only? command-argument-beginning?
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin2.fsl")
'(
bufferset-select-buffer! bufferset-find-buffer
bufferset-create-buffer
bufferset-find-or-create-buffer
bufferset-kill-buffer!
bufferset-rename-buffer
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin3.fsl")
'(
twiddle-characters
%edwin-transpose-characters
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin4.fsl")
'(
append-next-kill-tag delete-region kill-region
%kill-region un-kill-region
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin5.fsl")
'(
copy-region un-kill-region-reversed %edwin-un-kill-pop
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin6.fsl")
'(
lisp-indent-line lisp-indent-sexp
forward-sexp backward-sexp
forward-list backward-list forward-down-list
backward-down-list forward-up-list backward-up-list
backward-up-one-list
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin7.fsl")
'(
incremental-search
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin8.fsl")
'(
forward-word backward-word
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin9.fsl")
'(
match-next-strings match-next-string
match-previous-strings match-previous-string
match-next-substring match-previous-substring
match-next-char match-previous-char
match-next-char-in-set match-previous-char-in-set
)
edwin-environment
)
(autoload-from-file
(%system-file-name "edwin10.fsl")
'(
forward-sentence backward-sentence
forward-paragraph backward-paragraph
)
edwin-environment
)


174
edwin/buffer.scm Normal file
View File

@ -0,0 +1,174 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Buffer Abstraction
(define-named-structure "Buffer"
name
group
point
mark-ring
modified?
windows
cursor-y
pathname
truename
writeable?
alist)
(define (make-buffer name)
(let ((group (region-group (string->region ""))))
(let ((buffer (%make-buffer)))
(vector-set! buffer buffer-index:name name)
(vector-set! buffer buffer-index:group group)
(set-buffer-point! buffer (%group-start group))
(vector-set! buffer buffer-index:mark-ring (make-ring 10))
(ring-push! (buffer-mark-ring buffer) (%group-start group))
(vector-set! buffer buffer-index:modified? #!FALSE)
(vector-set! buffer buffer-index:windows '())
(vector-set! buffer buffer-index:cursor-y #!FALSE)
(vector-set! buffer buffer-index:pathname #!FALSE)
(vector-set! buffer buffer-index:truename #!FALSE)
(vector-set! buffer buffer-index:writeable? #!TRUE)
(vector-set! buffer buffer-index:alist '())
(let ((daemon (make-buffer-modification-daemon buffer)))
(add-group-insert-daemon! group daemon)
(add-group-delete-daemon! group daemon))
buffer)))
(define (buffer-region buffer)
(group-region (buffer-group buffer)))
(define (buffer-start buffer)
(%group-start (buffer-group buffer)))
(define (buffer-end buffer)
(%group-end (buffer-group buffer)))
(define (buffer-modeline-event! buffer type)
(define (loop windows)
(if (not (null? windows))
(begin (window-modeline-event! (car windows) type)
(loop (cdr windows)))))
(loop (buffer-windows buffer)))
(define (add-buffer-window! buffer window)
(vector-set! buffer buffer-index:windows
(cons window (vector-ref buffer buffer-index:windows))))
(define (set-buffer-cursor-y! buffer cursor-y)
(vector-set! buffer buffer-index:cursor-y cursor-y))
(define (set-buffer-name! buffer name)
(vector-set! buffer buffer-index:name name)
(buffer-modeline-event! buffer 'BUFFER-NAME))
(define (set-buffer-pathname! buffer pathname)
(vector-set! buffer buffer-index:pathname pathname)
(buffer-modeline-event! buffer 'BUFFER-PATHNAME))
(define (set-buffer-truename! buffer truename)
(vector-set! buffer buffer-index:truename truename)
(buffer-modeline-event! buffer 'BUFFER-TRUENAME))
(define (set-buffer-point! buffer mark)
;; Each window has its own point, so instead of signalling a point
;; change from here, the window's point is changed and it tells
;; the buffer about it.
(vector-set! buffer buffer-index:point
(if (mark-left-inserting? mark)
mark
(%make-mark (mark-line mark)
(mark-position mark) #!true))))
(define ((make-buffer-modification-daemon buffer) . args)
(buffer-modified! buffer)
#!FALSE)
(define (buffer-not-modified! buffer)
(set-buffer-modified! buffer #!FALSE))
(define (buffer-modified! buffer)
(set-buffer-modified! buffer #!TRUE))
(define (set-buffer-modified! buffer sense)
(vector-set! buffer buffer-index:modified? sense)
(buffer-modeline-event! buffer 'BUFFER-MODIFIED))
(define (buffer-read-only? buffer)
(group-read-only? (buffer-group buffer)))
(define (set-buffer-writeable! buffer)
(set-group-writeable! (buffer-group buffer))
(vector-set! buffer buffer-index:writeable? #!TRUE)
(buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
(define (set-buffer-file-read-only! buffer)
(set-group-writeable! (buffer-group buffer))
(vector-set! buffer buffer-index:writeable? #!FALSE)
(buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
(define (set-buffer-read-only! buffer)
(set-group-read-only! (buffer-group buffer))
(vector-set! buffer buffer-index:writeable? #!FALSE)
(buffer-modeline-event! buffer 'BUFFER-MODIFIABLE))
;;; Not used currently so commented out
;;;(define (with-read-only-defeated mark thunk)
;;; (let ((group (mark-group mark)))
;;; (define read-only?)
;;; (dynamic-wind (lambda ()
;;; (set! read-only? (group-read-only? group))
;;; (if read-only?
;;; (set-group-writeable! group)))
;;; thunk
;;; (lambda ()
;;; (if read-only?
;;; (set-group-read-only! group))))))
;;;
;;;


65
edwin/bufset.scm Normal file
View File

@ -0,0 +1,65 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Buffer Set Abstraction
(define-named-structure "Bufferset"
buffer-list
names)
;;; bufferset changed to not use string tables
;;;
;;;(define (make-bufferset initial-buffer)
;;; (let ((bufferset (%make-bufferset))
;;; (names (make-string-table)))
;;; (string-table-put! names (buffer-name initial-buffer) initial-buffer)
;;; (vector-set! bufferset bufferset-index:buffer-list (list initial-buffer))
;;; (vector-set! bufferset bufferset-index:names names)
;;; bufferset))
(define (make-bufferset initial-buffer)
(let ((bufferset (%make-bufferset))
(names '()))
(set! names (cons (cons (buffer-name initial-buffer) initial-buffer) names))
(vector-set! bufferset bufferset-index:buffer-list (list initial-buffer))
(vector-set! bufferset bufferset-index:names names)
bufferset))


82
edwin/bufsetp.scm Normal file
View File

@ -0,0 +1,82 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;code for bufferset commands??
(define (bufferset-select-buffer! bufferset buffer)
(if (memq buffer (bufferset-buffer-list bufferset))
(vector-set! bufferset bufferset-index:buffer-list
(cons buffer
(delq! buffer (bufferset-buffer-list bufferset))))))
(define (bufferset-find-buffer bufferset name)
(string-table-get (bufferset-names bufferset) name))
(define (bufferset-create-buffer bufferset name)
(if (bufferset-find-buffer bufferset name)
(error "Attempt to re-create buffer" name))
(let ((buffer (make-buffer name)))
(string-table-put! (bufferset-names bufferset) name buffer)
(vector-set! bufferset bufferset-index:buffer-list
(append! (bufferset-buffer-list bufferset)
(list buffer)))
buffer))
(define (bufferset-find-or-create-buffer bufferset name)
(or (bufferset-find-buffer bufferset name)
(bufferset-create-buffer bufferset name)))
(define (bufferset-kill-buffer! bufferset buffer)
(if (not (memq buffer (bufferset-buffer-list bufferset)))
(error "Attempt to kill unknown buffer" buffer))
(vector-set! bufferset bufferset-index:buffer-list
(delq! buffer (bufferset-buffer-list bufferset)))
(string-table-remove! (bufferset-names bufferset) (buffer-name buffer)))
(define (bufferset-rename-buffer bufferset buffer new-name)
(if (not (memq buffer (bufferset-buffer-list bufferset)))
(error "Attempt to rename unknown buffer" buffer))
(if (bufferset-find-buffer bufferset new-name)
(error "Attempt to rename buffer to existing buffer name" new-name))
(let ((names (bufferset-names bufferset)))
(string-table-remove! names (buffer-name buffer))
(set-buffer-name! buffer new-name)
(string-table-put! names new-name buffer)))

82
edwin/charmac.scm Normal file
View File

@ -0,0 +1,82 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Character Sets macros
(macro make-char-set
(lambda (e)
(list->string (cdr e))))
(define (%loop code chars predicate)
(if (< code 256)
(let ((char (integer->char code)))
(%loop (1+ code)
(if (predicate char)
(cons char chars)
chars)
predicate))
chars))
(macro predicate->char-set
(lambda (e)
(list->string (%loop 0 '() (eval (cadr e))))))
(macro char-set-invert
(lambda (e)
(list->string (%loop 0 '()
(lambda (char)
(not (char-set-member? (eval (cadr e)) char)))))))
(macro char-set-union
(lambda (e)
(list->string (%loop 0 '()
(lambda (char)
(or (char-set-member? (eval (cadr e)) char)
(char-set-member? (eval (caddr e)) char)))))))
(macro make-non-graphic-char-set
(lambda (e)
(let ((set (make-string 32 (integer->char 128))))
(do ((i 0 (1+ i)))
((= i 32) set)
(string-set! set i (integer->char i))))))

121
edwin/charset.scm Normal file
View File

@ -0,0 +1,121 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define char<=
(lambda (a1 c e1)
(and (char<=? a1 c)
(char<=? c e1))))
(define (char-set-member? char-set char)
(substring-find-next-char-in-set char-set 0 (string-length char-set) char))
;;; Character Sets
(define char-set:whitespace
(make-char-set #\Space #\Newline
#\Tab #\Return #\Page
))
(define char-set:not-whitespace
(char-set-invert char-set:whitespace))
(define char-set-predicate
(lambda (char-set)
(let ((len (string-length char-set)))
(lambda (char)
(substring-find-next-char-in-set char-set 0 len char)))))
(define char-whitespace? (char-set-predicate char-set:whitespace))
(define char-set:alphabetic
(predicate->char-set
(lambda (char)
(or (char<= #\A char #\Z)
(char<= #\a char #\z)))))
(define char-alphabetic? (char-set-predicate char-set:alphabetic))
(define char-set:alphanumeric
(predicate->char-set
(lambda (char)
(or (char<= #\0 char #\9)
(char<= #\A char #\Z)
(char<= #\a char #\z)))))
(define char-set:graphic
(char-set-union char-set:alphanumeric
(make-char-set #\! #\" #\# #\$ #\% #\& #\' #\( #\) #\*
#\+ #\, #\- #\. #\/ #\: #\; #\< #\= #\>
#\? #\@ #\[ #\\ #\] #\^ #\_ #\` #\{ #\|
#\} #\~ #\Space)))
(define char-graphic? (char-set-predicate char-set:graphic))
(define sexp-delims (make-char-set #\( #\)))
(define char-set:blanks (make-char-set #\Space #\Tab))
(define char-blank? (char-set-predicate char-set:blanks))
(define char-set:non-blanks (char-set-invert char-set:blanks))
;define find-next-blank (char-set-forward-search char-set:blanks))
;define find-previous-blank (char-set-backward-search char-set:blanks))
(define word-constituent-chars
(char-set-union char-set:alphanumeric
(make-char-set #\$ #\% #\.)))
(define word-delimiter-chars
(char-set-invert word-constituent-chars))
(define sexp-constituent-chars
(char-set-union char-set:alphanumeric
(make-char-set #\! #\$ #\% #\* #\/ #\: #\< #\= #\> #\? #\_
#\- #\+ #\~ #\@ #\# #\^)))
(define sexp-delimeter-chars (char-set-invert sexp-constituent-chars))
(define char-set-sexp? (char-set-predicate sexp-constituent-chars))
(define non-graphic-chars (make-non-graphic-char-set))

108
edwin/coedwin.scm Normal file
View File

@ -0,0 +1,108 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 10/21/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define source-dir "")
(define fastload-dir "")
(define dist-dir "")
(define dev)
(begin
;;(writeln "Optimize define integrables ? ")
;;(if (eq? (read) 'y)
(begin
(set! dev #!true)
(load (string-append source-dir "de.scm")))
;; (begin
;; (set! dev #!false))
)
(define Version
((rec loop
(lambda ()
;;; (writeln "Enter Version Number for Edwin (string) : ")
(let ((version "3.03"))
(if (string? version)
version
(begin
(writeln "Please use a string")
(loop))))))))
(macro make-version
(lambda (exp)
`(define-integrable edwin-version ,version)))
(make-version)
(define load-file
(let ((n 1))
(lambda (file)
(if (< n stop-files)
(begin
(if (> n skip-files)
(let ((file1 (string-append source-dir file ".scm"))
(file2 (string-append (if dev dist-dir fastload-dir)
file ".so")))
(writeln "Compiling File : " file1)
(gc)
(compile-file file1 file2)
(writeln "File " file1 " compiled to " file2)
(if (not dev)
(dos-call "" (string-append "make_fsl "
file ".so"
" "
file
".f"))))
(let ((fsl (string-append fastload-dir file ".f")))
(writeln "Fast Loading " fsl)
(fast-load fsl)))
(set! n (+ n 1)))))))
(define skip-files 0)
(define stop-files 1000)
(define ld
(lambda (no)
(set! skip-files no)))
(define ls
(lambda (no)
(set! stop-files no)))


90
edwin/coedwin2.scm Normal file
View File

@ -0,0 +1,90 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load-file "commac") ;;; 0
(load-file "comfun")
(load-file "emacros")
(load-file "dwind")
(load-file "charmac")
(load-file "charset")
(load-file "strcomp")
(load-file "nstring")
(load-file "struct")
(load-file "regops")
(load-file "comtabv") ;;; 10
(load-file "initmac")
(load-file "initkey")
(load-file "buffer")
(load-file "bufset")
(load-file "bufsetp")
(load-file "ring")
(load-file "motion")
(load-file "redisp1")
(load-file "redisp2")
(load-file "insert80") ;20
(load-file "main")
(load-file "curr")
(load-file "marks")
(load-file "messages")
(load-file "modeln");;; 25
(load-file "argred")
(load-file "argredp")
(load-file "toplevel")
(load-file "allcoms1")
(load-file "allcoms2") ;30
(load-file "allcoms3")
(load-file "io")
(load-file "kill1")
(load-file "kill2")
(load-file "search1") ;;; 35
(load-file "search2")
(load-file "things")
(load-file "incser")
(load-file "words")
(load-file "transpos") ;;; 40
(load-file "parens")
(load-file "lisp")
(load-file "sentence") ;;; 43
(exit)


49
edwin/coedwin3.scm Normal file
View File

@ -0,0 +1,49 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load-file "ldchset")
(exit)


51
edwin/coedwin4.scm Normal file
View File

@ -0,0 +1,51 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;(load-file "ldall")
(load (%system-file-name "PBOOT.FSL"))
(pcs-compile-file "ldall.scm" "ldall.so")
(pcs-compile-file "dummy.scm" "dummy.so")
(exit)


114
edwin/comfun.scm Normal file
View File

@ -0,0 +1,114 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; sum global definitions
(define integer-divide
(lambda (a b)
(cons (quotient a b) (remainder a b))))
(define integer-divide-quotient car)
(define integer-divide-remainder cdr)
(define char->name
(lambda (char)
(define (%char->name char)
(let ((i (char->integer char)))
(cond ((zero? i) "")
((= i 27) "Meta-")
((and (>= i 1) (<= i 31))
(string-append "Ctrl-" (char->name (integer->char (+ i 64)))))
(t (list->string (list char))))))
(if (atom? char)
(%char->name char)
(string-append (%char->name (car char))
(%char->name (cadr char))))))
(define string-append-separated
(lambda (s1 s2)
(cond ((zero? (string-length s1)) s2)
((zero? (string-length s2)) s1)
(else (string-append s1 " " s2)))))
(define string-append-with-blanks
(lambda strings
((rec loop
(lambda (strings)
(if (null? strings) ""
(string-append-separated (car strings) (loop (cdr strings))))))
strings)))
(define char->string
(lambda (char)
(if (char? char)
(char->name char)
(error "Bad argument to char->string" char))))
(define list->string*
(lambda (l)
(if (pair? l)
(string-append "("
(apply string-append-with-blanks
(mapcar obj->string l))
")")
(error "Bad argument to list->string*" l))))
(define obj->string
(lambda (obj)
(cond ((pair? obj) (list->string* obj))
((char? obj) (char->string obj))
((integer? obj) (number->string obj '(INT)))
((null? obj) "()")
(t (error "Bad argument to obj->string" obj)))))
(define char-base char->integer)
(define char->digit
(lambda (i radix)
(- i (char->integer #\0))))
(define identity-procedure (lambda (x) x))

96
edwin/commac.scm Normal file
View File

@ -0,0 +1,96 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; equating language feature
(alias vector-cons make-vector)
(alias vector-size vector-length)
(alias conjunction and)
(alias disjunction or)
(macro string-allocate
(lambda (e)
(list 'make-string (cadr e) " ")))
;;; Following equations are temporary till I understand them better
(macro without-interrupts
(lambda (e)
(cdr e)))
(macro define-unparser
(lambda (e)
'()))
(macro declare (lambda (e) '()))
(macro integrate (lambda (e) '()))
(macro primitive-datum
(lambda (e) (cadr e)))
(macro set!
(lambda (e)
(if (= 2 (length e))
(list (car e) (cadr e) '#!unassigned)
e)))
;;; some to remove name clashes
;;; line-length is a pcs primitive. we are changing it to line-string-length
;;; by defining a macro.
(define-integrable line-string-length
(lambda (line)
(string-length (line-string line))))
(macro line-length
(lambda (e)
(cons 'line-string-length (cdr e))))


155
edwin/comtabv.scm Normal file
View File

@ -0,0 +1,155 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Command Tables
(define comtab '(()()))
(define default-key #!false)
(define (%set-comtab-key comtab char command)
(vector-set! (cdr comtab) (char->integer char) command))
(define (%set-comtab-entry! alists char command)
(let ((entry (assq char (cdr alists))))
(if entry
(set-cdr! entry command)
(set-cdr! alists (cons (cons char command) (cdr alists))))))
(define (%comtab-make-prefix-char! alists char alists*)
(let ((entry (assq char (car alists))))
(if entry
(set-cdr! entry alists*)
(set-car! alists (cons (cons char alists*) (car alists))))))
(define (comtab-lookup-prefix char receiver)
(define (loop char->alist chars)
(let ((entry (assq (car chars) char->alist)))
(if entry
(if (null? (cddr chars))
(receiver (cdr entry) (cadr chars))
(loop (cadr entry) (cdr chars)))
(error "Not a prefix character" (car chars)))))
(cond ((char? char)
(receiver comtab char))
((pair? char)
(if (null? (cdr char))
(receiver comtab (car char))
(loop (car comtab) char)))
(else
(error "Unrecognizable character" char))))
(define comtab-entry
(letrec
((ychar '())
(receiver
(lambda (alists char)
(let ((entry (assq char (cdr alists))))
(cond (entry (cdr entry))
(default-key default-key)
(t (editor-error (string-append "Unknown command: "
(obj->string ychar)))))))))
(lambda (xchar)
(letrec
((lookup-vector
(lambda (*char*)
(let ((*int* (char->integer *char*)))
(if (< *int* 256) ;;; change to 256 for internationalize
(vector-ref (cdr comtab) *int*)
default-key)))))
(cond ((char? xchar) (lookup-vector xchar))
((and (pair? xchar) (null? (cdr xchar)))
(lookup-vector (car xchar)))
(else (set! ychar xchar)
(comtab-lookup-prefix xchar receiver)))))))
(define (set-comtab-entry! char command)
(comtab-lookup-prefix char
(lambda (alists char)
(%set-comtab-entry! alists char command))))
;;; These are not used becuase the initkey stuff is used to define keys
;;;(define (define-key char command-name)
;;; (let ((command (name->command command-name)))
;;; (cond ((char? char)
;;; (%set-comtab-key comtab (char-upcase char) command)
;;; (if (char-alphabetic? char)
;;; (%set-comtab-key comtab (char-downcase char) command)))
;;; ((and (pair? char) (null? (cdr char)))
;;; (%set-comtab-key comtab (char-upcase (car char)) command)
;;; (if (char-alphabetic? char)
;;; (%set-comtab-key comtab (char-downcase (car char)) command)))
;;; ((pair? char)
;;; (comtab-lookup-prefix char
;;; (lambda (alists char)
;;; (let ((upcase (char-upcase char)))
;;; (%set-comtab-entry! alists upcase command)
;;; (if (char-alphabetic? char)
;;; (%set-comtab-entry! alists (char-downcase char)
;;; command))))))
;;; ((char-set? char)
;;; (mapc (lambda (char) (set-comtab-entry! char command))
;;; (char-set-members char)))
;;; (else (error "Unknown character" char))))
;;; char)
;;;
;;;(define (define-prefix-key char command-name)
;;; (let ((command (name->command command-name)))
;;; (cond ((or (char? char) (pair? char))
;;; (comtab-lookup-prefix char
;;; (lambda (alists char)
;;; (let ((upcase (char-upcase char)))
;;; (%set-comtab-key alists upcase command)
;;; (%comtab-make-prefix-char! alists upcase (cons '() '()))
;;; (if (char-alphabetic? char)
;;; (%comtab-make-synonym-char! alists (char-downcase char)
;;; alists upcase))))))
;;; (else (error "Unknown character" char))))
;;; char)
;;;
;;;(define (define-default-key command-name)
;;; (let ((command (name->command command-name)))
;;; (set! default-key command)
;;; (set-cdr! comtab (make-vector 128 command))))


184
edwin/curr.scm Normal file
View File

@ -0,0 +1,184 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Current State
;;;; Windows
(begin
(define-integrable current-window
(lambda ()
(current-buffer-window)))
;;;; Buffers
(define-integrable buffer-list
(lambda ()
(bufferset-buffer-list (current-bufferset))))
(define-integrable buffer-names
(lambda ()
(bufferset-names (current-bufferset))))
(define-integrable current-buffer
(lambda ()
(window-buffer (current-window))))
(define-integrable find-buffer
(lambda (name)
(bufferset-find-buffer (current-bufferset) name)))
(define-integrable create-buffer
(lambda (name)
(bufferset-create-buffer (current-bufferset) name)))
(define-integrable find-or-create-buffer
(lambda (name)
(bufferset-find-or-create-buffer (current-bufferset) name)))
(define-integrable rename-buffer
(lambda (buffer new-name)
(bufferset-rename-buffer (current-bufferset) buffer new-name)))
(define-integrable current-point
(lambda ()
(window-point (current-window))))
(define-integrable set-current-point!
(lambda (mark)
(set-window-point! (current-window) mark)))
(define-integrable current-mark
(lambda ()
(buffer-mark (current-buffer))))
(define-integrable set-current-mark!
(lambda (mark)
(set-buffer-mark! (current-buffer) mark)))
(define-integrable push-current-mark!
(lambda (mark)
(push-buffer-mark! (current-buffer) mark)))
(define-integrable pop-current-mark!
(lambda ()
(pop-buffer-mark! (current-buffer))))
(define-integrable current-region
(lambda ()
(make-region (current-point) (current-mark))))
)
;;; These have been commented out as are not currently used. However,
;;; these are useful routines and should not be deleted from this file.
;;;(define (kill-buffer buffer)
;;; (let ((new-buffer (other-buffer buffer))
;;; (current? (eq? buffer (current-buffer)))
;;; (windows (buffer-windows buffer)))
;;; (if (and (not new-buffer) (not (null? windows)))
;;; (error "Buffer to be killed has no replacement" buffer))
;;; (bufferset-kill-buffer! (current-bufferset) buffer)
;;; (if current? (select-buffer new-buffer))
;;; (mapc (lambda (window) (set-window-buffer! window new-buffer))
;;; windows)))
;;;(define (with-current-window new-window thunk)
;;; (define old-window)
;;; (dynamic-wind (lambda ()
;;; (set! old-window (current-window))
;;; (select-window (set! new-window)))
;;; thunk
;;; (lambda ()
;;; (set! new-window (current-window))
;;; (select-window (set! old-window)))))
;;;
;;;(define (with-selected-buffer buffer thunk)
;;; (define old-buffer)
;;; (dynamic-wind (lambda ()
;;; (set! old-buffer (current-buffer))
;;; (select-buffer-no-record buffer))
;;; thunk
;;; (lambda ()
;;; (set! buffer (current-buffer))
;;; (select-buffer-no-record old-buffer))))
;;;; Point and Mark
;;;(define (with-current-point new-point thunk)
;;; (define old-point)
;;; (dynamic-wind (lambda ()
;;; (set! old-point (current-point))
;;; (set-current-point! new-point))
;;; thunk
;;; (lambda ()
;;; (set! new-point (current-point))
;;; (set-current-point! old-point))))
(define (buffer-mark buffer)
(let ((ring (buffer-mark-ring buffer)))
(if (ring-empty? ring) (editor-error))
(ring-ref ring 0)))
(define (set-buffer-mark! buffer mark)
(ring-set! (buffer-mark-ring buffer)
0
(mark-right-inserting mark)))
(define (push-buffer-mark! buffer mark)
(ring-push! (buffer-mark-ring buffer)
(mark-right-inserting mark)))
(define (pop-buffer-mark! buffer)
(ring-pop! (buffer-mark-ring buffer)))
(define (set-current-region! region)
(set-current-point! (region-start region))
(push-current-mark! (region-end region)))
(define (set-current-region-reversed! region)
(push-current-mark! (region-start region))
(set-current-point! (region-end region)))


50
edwin/de.scm Normal file
View File

@ -0,0 +1,50 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macro define-integrable
(lambda (form)
(pcs-chk-length= form form 3)
(let ((id (cadr form))
(exp (caddr form)))
(pcs-chk-id form id)
(putprop id (cons 'define-integrable exp) 'pcs*primop-handler)
'())))


4
edwin/demstart.scm Normal file
View File

@ -0,0 +1,4 @@
(start-tutorial)
(demo)


46
edwin/doedwi2a.scm Normal file
View File

@ -0,0 +1,46 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 6/11/87
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load (%system-file-name "pboot.fsl"))
(pcs-compile-file "autoload.scm" "autoload.so")
(pcs-compile-file "edinit.scm" "edinit.so")
(exit)


5
edwin/doedwin1.scm Normal file
View File

@ -0,0 +1,5 @@
; this is the file "doedwin1.scm"
(load "coedwin.scm")
(load "coedwin2.scm")


5
edwin/doedwin2.scm Normal file
View File

@ -0,0 +1,5 @@
; this is the file "doedwin2.scm"
(load "coedwin.scm")
(load "coedwin3.scm")


5
edwin/doedwin3.scm Normal file
View File

@ -0,0 +1,5 @@
; this is the file "doedwin3.scm"
(load "coedwin.scm")
(load "coedwin4.scm")


18
edwin/dummy.scm Normal file
View File

@ -0,0 +1,18 @@
;;; Dummy Module to replace EDWIN0.FSL on Diskette 1 of a dual floppy
;;; installation.
;;;
;;; Note: this module must be compiled using the pcs-compile-file
;;; procedure found in PBOOT.FSL as follows:
;;;
;;; (load "pboot.fsl") ; if not already loaded
;;; (pcs-compile-file "dummy.s" "dummy.so")
(begin
(newline)
(display "Replace PC Scheme diskette 1 with PC Scheme")
(newline)
(display "diskette 2 and re-enter (EDWIN) command . . .")
(newline)
(display #\space)
(reset))


120
edwin/dwind.scm Normal file
View File

@ -0,0 +1,120 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Copyright Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; Dynamic Wind ;;;
;;; ;;;
;;; File Updated : May 23, 1985 ;;;
;;; ;;;
;;; This file contains the code to implement dynamic ;;;
;;; wind. User interacts by using dynamic-wind and ;;;
;;; call/cc-dw. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; macros for states
(macro make-new-state
(lambda (e)
(cons 'vector (cdr e))))
(macro %in-out-flag
(lambda (e)
(list 'vector-ref (cadr e) 0)))
(macro %before
(lambda (e)
(list 'vector-ref (cadr e) 1)))
(macro %after
(lambda (e)
(list 'vector-ref (cadr e) 2)))
(macro %next
(lambda (e)
(list 'vector-ref (cadr e) 3)))
(macro %set-next
(lambda (e)
(list 'vector-set! (cadr e) 3 (caddr e))))
(alias %in? %in-out-flag)
;;;
;;; State Space - routines
;;;
(define dynamic-wind '())
(define call/cc-dw '())
(letrec
((%state-space (vector #!TRUE nil nil nil))
(extend-state-space
(lambda (state)
(%set-next %state-space state)
(set! %state-space state)))
(execute-at-new-state
(lambda (state)
(letrec
((loop
(lambda (previous current)
(if (not (null? (%next current)))
(loop current (%next current)))
(%set-next current previous)
(if (%in? current)
((%after current))
((%before current)))))
(reroot-state-space
(lambda ()
(loop state (%next state))
(%set-next state nil)
(set! %state-space state)))
(recompute-new-state
(lambda ()
(if (not (%in? state))
((%before state))))))
(if (not (eq? state %state-space))
(begin
(reroot-state-space)
(recompute-new-state)))))))
;;;
(set! call/cc-dw
(lambda (f)
(call/cc
(lambda (k)
(let ((state %state-space))
(let ((cob
(lambda (v)
(execute-at-new-state state)
(k v))))
(f cob)))))))
(set! dynamic-wind
(lambda (before body after)
(let ((state %state-space))
(extend-state-space
(make-new-state #!TRUE before after nil))
(before)
(begin0
(body)
(execute-at-new-state state))))))
(define catch call/cc-dw)


116
edwin/edinit.scm Normal file
View File

@ -0,0 +1,116 @@
;;;
;;; Export EDWIN and EDWIN-RESET-WINDOWS to user-global-environment
;;;
(set! (access edwin user-global-environment) edwin)
(set! (access edwin-reset-windows user-global-environment)
(access edwin-reset-windows edwin-environment))
;;;
;;; Export function which can remove edwin and reclaim all space
;;;
(set! (access remove-edwin user-global-environment)
(lambda ()
;;;
;;; Remove autoload info from proplist)
;;;
(remove-autoload-info "EDWIN0.FSL")
(remove-autoload-info "edwin1.fsl")
(remove-autoload-info "edwin2.fsl")
(remove-autoload-info "edwin3.fsl")
(remove-autoload-info "edwin4.fsl")
(remove-autoload-info "edwin5.fsl")
(remove-autoload-info "edwin6.fsl")
(remove-autoload-info "edwin7.fsl")
(remove-autoload-info "edwin8.fsl")
(remove-autoload-info "edwin9.fsl")
(remove-autoload-info "edwin10.fsl")
;;;
;;; Remove macros so there are no ties to EDWIN-ENVIRONMENT
;;;
(remprop 'make-new-state 'PCS*MACRO)
(remprop '%in-out-flag 'PCS*MACRO)
(remprop '%before 'PCS*MACRO)
(remprop '%after 'PCS*MACRO)
(remprop '%next 'PCS*MACRO)
(remprop '%set-next 'PCS*MACRO)
(remprop 'define-initial-command-key 'PCS*MACRO)
(remprop 'string-allocate 'PCS*MACRO)
(remprop 'remap-edwin-key 'PCS*MACRO)
;;;
;;; Unbind REMOVE-EDWIN and EDWIN-ENVIRONMENT
;;;
(unbind 'edwin-reset-windows user-global-environment)
(unbind 'edwin-environment user-global-environment)
(unbind 'remove-edwin user-global-environment)
;;;
;;; Set EXIT and EDWIN definitions back to original
;;;
(set! (access exit user-global-environment)
(access system-exit user-global-environment))
(set! (access edwin user-global-environment)
(access initiate-edwin user-global-environment))
))
(set! (access system-exit user-global-environment)
(access exit user-global-environment))
(define %edwin-buffer%
(lambda ()
(vector-ref (vector-ref edwin-editor 1) 7)))
(define edwin-buffer-modified?
(lambda (buf)
(vector-ref buf 5)))
(define exit
(lambda ()
(cond ((or (unbound? edwin-editor)
(unassigned? edwin-editor))
(system-exit))
(else
(%save-buffer-changes (%edwin-buffer%))
(if (edwin-buffer-modified? (%edwin-buffer%))
(if (prompt-for-confirmation? "Exit anyway (Y or N)?")
(system-exit))
(system-exit))
(gc)))))
(set! (access exit user-global-environment) exit)
(macro remap-edwin-key
(lambda (e)
`(set-edwin-key ,(cadr e) (comtab-entry ,(caddr e)))))
(define set-edwin-key
(letrec
((%prefix
(lambda (alists char)
(%set-comtab-entry! alists char %command)))
(%command '()))
(lambda (char command)
(cond ((char? char)
(%set-comtab-key comtab (char-upcase char) command)
(if (char-alphabetic? char)
(%set-comtab-key comtab (char-downcase char) command)))
((and (pair? char) (null? (cdr char)))
(%set-comtab-key comtab (char-upcase (car char)) command)
(if (char-alphabetic? (car char))
(%set-comtab-key comtab (char-downcase (car char)) command)))
((pair? char)
(set! %command command)
(comtab-lookup-prefix char %prefix))
((char-set? char)
(mapc (lambda (char) (set-comtab-entry! char command))
(char-set-members char)))
(else (error "Unknown character" char)))
char)))
(let* ((last-char (string-ref pcs-sysdir (-1+ (string-length pcs-sysdir))))
(edwin-init (%system-file-name "EDWIN.INI")))
(if (file-exists? edwin-init)
(load edwin-init)))


183
edwin/emacros.scm Normal file
View File

@ -0,0 +1,183 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(begin
(define-integrable substring-find-next-char
substring-find-next-char-in-set)
(define-integrable substring-find-previous-char
substring-find-previous-char-in-set)
)
;;;; Replace Group
(define (string-replace string char1 char2)
(let ((string (string-copy string)))
(string-replace! string char1 char2)
string))
(define (substring-replace string start end char1 char2)
(let ((string (string-copy string)))
(substring-replace! string start end char1 char2)
string))
(define (string-replace! string char1 char2)
(substring-replace! string 0 (string-length string) char1 char2))
(define (substring-replace! string start end char1 char2)
(define (loop start)
(let ((index (substring-find-next-char string start end char1)))
(if index
(sequence (string-set! string index char2)
(loop (1+ index))))))
(loop start))
(define string-uppercase '())
(let ()
(define (string-set-case char-set-case)
(lambda (string1)
(let ((end (string-length string1)))
(define (loop string2 string1 index char-set-case end)
(if (= index end)
string2
(begin (string-set! string2
index
(char-set-case (string-ref string1 index)))
(loop string2 string1 (1+ index) char-set-case end))))
(loop (make-string end '()) string1 0 char-set-case end))))
(set! string-uppercase (string-set-case char-upcase)))
(define map2
(lambda (fn arg1 arg2)
(cond ((or (null? arg1) (null? arg2)) '())
(t (cons (fn (car arg1) (car arg2))
(map2 fn (cdr arg1) (cdr arg2)))))))
(macro define-named-structure
(lambda (e)
(let ((name (cadr e)) (slots (cddr e)))
(define ((make-symbols x) y) (make-symbol x y))
(define (make-symbol . args)
(string->symbol (apply string-append args)))
(let ((structure-string (string-uppercase name))
(slot-strings (mapcar symbol->string slots)))
(let ((prefix (string-append structure-string "-")))
(let ((structure-name (string->symbol structure-string))
(tag-name (make-symbol "%" prefix "TAG"))
(constructor-name
(make-symbol "%MAKE-" structure-string))
(predicate-name (make-symbol structure-string "?"))
(slot-names
(mapcar (make-symbols
(string-append prefix "INDEX:"))
slot-strings))
(selector-names
(mapcar (make-symbols prefix) slot-strings)))
(define (slot-loop tail slot-names n)
(if (null? slot-names)
tail
(slot-loop (cons (list 'DEFINE-INTEGRABLE
(car
slot-names)
n)
tail)
(cdr slot-names)
(|1+| n))))
(define (selector-loop tail selector-names n)
(if (null? selector-names)
tail
(selector-loop
(cons `(define-integrable
,(car selector-names)
(lambda (,structure-name)
(vector-ref ,structure-name
,n)))
tail)
(cdr selector-names)
(|1+| n))))
`(begin
(define ,tag-name ,name)
(define (,constructor-name)
(let ((,structure-name
(make-vector ,(1+ (length slots)) '())))
(vector-set! ,structure-name 0 ,tag-name)
,structure-name))
;;; (define (,predicate-name object)
;;; (and (vector? object)
;;; (not (zero? (vector-size object)))
;;; (eq? ,tag-name (vector-ref object 0))))
,@(slot-loop '() slot-names 1)
,@(selector-loop '() selector-names 1))))))))
(macro define-command
(lambda (e)
(let ((bvl (cadr e)) (description (caddr e)) (body (cdddr e)))
(let ((name (car bvl))
(arg-names
(mapcar (lambda (arg)
(if (pair? arg) (car arg) arg))
(cdr bvl)))
(arg-inits
(mapcar (lambda (arg)
(if (pair? arg) (cadr arg) #!FALSE))
(cdr bvl))))
(let ((procedure-name
(string->symbol
(string-append (canonicalize-name-string name)
"-COMMAND"))))
`(begin
(define (,procedure-name ,@arg-names)
,@(map2 (lambda (arg-name arg-init)
`(if (not ,arg-name)
(set! ,arg-name ,arg-init)))
arg-names arg-inits)
,@body)
(make-command ,name ,description ,procedure-name)))))))
(define canonicalize-name-string
(lambda (name)
(let ((name (string-uppercase name)))
(string-replace! name #\Space #\-)
name)))


322
edwin/incser.scm Normal file
View File

@ -0,0 +1,322 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Incremental Search
;;;; Search State Abstraction
(define search-state-tag "Search State")
(define (make-search-state text parent forward? successful?
start-point end-point point initial-point)
(let ((state (make-vector 9)))
(vector-set! state 0 search-state-tag)
(vector-set! state 1 text)
(vector-set! state 2 parent)
(vector-set! state 3 forward?)
(vector-set! state 4 successful?)
(vector-set! state 5 start-point)
(vector-set! state 6 end-point)
(vector-set! state 7 point)
(vector-set! state 8 initial-point)))
(begin
(define-integrable search-state-index:text 1)
(define-integrable search-state-index:parent 2)
(define-integrable search-state-index:forward? 3)
(define-integrable search-state-index:successful? 4)
(define-integrable search-state-index:start-point 5)
(define-integrable search-state-index:end-point 6)
(define-integrable search-state-index:point 7)
(define-integrable search-state-index:initial-point 8)
(define-integrable search-state-text
(lambda (search-state)
(vector-ref search-state search-state-index:text)))
(define-integrable search-state-parent
(lambda (search-state)
(vector-ref search-state search-state-index:parent)))
(define-integrable search-state-forward?
(lambda (search-state)
(vector-ref search-state search-state-index:forward?)))
(define-integrable search-state-start-point
(lambda (search-state)
(vector-ref search-state search-state-index:start-point)))
(define-integrable search-state-end-point
(lambda (search-state)
(vector-ref search-state search-state-index:end-point)))
(define-integrable search-state-point
(lambda (search-state)
(vector-ref search-state search-state-index:point)))
(define-integrable search-state-initial-point
(lambda (search-state)
(vector-ref search-state search-state-index:initial-point)))
(define-integrable search-state-successful?
(lambda (search-state)
(vector-ref search-state search-state-index:successful?)))
)
;;;; Top Level
(define (incremental-search forward?)
(let ((old-point (current-point))
(old-window (current-window)))
(let ((y-point (window-point-y old-window)))
(let ((result
(catch
(lambda (continuation)
(fluid-let ((incremental-search-exit continuation)
(incremental-search-window old-window)
(current-search-state #!FALSE))
(set-current-search-state!
(initial-search-state forward? old-point))
(incremental-search-loop))))))
(cond ((eq? result 'ABORT)
(set-current-point! old-point)
(window-scroll-y-absolute! (current-window) y-point))
((char? result)
(erase-echo-prompt!)
(dispatch-on-char result)))))))
(define (incremental-search-loop)
(let ((result
(catch
(lambda (continuation)
(fluid-let ((*error-continuation* continuation))
(incremental-search-command-reader))))))
(if (eq? result 'abort) ;; Handle ^G and go on
(begin (incremental-search:pop!)
(incremental-search-loop))
result)))
(define ctrl-q (integer->char 17))
(define ctrl-r (integer->char 18))
(define ctrl-s (integer->char 19))
(define (incremental-search-command-reader)
(let ((char (editor-read-char (window-screen (current-window)))))
(cond ((standard-char? char) (i-search-append-char char))
((char=? char #\Tab) (i-search-append-char char))
((char=? char ctrl-q) (i-search-append-char
(read-char (window-screen (current-window)))))
((char=? char ctrl-s)
(set-current-search-state!
(incremental-search:next-occurrence (fluid current-search-state)))
(i-search-detect-failure (fluid current-search-state)))
((char=? char ctrl-r)
(set-current-search-state!
(incremental-search:previous-occurrence
(fluid current-search-state)))
(i-search-detect-failure (fluid current-search-state)))
((char=? char #\backspace)
(set-current-search-state!
(incremental-search:delete-char (fluid current-search-state))))
(t (incremental-search:terminate! (fluid current-search-state)
char))))
(incremental-search-command-reader))
(define (standard-char? char)
(let ((i (char->integer char)))
(and (>= i 32) (<= i 126))))
;;;; Commands
(define (incremental-search:append-char state char)
(let ((text (string-append (search-state-text state)
(list->string (list char)))))
(cond ((not (search-state-successful? state))
(unsuccessful-search-state state text
(search-state-forward? state)))
((search-state-forward? state)
(find-next-search-state state
text
(search-state-start-point state)))
(else
(find-previous-search-state
state text
(let ((end (search-state-end-point state)))
(if (or (group-end? end)
(mark= end (search-state-initial-point state)))
end
(mark1+ end #!false))))))))
(define (incremental-search:delete-char state)
(let ((parent (search-state-parent state)))
(if (null? parent) (editor-error))
parent))
(define (incremental-search:next-occurrence state)
(cond ((null? (search-state-parent state))
(let ((point (search-state-initial-point state)))
(if (not (search-state-forward? state))
(initial-search-state #!FALSE point)
(find-next-search-state state
previous-successful-search-string
point))))
((search-state-successful? state)
(find-next-search-state state
(search-state-text state)
((if (search-state-forward? state)
search-state-end-point
search-state-start-point)
state)))
((not (search-state-forward? state))
(find-next-search-state state
(search-state-text state)
(search-state-point state)))
(else
(unsuccessful-search-state state (search-state-text state) #!TRUE))))
(define (incremental-search:previous-occurrence state)
(cond ((null? (search-state-parent state))
(let ((point (search-state-initial-point state)))
(if (search-state-forward? state)
(initial-search-state #!FALSE point)
(find-previous-search-state state
previous-successful-search-string
point))))
((search-state-successful? state)
(find-previous-search-state state
(search-state-text state)
((if (search-state-forward? state)
search-state-end-point
search-state-start-point)
state)))
((search-state-forward? state)
(find-previous-search-state state
(search-state-text state)
(search-state-point state)))
(else
(unsuccessful-search-state state (search-state-text state) #!FALSE))))
(define (incremental-search:terminate! state char)
(let ((state (most-recent-successful-search-state state)))
(if (not (null? (search-state-parent state)))
(set! previous-successful-search-string (search-state-text state))))
((fluid incremental-search-exit) char))
(define (incremental-search:pop!)
(let ((success (most-recent-successful-search-state
(fluid current-search-state))))
(if (eq? success (fluid current-search-state))
((fluid incremental-search-exit) 'ABORT)
(set-current-search-state! success))))
;;;; Primitives
(define (initial-search-state forward? point)
(make-search-state "" '() forward? #!TRUE point point point point))
(define (unsuccessful-search-state parent text forward?)
(let ((start-point (search-state-start-point parent)))
(make-search-state text parent forward? #!FALSE
start-point
(mark+ start-point (string-length text) #!false)
(search-state-point parent)
(search-state-initial-point parent))))
(define (find-next-search-state state text start)
(let ((start-point (find-next-string start (group-end start) text)))
(if (not start-point)
(unsuccessful-search-state state text #!TRUE)
(let ((end-point (mark+ start-point (string-length text) #!false)))
(make-search-state text state #!TRUE #!TRUE
start-point end-point end-point
(if (search-state-forward? state)
(search-state-initial-point state)
(search-state-start-point state)))))))
(define (find-previous-search-state state text start)
(let ((end-point (find-previous-string start (group-start start) text)))
(if (not end-point)
(unsuccessful-search-state state text #!FALSE)
(let ((start-point (mark- end-point (string-length text) #!false)))
(make-search-state text state #!FALSE #!TRUE
start-point end-point start-point
(if (search-state-forward? state)
(search-state-end-point state)
(search-state-initial-point state)))))))
(define (set-current-search-state! state)
(update-i-search-prompt state)
(set-window-point! (fluid incremental-search-window)
(search-state-point state))
(set-fluid! current-search-state state))
(define (update-i-search-prompt state)
(set-echo-prompt!
(string-append
(if (search-state-successful? state) "" "Failing ")
(if (search-state-forward? state) "" "Reverse ")
"I-Search: "
(search-state-text state))))
(define (most-recent-successful-search-state state)
(cond ((search-state-successful? state)
state)
((null? (search-state-parent state))
(error "Search state chain terminated improperly"))
(else
(most-recent-successful-search-state (search-state-parent state)))))
(define (i-search-append-char char)
(set-current-search-state!
(incremental-search:append-char (fluid current-search-state) char))
(i-search-detect-failure (fluid current-search-state)))
(define (i-search-detect-failure search-state)
(if (and (not (search-state-successful? search-state))
(or (search-state-successful? (search-state-parent
search-state))
(not (eq? (search-state-forward? search-state)
(search-state-forward?
(search-state-parent search-state))))))
(beep)))


98
edwin/initkey.scm Normal file
View File

@ -0,0 +1,98 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define define-initial-key
(letrec
((%prefix
(lambda (alists char)
(let ((upcase (char-upcase char)))
(%set-comtab-entry! alists upcase %command)
(if (char-alphabetic? char)
(%set-comtab-entry! alists (char-downcase char) %command)))))
(%command '()))
(lambda (char command)
(cond ((char? char)
(%set-comtab-key comtab (char-upcase char) command)
(if (char-alphabetic? char)
(%set-comtab-key comtab (char-downcase char) command)))
((and (pair? char) (null? (cdr char)))
(%set-comtab-key comtab (char-upcase (car char)) command)
(if (char-alphabetic? (car char))
(%set-comtab-key comtab (char-downcase (car char)) command)))
((pair? char)
(set! %command command)
(comtab-lookup-prefix char %prefix))
((char-set? char)
(mapc (lambda (char) (set-comtab-entry! char command))
(char-set-members char)))
(else (error "Unknown character" char)))
char)))
(define define-initial-prefix-key
(letrec
((%prefix
(lambda (alists char)
(let ((upcase (char-upcase char)))
(if (pair? %char)
(%set-comtab-entry! alists upcase %command)
(%set-comtab-key alists upcase %command))
(%comtab-make-prefix-char! alists upcase (cons '() '()))
(if (char-alphabetic? char)
(%comtab-make-synonym-char! alists (char-downcase char)
alists upcase)))))
(%char '())
(%command '()))
(lambda (char command)
(cond ((or (char? char) (pair? char))
(set! %command command)
(set! %char char)
(comtab-lookup-prefix char %prefix))
(else (error "Unknown character" char)))
char)))
(define (define-initial-default-key command)
(set! default-key command)
(set-cdr! comtab (make-vector 256 command)))
;;; change to 256 for internationalize


65
edwin/initmac.scm Normal file
View File

@ -0,0 +1,65 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(macro define-initial-command-key
(lambda (e)
(let ((bvl (cadr e))
(description (caddr e))
(key-commands (cadddr e))
(body (cddddr e)))
(let ((name (car bvl))
(arg-names (mapcar (lambda (arg) (if (pair? arg) (car arg) arg))
(cdr bvl)))
(arg-inits (mapcar (lambda (arg)
(if (pair? arg) (cadr arg) #!FALSE))
(cdr bvl))))
(let ((procedure-name
(string->symbol (string-append (canonicalize-name-string name)
"-COMMAND"))))
`(begin
(let ()
(define (procedure ,@arg-names)
,@(map2 (lambda (arg-name arg-init)
`(if (not ,arg-name)
(set! ,arg-name ,arg-init)))
arg-names arg-inits)
,@body)
,@key-commands)))))))

145
edwin/insert80.scm Normal file
View File

@ -0,0 +1,145 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; These routines are implemented to get speed in character
;;;; insertion and deletions. They are written so as not to effect
;;;; the code too much.
;;;; Changes arise in the command for delete character and delete backward
;;;; character in allcoms.scm. Also, redisplay contains an statement for the
;;;; creation of the daemons.
;;;; These should be faster and should create less garbage.
(define region-insert-char!
(lambda (mark char)
(if (eq? char #\newline)
(region-insert-newline! mark)
(begin
(if (group-read-only? (mark-group mark))
(editor-error "Trying to modify read only text"))
((lambda (line pos)
(%region-insert-char! line pos char))
(mark-line mark) (mark-position mark))
(%recompute-for-insert-del-char! mark)))))
(define %region-insert-char!
(letrec
((%receiver
(lambda (mark cursor?)
(if (or (> (mark-position mark) %pos)
(and (= (mark-position mark) %pos)
(mark-left-inserting? mark)))
(set-mark-position! mark (1+ (mark-position mark))))))
(%pos '()))
(lambda (line pos char)
(set! %pos pos)
(for-each-mark! line %receiver)
(line-insert-char! line pos char))))
(define %recompute-for-insert-del-char! '())
(define %create-char-daemon
(lambda (window)
(set! %recompute-for-insert-del-char!
(%char-daemon window))))
(define (%char-daemon window)
(lambda (mark)
(let ((buffer (vector-ref window window:buffer))
(table (vector-ref window window:lines))
(line (mark-line mark))
(y (line->y window (mark-line mark)))
(y-size (vector-ref window window:y-size)))
(let ((inferior (vector-ref table y)))
(let ((old-ys (inferior:y-size inferior))
(new-ys (find-y-size line)))
(buffer-modified! buffer)
(if (= old-ys new-ys)
(begin
(maybe-marks-changed window y)
(set-start-end! window y y)
(cursor-moved! window))
(begin
(if (< old-ys new-ys)
(scroll-lines-down! window (- new-ys old-ys) y-size
table (+ (inferior:y-start inferior) old-ys))
(scroll-lines-up! window (- old-ys new-ys) y-size
table (+ (inferior:y-start inferior) old-ys)))
(set-inferior:y-size! inferior new-ys)
(fill-entries (1+ y)
(+ (inferior:y-start inferior) new-ys)
y table y-size)
(set-start-end! window y (-1+ y-size))
(everything-changed! window window-redraw!))))))))
(define %region-delete-char!
(letrec
((%receiver
(lambda (mark cursor?)
(cond ((> (mark-position mark) end-pos)
(set-mark-position! mark (- (mark-position mark)
offset)))
((> (mark-position mark) %pos)
(set-mark-position! mark %pos)))))
(%pos '())
(end-pos '())
(offset 1))
(lambda (mark)
(letrec
((%%region-delete-char!
(lambda (line pos)
(set! %pos pos)
(set! end-pos (1+ pos))
(for-each-mark! line %receiver)
(subline-extract! line pos (1+ pos)))))
(if (group-read-only? (mark-group mark))
(editor-error "Trying to modify read only text"))
(%%region-delete-char! (mark-line mark) (mark-position mark))
(%recompute-for-insert-del-char! mark)))))

205
edwin/io.scm Normal file
View File

@ -0,0 +1,205 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; File IO
(define read-buffer
(lambda (buffer filename)
(region-delete! (buffer-region buffer))
(if (file-exists? filename)
(begin
(let ((region (file->region-interactive filename)))
(vector-set! (current-window) window:point
(mark-right-inserting (buffer-start buffer)))
(region-insert! (buffer-start buffer) region))
(set-current-point! (buffer-start buffer)))
(temporary-message "(New File)"))
(set-buffer-truename! buffer filename)
(set-buffer-pathname! buffer filename)
(buffer-not-modified! buffer)))
(define insert-file
(lambda (mark filename)
(if (file-exists? filename)
(region-insert! mark (file->region-interactive filename))
(editor-error (string-append "File " filename " not found")))))
(define file->region-interactive
(lambda (filename)
(temporary-message (string-append "Reading file " filename))
(let ((region (file->region filename)))
(append-message " -- done")
region)))
(define file->region
(lambda (filename)
(let ((port '()))
(dynamic-wind
(lambda () (set! port (open-input-file filename)))
(lambda () (file-stream->region port))
(lambda () (close-input-port port))))))
(define (file-stream->region stream)
(let ((first-line (read-line stream)))
(if (not (eof-object? first-line))
(let ((first-line (make-line first-line))
(group (make-group #!FALSE)))
(define (%connect-lines previous-line this-line n)
(connect-lines! previous-line this-line)
(set-line-group! this-line group)
(set-line-number! this-line n))
(define (loop previous-line n this-line)
(if (not (eof-object? this-line))
(let ((this-line (make-line this-line)))
(%connect-lines previous-line this-line n)
(loop this-line (+ n line-number-increment)
(read-line stream)))
(let ((this-line (make-line "")))
(%connect-lines previous-line this-line n)
(let ((region
(components->region first-line 0 this-line
(line-length this-line))))
(%set-group-region! group region)
region))))
(set-line-group! first-line group)
(set-line-number! first-line 0)
(loop first-line line-number-increment (read-line stream)))
(let ((line (make-line "")))
(lines->region line line)))))
;;;; Output
(define write-buffer
(lambda (buffer filename)
(if (or (not (file-exists? filename))
(prompt-for-confirmation?
(string-append "File " filename
" exists. Write anyway (Y or N)?")))
(begin
(temporary-message (string-append "Writing file " filename))
(region->file (buffer-region buffer) filename)
(append-message " -- done")
(set-buffer-pathname! buffer filename)
(set-buffer-truename! buffer filename)
(buffer-not-modified! buffer)))))
(define write-region
(lambda (region filename)
(if (or (not (file-exists? filename))
(prompt-for-confirmation?
(string-append "File " filename
" exists. Write anyway (Y or N)?")))
(begin
(temporary-message (string-append "Writing file " filename))
(region->file region filename)
(append-message " -- done")))))
(define (region->file region filename)
(let ((port '()))
(dynamic-wind
(lambda () (set! port (open-output-file filename)))
(lambda () (region->filestream region port))
(lambda () (close-output-port port)))))
(define (region->filestream region stream)
(region-components region
(lambda (start-line start-position end-line end-position)
(if (eq? start-line end-line)
(princ (substring (line-string start-line)
start-position
end-position)
stream)
(begin
(princ (substring (line-string start-line)
start-position
(line-length start-line))
stream)
(let loop ((this-line (line-next start-line)))
(princ #\newline stream)
(if (eq? this-line end-line)
(princ (substring (line-string end-line)
0
end-position)
stream)
(begin (princ (line-string this-line) stream)
(loop (line-next this-line))))))))))
(define (save-buffer-changes buffer)
(if (and (buffer-pathname buffer)
(buffer-modified? buffer)
(buffer-writeable? buffer)
(prompt-for-confirmation?
(string-append "Buffer "
(buffer-name buffer)
" contains changes. Write them out (Y or N)?")))
(write-buffer buffer (buffer-pathname buffer))))
(define (%save-buffer-changes buffer)
(if (and (buffer-modified? buffer)
(buffer-writeable? buffer)
(prompt-for-confirmation?
(string-append "Buffer "
(buffer-name buffer)
" contains changes. Write them out (Y or N)?")))
(save-file buffer)))
(define (setup-current-buffer-read-only! argument)
((cond ((or (not argument) (zero? argument)) set-buffer-writeable!)
((negative? argument) set-buffer-read-only!)
(else set-buffer-file-read-only!))
(current-buffer)))
(define (save-file buffer)
(if (buffer-modified? buffer)
(if (or (buffer-writeable? buffer)
(prompt-for-confirmation?
(string-append "Buffer " (buffer-name buffer)
" is read only. Save anyway (Y or N)?")))
(write-buffer buffer
(let ((pathname (buffer-pathname buffer)))
(if (not pathname)
(prompt-for-pathname
"Write buffer to file : ")
pathname))))
(temporary-message "(No changes need to be written)")))


71
edwin/kill1.scm Normal file
View File

@ -0,0 +1,71 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Kill Commands
(define append-next-kill-tag "Append Next Kill")
(define (delete-region mark)
(if (not mark) (editor-error "Delete exceeds buffer bounds"))
(region-delete! (make-region (current-point) mark)))
(define (kill-region mark)
(if (not mark) (editor-error "Kill exceeds buffer bounds"))
(let* ((point (current-point))
(forward? (mark<= point mark)))
(%kill-region (region-extract! (make-region point mark)) forward?)))
(define (%kill-region region forward?)
(let ((ring (current-kill-ring)))
(command-message-receive append-next-kill-tag
(lambda ()
(if (ring-empty? ring) (editor-error "No previous kill"))
(region-insert! ((if forward? region-end region-start)
(ring-ref ring 0))
region))
(lambda ()
(ring-push! ring region))))
(set-command-message! append-next-kill-tag))
(define (un-kill-region region)
(set-current-region! (region-insert (current-point) region)))


64
edwin/kill2.scm Normal file
View File

@ -0,0 +1,64 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (copy-region mark)
(if (not mark) (editor-error "Copy exceeds buffer bounds"))
(let ((point (current-point)))
(%kill-region (region-copy (make-region point mark))
(mark<= point mark))))
(define (un-kill-region-reversed region)
(set-current-region-reversed! (region-insert (current-point) region)))
(define (%edwin-un-kill-pop argument)
(command-message-receive un-kill-tag
(lambda ()
(region-delete! (make-region (current-point) (pop-current-mark!)))
(let ((ring (current-kill-ring)))
;; **** Missing test for equality here.
(if (not (zero? argument))
(begin (ring-pop! ring)
(un-kill-region-reversed (ring-ref ring 0))))))
(lambda ()
(editor-error "No previous un-kill to replace")))
(set-command-message! un-kill-tag))


58
edwin/ldall.scm Normal file
View File

@ -0,0 +1,58 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(set! (access edwin-environment user-global-environment)
(make-hashed-environment))
(let ((old-env (%set-global-environment (access edwin-environment
user-global-environment))))
(load (%system-file-name "edwin0.fsl"))
(load (%system-file-name "edwin1.fsl"))
(load (%system-file-name "edwin2.fsl"))
(load (%system-file-name "edwin3.fsl"))
(load (%system-file-name "edwin4.fsl"))
(load (%system-file-name "edwin5.fsl"))
(load (%system-file-name "edwin6.fsl"))
(load (%system-file-name "edwin7.fsl"))
(load (%system-file-name "edwin8.fsl"))
(load (%system-file-name "edwin9.fsl"))
(load (%system-file-name "edwin10.fsl"))
(%set-global-environment old-env))


43
edwin/ldchset.scm Normal file
View File

@ -0,0 +1,43 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(load (%system-file-name "edwin11.fsl"))


258
edwin/lisp.scm Normal file
View File

@ -0,0 +1,258 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; moving forward
(define (forward-one-list start end)
(forward-sexp:top start end 0))
(define (forward-down-one-list start end)
(forward-sexp:top start end -1))
(define (forward-up-one-list start end)
(forward-sexp:top start end 1))
(define forward-sexp:top
(lambda (start end depth)
(letrec
((forward-sexp:top
(lambda (start end depth)
(and (mark< start end)
(search-forward start end depth))))
(search-forward
(lambda (start end depth)
(let ((mark (find-next-char-in-set start end sexp-delims)))
(and mark
(cond
((char=? (mark-right-char mark) ;;; (
#\) )
(list-forward-close (mark1+ mark #!false) end depth))
(else (list-forward-open (mark1+ mark #!false)
end depth)))))))
(list-forward-open
(lambda (start end depth)
(if (= depth -1)
start
(forward-sexp:top start end (1+ depth)))))
(list-forward-close
(lambda (start end depth)
(and (> depth 0)
(if (= depth 1)
start
(forward-sexp:top start end (-1+ depth)))))))
(forward-sexp:top start end depth))))
;;; sexp movement
(define (forward-one-sexp start end )
(let ((m (find-next-char-in-set start end char-set:not-whitespace)))
(if m
(let ((char (mark-right-char m)))
(cond ((char=? char #\( ) ;;; )
(forward-one-list m end))
((char-set-sexp? char)
(find-next-char-in-set m end sexp-delimeter-chars))
((char=? char #\") ;;;"
(find-next-closing-quote (mark1+ m #!false) end)) ;;;)
((char=? char #\)) (mark1+ m #!false)) ;;; (
((or (char=? char #\') (char=? char #\`))
(forward-one-sexp (mark1+ m #!false) end))
(else (find-next-char-in-set m end char-set:whitespace))))
#!false)))
(define (backward-one-sexp start end )
(let ((m (find-previous-char-in-set start end char-set:not-whitespace)))
(if m
(let ((char (mark-left-char m)))
(cond ((char=? char #\) ) ;;; (
(backward-one-list m end))
((char-set-sexp? char)
(find-previous-char-in-set m end sexp-delimeter-chars))
((char=? char #\") ;;;"
(find-previous-closing-quote (mark-1+ m #!false) end)) ;;;)
((char=? char #\() ;;;)
(mark-1+ m #!false))
((or (char=? char #\') (char=? char #\`))
(backward-one-sexp (mark-1+ m #!false) end))
(else (find-previous-char-in-set m end
char-set:whitespace))))
#!false)))
(define find-next-closing-quote
(lambda (start end)
(let ((m (find-next-char-in-set start end string-quote)))
(and m
(mark1+ m #!false)))))
(define find-previous-closing-quote
(lambda (start end)
(let ((m (find-previous-char-in-set start end string-quote)))
(and m
(mark-1+ m #!false)))))
(define string-quote (make-string 1 #\"))
;;; moving backward
(define (backward-down-one-list start end)
(backward-sexp:top start end -1))
(define (backward-up-one-list start end)
(backward-sexp:top start end 1))
(define forward-list)
(define backward-list)
(make-motion-pair forward-one-list backward-one-list
(lambda (f b)
(set! forward-list f)
(set! backward-list b)))
(define forward-down-list)
(define backward-down-list)
(make-motion-pair forward-down-one-list backward-down-one-list
(lambda (f b)
(set! forward-down-list f)
(set! backward-down-list b)))
(define forward-up-list)
(define backward-up-list)
(make-motion-pair forward-up-one-list backward-up-one-list
(lambda (f b)
(set! forward-up-list f)
(set! backward-up-list b)))
;;;
(define forward-sexp '())
(define backward-sexp '())
(make-motion-pair forward-one-sexp backward-one-sexp
(lambda (f b)
(set! forward-sexp f)
(set! backward-sexp b)))
;;; Lisp Indenting
(define scheme:delim (char-set-union char-set:whitespace sexp-delims))
(define lisp-indent-line
(lambda (point)
(letrec
((calculate-lisp-indent
(lambda (mark)
(let ((containing-sexp
(backward-up-one-list mark (group-start mark))))
(if containing-sexp
(let ((next-sexp-start
(find-next-char-in-set
(mark1+ containing-sexp #!false) mark
char-set:not-whitespace)))
(if next-sexp-start
(if (char-ci=? #\( (mark-right-char next-sexp-start));)
(mark-column next-sexp-start)
(let ((next-sexp-end
(find-next-char-in-set next-sexp-start mark
scheme:delim)))
(table-lookup containing-sexp next-sexp-start
next-sexp-end mark)))
(1+ (mark-column containing-sexp))))
0))))
(table-lookup
(lambda (containing-sexp sexp-start sexp-end limit-mark)
(let ((string (substring (line-string (mark-line sexp-start))
(mark-position sexp-start)
(mark-position sexp-end))))
(cond ((is-string-member? string %standard-funcs)
(+ lisp-indent (mark-column containing-sexp)))
(else (let ((m (find-next-char-in-set sexp-end limit-mark
char-set:not-whitespace)))
(if (and m
(not (char=? (mark-right-char m) #\;)))
(mark-column m)
(+ lisp-indent
(mark-column containing-sexp)))))))))
(is-string-member?
(lambda (string list1)
(if list1
(if (string-ci=? string (car list1))
#!true
(is-string-member? string (cdr list1)))
#!false))))
(let* ((start-mark (line-start point 0 #!false))
(start (horizontal-space-end (line-start point 0 #!false))))
(let ((indentation (calculate-lisp-indent start)))
(if (<> indentation (mark-column start))
(begin
(region-delete! (make-region start-mark start))
(insert-chars #\space indentation start-mark))))))))
(define %standard-funcs
'("define" "lambda" "let" "letrec" "let*" "fluid-let" "macro" "rec" "named-lambda" "call/cc" "case" "with-input-from-file" "call-with-input-file"))
(define lisp-indent-sexp
(lambda (point)
(letrec
((end (line-start (forward-sexp point 1 'ERROR) 0 #!false))
(loop
(lambda (start)
(lisp-indent-line start)
(if (not (mark= start end))
(loop (line-start start 1 #!false))))))
(if (mark< point end)
(loop (line-start point 1 #!false))))))

157
edwin/main.scm Normal file
View File

@ -0,0 +1,157 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; miscellaneous routine for windows
(define save-console-contents
(lambda ()
(set! *pcs-contents* (%save-window 'console))))
(define restore-console-contents
(lambda ()
(let ((cursor-x (%reify-port 'console 1))
(cursor-y (%reify-port 'console 0)))
(%clear-window 'console)
(%reify-port! 'console 1 cursor-x)
(%reify-port! 'console 0 cursor-y)
(%restore-window 'console *pcs-contents*))))
(define make-pcs-status-invisible
(lambda ()
(%reify-port! pcs-status-window 11
(%logand (%reify-port pcs-status-window 11) -9))))
(define make-pcs-status-visible
(lambda ()
(%reify-port! pcs-status-window 11
(%logior (%reify-port pcs-status-window 11) 8))))
(define move-editor-to-upper-half
(lambda ()
(%reify-port! buffer-screen 4 11)
(%reify-port! modeline-screen 2 11)
(%reify-port! typein-screen 2 12)))
(define move-editor-to-full
(lambda ()
(%reify-port! buffer-screen 4 23)
(%reify-port! modeline-screen 2 23)
(%reify-port! typein-screen 2 24)))
(define move-pcs-window-lower
(lambda ()
(%reify-port! 'console 2 13)
(%reify-port! 'console 4 11)))
(define move-pcs-to-full
(lambda ()
(%reify-port! 'console 2 0)
(%reify-port! 'console 4 24)))
(begin
(define-integrable editor:name 0)
(define-integrable editor:buffer-window 1)
(define-integrable editor:bufferset 2)
(define-integrable editor:kill-ring 3)
(define-integrable editor-bufferset
(lambda (editor)
(vector-ref editor editor:bufferset)))
(define-integrable editor-kill-ring
(lambda (editor)
(vector-ref editor editor:kill-ring)))
(define-integrable editor-buffer-window
(lambda (editor)
(vector-ref editor editor:buffer-window)))
(define-integrable editor-name
(lambda (editor)
(vector-ref editor editor:name)))
(define-integrable current-buffer-set
(lambda()
(editor-bufferset edwin-editor)))
(define-integrable current-kill-ring
(lambda ()
(editor-kill-ring edwin-editor)))
(define-integrable current-buffer-window
(lambda ()
(editor-buffer-window edwin-editor)))
)
;;; screens
(define make-screen
(lambda (xl yl lin col)
(let ((window (%make-window'())))
(%reify-port! window 2 yl)
(%reify-port! window 3 xl)
(%reify-port! window 4 lin)
(%reify-port! window 5 col)
(%reify-port! window 8
(%logand -2 (%reify-port window 8)))
window)))
(define buffer-screen (make-screen 0 0 23 80))
(define modeline-screen
(let ((screen (make-screen 0 23 1 80)))
(%reify-port! screen 7 (if (= pcs-machine-type 1) 28 120))))
(define typein-screen (make-screen 0 24 1 80))
(define blank-screen (make-screen 0 0 24 80))
;;; editor
(define initial-buffer-name "Main")
(define make-editor
(lambda (name)
(let ((vec (make-vector 4))
(init-buffer (make-buffer initial-buffer-name)))
(let ((bufferset (make-bufferset init-buffer)))
(vector-set! vec editor:name name)
(vector-set! vec editor:buffer-window
(make-buffer-window buffer-screen init-buffer))
(vector-set! vec editor:bufferset bufferset)
(vector-set! vec editor:kill-ring (make-ring 10))
vec))))

83
edwin/marks.scm Normal file
View File

@ -0,0 +1,83 @@
;;;; Permanent Marks
;;; The marks list is cleaned every time that a mark is added to the list,
;;; and every time that FOR-EACH-MARK! is called. This should keep the
;;; number of extraneous entries to a minimum. Note that FOR-EACH-MARK!
;;; and SET-MARK-LINE! are intended to be used together; in particular,
;;; a great deal of cleverness has been used to ensure that the changes
;;; made by SET-MARK-LINE! are noticed by FOR-EACH-MARK!. This turned out
;;; to be non-trivial to implement.
(define (mark-permanent! mark)
(let ((n (object-hash mark))
(marks (line-marks (mark-line mark))))
(if (not (memv n marks))
(let ((marks (cons n marks)))
(begin (clean-marks-tail! marks)
(set-line-marks! (mark-line mark) marks)))))
mark)
(define (clean-marks-tail! marks)
(if (not (null? (cdr marks)))
(if (object-unhash (cadr marks))
(clean-marks-tail! (cdr marks))
(begin (set-cdr! marks (cddr marks))
(clean-marks-tail! marks)))))
(define (for-each-mark! line procedure)
(define (loop-1 marks)
(if (not (null? marks))
(let ((mark (object-unhash (car marks))))
(if mark
(begin (procedure mark #!false)
(if (eq? marks (line-marks line))
(loop-2 marks (cdr marks))
(loop-1 (line-marks line))))
(begin (set-line-marks! line (cdr marks))
(loop-1 (line-marks line)))))))
(define (loop-2 previous marks)
(if (not (null? marks))
(let ((mark (object-unhash (car marks))))
(if mark
(begin (procedure mark #!false)
(if (eq? marks (cdr previous))
(loop-2 marks (cdr marks))
(loop-2 previous (cdr previous))))
(begin (set-cdr! previous (cddr previous))
(loop-2 previous (cdr previous)))))))
;;; point is treated as a special case and is no longer a permanent mark
;;; This would decrease the number of permanent marks considerably.
;;; Permannet marks are not so cheap and should be used only when
;;; really needed. Currently the point is obtained from current point
;;; but in a general setting there should be a way to get back to the
;;; buffer from group to get the point.
(let ((point (current-point)))
(if (and (eq? line (mark-line point))
(let ((n (object-hash point)))
(not (memv n (line-marks line)))))
(procedure point #!true)))
(loop-1 (line-marks line)))
(define (set-mark-line! mark new-line)
(let ((old-line (mark-line mark)))
(cond ((not (eq? old-line new-line))
(let ((marks
(let ((n (object-hash mark))
(marks (line-marks old-line)))
(define (loop previous marks)
(if (= n (car marks))
(begin (set-cdr! previous (cdr marks))
marks)
(loop marks (cdr marks))))
(if (= n (car marks))
(begin (set-line-marks! old-line (cdr marks))
marks)
(loop marks (cdr marks))))))
(%set-mark-line! mark new-line)
(set-cdr! marks (line-marks new-line))
(clean-marks-tail! marks)
(set-line-marks! new-line marks))))))

178
edwin/messages.scm Normal file
View File

@ -0,0 +1,178 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define reset-typein-window
(lambda ()
(%clear-window typein-screen)))
;;; command-prompts
(define *command-prompt-string* #!false)
(define *command-prompt-displayed?* #!false)
(define *temporary-message-displayed?* #!false)
(define *prompt-should-be-erased?* #!false)
(define *t-msg* "")
(define reset-command-prompt!
(lambda ()
(set! *command-prompt-string* #!false)
(set! *command-prompt-displayed?* #!false)))
(define set-command-prompt!
(lambda (prompt)
(set! *command-prompt-string* prompt)))
(define set-echo-prompt!
(lambda (string)
(set! *command-prompt-string* #!false)
(set! *command-prompt-displayed?* #!false)
(set! *temporary-message-displayed?* #!false)
(set! *prompt-should-be-erased?* #!false)
(write-prompt! string)))
(define erase-echo-prompt!
(lambda ()
(set! *command-prompt-string* #!false)
(set! *command-prompt-displayed?* #!false)
(set! *temporary-message-displayed?* #!false)
(set! *prompt-should-be-erased?* #!false)
(clear-prompt!)))
(define update-typein-window!
(lambda ()
(cond (*command-prompt-string*
(write-prompt! *command-prompt-string*)
(set! *command-prompt-string* #!false)
(set! *command-prompt-displayed?* #!true)
(set! *temporary-message-displayed?* #!false)
(set! *prompt-should-be-erased?* #!true))
(*prompt-should-be-erased?*
(set! *command-prompt-displayed?* #!false)
(set! *temporary-message-displayed?* #!false)
(set! *prompt-should-be-erased?* #!false)
(clear-prompt!))
(*temporary-message-displayed?*
(set! *prompt-should-be-erased?* #!true)
(set! *command-prompt-displayed?* #!false)
(set! *temporary-message-displayed?* #!false)))))
(define write-prompt!
(lambda (string)
(%clear-window typein-screen)
(write-string! typein-screen string 0 0)))
(define clear-prompt!
(lambda ()
(%clear-window typein-screen)))
(define temporary-message
(lambda (string)
(set! *t-msg* string)
(set-temp-message-status)
(write-prompt! string)))
(define set-temp-message-status
(lambda ()
(set! *command-prompt-string* #!false)
(set! *command-prompt-displayed?* #!false)
(set! *prompt-should-be-erased?* #!false)
(set! *temporary-message-displayed?* #!true)))
(define append-message
(lambda (string)
(set! *t-msg* (string-append *t-msg* string))
(temporary-message *t-msg*)))
;;; prompting
(define prompt-for-pathname
(lambda (prompt)
(temporary-message prompt)
(read-pathname-from-screen typein-screen)))
(define prompt-for-confirmation?
(lambda (prompt)
(define (loop)
(let ((char (char-upcase (editor-read-char typein-screen))))
(if (or (char=? #\Y char) (char=? #\N char))
(char=? #\Y char)
(loop))))
(temporary-message prompt)
(loop)))
(define read-pathname-from-screen
(let ((input-buffer (make-string 80 #\space)))
(lambda (screen)
(define erase-move-back
(lambda (screen)
(let ((cursor-x (%reify-port screen screen:cursor-x))
(cursor-y (%reify-port screen screen:cursor-y))
(set-cursor-pos
(lambda (x y)
(%reify-port! screen screen:cursor-x x)
(%reify-port! screen screen:cursor-y y))))
(set-cursor-pos (-1+ cursor-x) cursor-y)
(princ #\space screen)
(set-cursor-pos (-1+ cursor-x) cursor-y))))
(define (loop char ptr)
(cond ((char=? char #\return) (substring input-buffer 0 ptr))
((char=? char #\Backspace)
(if (not (= ptr 0))
(begin
(erase-move-back screen)
(loop (editor-read-char screen) (-1+ ptr)))
(loop (editor-read-char screen) ptr)))
((char-graphic? char)
(princ char screen)
(string-set! input-buffer ptr char)
(loop (editor-read-char screen) (1+ ptr)))
(else (loop (editor-read-char screen) ptr))))
(loop (editor-read-char screen) 0))))


148
edwin/modeln.scm Normal file
View File

@ -0,0 +1,148 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; modeline messages
;012345678901234567890123456789012345678901234567890123456789012345678901234567
;PCS Edwin VVVVVVVVVV Filename for the rest of the line
; cols 78 and 79 are reserved for the modified stars
(begin
(define-integrable name-position 4)
(define-integrable version-position 11)
(define-integrable version-length 6)
(define-integrable mode-position 19)
(define-integrable file-name-position 35)
(define-integrable file-name-length 31)
(define-integrable modified-position 0)
(define-integrable buffer-position 17)
)
(define reset-modeline-window #!false)
(define window-modeline-event! #!false)
(define update-modeline! #!false)
(letrec
((file-name #!false)
(file-name-changed #!false)
(version Edwin-Version)
(modified #!false)
(modified-changed #!false)
(mode-changed #!false)
(mode-scheme? #!true)
(position-cursor
(lambda (pos)
(%reify-port! modeline-screen screen:cursor-x pos)))
(string-upcase
(lambda (string)
(and string
(let loop ((string1 (make-string (string-length string) #\space))
(index 0) (end (string-length string)))
(if (< index end)
(begin
(string-set! string1 index
(char-upcase (string-ref string index)))
(loop string1 (1+ index) end))
string1)))))
(write-modified (lambda ()
(set! modified-changed #!false)
(position-cursor modified-position)
(princ (if modified "**" " ") modeline-screen)))
(write-mode (lambda ()
(set! mode-changed #!false)
(position-cursor mode-position)
(princ (if mode-scheme? " [Scheme] "
" [Fundamental] ")
modeline-screen)))
(write-file-name (lambda ()
(set! file-name-changed #!false)
(clear-subscreen! modeline-screen
file-name-position 0 0
file-name-length)
(position-cursor file-name-position)
(if file-name (princ file-name modeline-screen)))))
(set! reset-modeline-window
(lambda ()
(let ((buffer (current-buffer)))
(set! modified (buffer-modified? buffer))
(set! modified-changed #!true)
(set! file-name (string-upcase (buffer-pathname buffer)))
(set! file-name-changed #!true)
(set! mode-scheme? *current-mode-scheme?*)
(set! mode-changed #!true)
(%clear-window modeline-screen)
(%reify-port! modeline-screen screen:cursor-y 0)
(position-cursor name-position)
(princ "Edwin" modeline-screen)
(position-cursor version-position)
(princ version modeline-screen)
;;; (position-cursor buffer-position)
;;; (princ " Buffer : Main " modeline-screen)
(update-modeline!))))
(set! window-modeline-event!
(lambda (window event)
(let ((buffer (current-buffer)))
(cond ((eq? event 'buffer-modified)
(let ((buffer-modified (buffer-modified? buffer)))
(if (not (eq? buffer-modified modified))
(set! modified-changed #!true))
(set! modified buffer-modified)))
((eq? event 'buffer-pathname)
(set! file-name-changed #!true)
(set! file-name (string-upcase (buffer-pathname buffer))))
((eq? event 'mode-changed)
(set! mode-scheme? *current-mode-scheme?*)
(set! mode-changed #!true))
(else #!false)))))
(set! update-modeline!
(lambda ()
(if modified-changed (write-modified))
(if file-name-changed (write-file-name))
(if mode-changed (write-mode)))))


223
edwin/motion.scm Normal file
View File

@ -0,0 +1,223 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Motion within Groups
;;;; Mark Movement
(begin
(define-integrable group-start
(lambda (mark)
(%group-start (mark-group mark))))
(define-integrable group-end
(lambda (mark)
(%group-end (mark-group mark))))
)
(define (group-start? mark)
(mark= (group-start mark) mark))
(define (group-end? mark)
(mark= (group-end mark) mark))
(define (line-start? mark)
(or (group-start? mark)
(zero? (mark-position mark))))
(define (line-end? mark)
(or (group-end? mark)
(= (mark-position mark) (line-length (mark-line mark)))))
(define (limit-mark-motion limit? limit)
(cond ((eq? limit? 'LIMIT) limit)
((eq? limit? 'BEEP) (beep) limit)
((eq? limit? 'ERROR) (editor-error))
((not limit?) #!FALSE)
(else (error "Unknown limit type" limit?))))
(define (mark1+ mark limit?)
(cond ((group-end? mark)
(limit-mark-motion limit? mark))
((= (mark-position mark)
(line-length (mark-line mark)))
(make-mark (line-next (mark-line mark))
0))
(else
(make-mark (mark-line mark)
(1+ (mark-position mark))))))
(define (mark-1+ mark limit?)
(cond ((group-start? mark)
(limit-mark-motion limit? mark))
((zero? (mark-position mark))
(make-mark (line-previous (mark-line mark))
(line-length (line-previous (mark-line mark)))))
(else
(make-mark (mark-line mark)
(-1+ (mark-position mark))))))
(define (mark+ mark n limit?)
(cond ((positive? n)
(let ((end-mark (group-end mark)))
(let ((end-line (mark-line end-mark))
(end-position (mark-position end-mark)))
(define (loop line position n)
(if (eq? line end-line)
(let ((new-position (+ position n)))
(if (<= new-position end-position)
(make-mark line new-position)
(limit-mark-motion limit? end-mark)))
(let ((room (- (line-length line) position)))
(if (<= n room)
(make-mark line (+ position n))
(loop (line-next line) 0 (- n (1+ room)))))))
(loop (mark-line mark) (mark-position mark) n))))
((negative? n) (mark- mark (- n) limit?))
(else mark)))
(define (mark- mark n limit?)
(cond ((positive? n)
(let ((start-mark (group-start mark)))
(let ((start-line (mark-line start-mark))
(start-position (mark-position start-mark)))
(define (loop line position n)
(cond ((eq? line start-line)
(let ((new-position (- position n)))
(if (<= start-position new-position)
(make-mark line new-position)
(limit-mark-motion limit? start-mark))))
((<= n position)
(make-mark line (- position n)))
(else
(loop (line-previous line)
(line-length (line-previous line))
(- n (1+ position))))))
(loop (mark-line mark) (mark-position mark) n))))
((negative? n) (mark+ mark (- n) limit?))
(else mark)))
(define (region-count-chars region)
(region-components region
(lambda (start-line start-position end-line end-position)
(define (loop line accumulator)
(if (eq? line end-line)
(+ end-position accumulator)
(loop (line-next line)
(1+ (+ (line-length line) accumulator)))))
(if (eq? start-line end-line)
(- end-position start-position)
(loop (line-next start-line)
(1+ (- (line-length start-line) start-position)))))))
;;;; Mark Comparison
(define (mark= mark1 mark2)
(and (eq? (mark-line mark1) (mark-line mark2))
(= (mark-position mark1) (mark-position mark2))))
(define (mark< mark1 mark2)
(if (eq? (mark-line mark1) (mark-line mark2))
(< (mark-position mark1) (mark-position mark2))
(and (eq? (line-group (mark-line mark1))
(line-group (mark-line mark2)))
(< (line-number (mark-line mark1))
(line-number (mark-line mark2))))))
(define (mark<= mark1 mark2)
(if (eq? (mark-line mark1) (mark-line mark2))
(<= (mark-position mark1) (mark-position mark2))
(and (eq? (line-group (mark-line mark1))
(line-group (mark-line mark2)))
(< (line-number (mark-line mark1))
(line-number (mark-line mark2))))))
(define (mark> mark1 mark2)
(if (eq? (mark-line mark1) (mark-line mark2))
(> (mark-position mark1) (mark-position mark2))
(and (eq? (line-group (mark-line mark1))
(line-group (mark-line mark2)))
(> (line-number (mark-line mark1))
(line-number (mark-line mark2))))))
;;;; Line Movement
(define (line-offset line n if-ok if-not-ok)
(cond ((negative? n)
(let ((limit (mark-line (%group-start (line-group line)))))
(define (loop- line n)
(cond ((zero? n) (if-ok line))
((eq? line limit) (if-not-ok limit))
(else (loop- (line-previous line) (1+ n)))))
(if (eq? line limit)
(if-not-ok limit)
(loop- (line-previous line) (1+ n)))))
(else
(let ((limit (mark-line (%group-end (line-group line)))))
(define (loop+ line n)
(cond ((zero? n) (if-ok line))
((eq? line limit) (if-not-ok limit))
(else (loop+ (line-next line) (-1+ n)))))
(loop+ line n)))))
(define (line-start mark n limit?)
(line-offset (mark-line mark) n
(lambda (line)
(if (eq? line (mark-line (group-start mark)))
(group-start mark)
(make-mark line 0)))
(lambda (line)
(limit-mark-motion limit?
(if (negative? n)
(group-start mark)
(group-end mark))))))
(define (line-end mark n limit?)
(line-offset (mark-line mark) n
(lambda (line)
(if (eq? line (mark-line (group-end mark)))
(group-end mark)
(make-mark line (line-length line))))
(lambda (line)
(limit-mark-motion limit?
(if (negative? n)
(group-start mark)
(group-end mark))))))

605
edwin/newframe.scm Normal file
View File

@ -0,0 +1,605 @@
;(load "scoops.fsl")
(define extensions
(let ((blanks (make-string 10 #\space)))
(lambda (word w) ;word=string of 1 word followed by 1 blank
;w=window
(let ((c (string-ref word 0))
(word (substring word 1 (-1+ (string-length word)))))
(case c
(#\/ ;new term
(window-set-attribute! w 'text-attributes (attr 'yellow))
(display word w)
(window-set-attribute! w 'text-attributes (attr))
(display #\space w)
#!true)
(#\@ ;emphasis
(window-set-attribute! w 'text-attributes (attr 'red))
(display word w)
(window-set-attribute! w 'text-attributes (attr))
(display #\space w)
#!true)
(#\! ;break
(fresh-line )
(display word w)
(display #\space w)
#!true)
(#\] ;break and tab
(fresh-line w)
(display blanks w)
(display word w)
(display #\space w)
#!true)
(else #!false))))))
;;; the tutorial's frames ----------------------------------------
(set! *tutorial*
(make-tutorial
'name "SCOOPS"
'writeln-extensions extensions))
(frame
initial
("The tutorial will follow these conventions:"
"-- words in /yellow introduce new terms"
; "-- words in @red mark notable points"
"-- a happy-face character, like you see"
"at the bottom of this screen,"
"means Scheme is waiting on you to press a key"
"-- and text in green is the item under discussion.")
(:data "The SCOOPS Tutorial" :pp-data))
(frame
()
("This tutorial starts with an introduction to"
"object-oriented programming. Then it takes you through"
"SCOOPS, showing how to code with it and introducing"
"design principles appropriate to an object-oriented system."
"When the"
"tutorial is finished, you will have an opportunity to try your"
"own hand at working with SCOOPS."
; "The classes for this tutorial are POINT, LINE and RECTANGLE."
)
()
("Chapter 5 in the TI Scheme Language Reference Manual contains"
"full information on SCOOPS."))
(frame
SCOOPS
("/SCOOPS stands for the /SCheme /Object-Oriented /Programming /System."
"Object-oriented programming deals with the"
"interactions of /objects, which have properties"
"of data and code combined."
"An object consists of variables, which are private to the object"
"and contain its local state,"
"and procedures, also private to the object, which define its behavior.")
()
()
()
"Introduction to Object-Oriented Programming"
("object" "SCOOPS"))
(frame
()
("You communicate with an object by sending it a /message, which"
"is somewhat like a procedure call."
"The object responds by executing one of its"
"local procedures and returning a value to"
"the caller.")
()
("Unlike conventional languages where the caller directly invokes"
"a procedure by using its name, the object approach allows the"
"object to substitute any procedure it sees fit that can perform"
"the task that the message names--the caller"
"cannot force it to call a specific procedure.")
()
()
("message"))
(frame
()
("What we've really done is swap the roles of who's controlling who."
"In conventional languages, the caller has control over"
"what procedures get executed with what data."
"In the object-oriented approach, the data decides"
"what procedures it will use on itself, and uses the message mechanism"
"to keep the caller from knowing the details about how it"
"did it.")
()
("This is the fundamental point of a message."
"It requests some kind of action on the object's part, but"
"the wording of the message implies nothing about how it"
"performs the action. This gives an object great flexibility"
"in how it is implemented, and it greatly enhances the"
"modularity of the system.")
()
()
("message"))
(frame
()
("How does one build an object?"
"First you declare the kind of object you want;"
"this is called the object's /class."
"Defining a class is somewhat like defining a \"record\" or \"structure\""
"in a conventional language--it declares what an object looks like,"
"but it doesn't actually create one."
"A class definition will include things like:"
"-- the name of the class"
"-- what variables are local to the object and what ones can it reference"
"-- what are their default values"
"-- declarations of simple local procedures"
"-- the inheritance structure of the class."
"This last is a very powerful feature of an object-oriented system,"
"and we will come back to it later.")
()
()
()
()
("class"))
(frame
()
("Now, using the class description, we can create as many objects"
"of that kind as we wish."
"A created object is called an /instance."
"It takes up memory space, keeps its own state, and knows"
"what kind of object it is (its class)."
"In a conventional language, this is akin to dynamically allocating space"
"for a \"record\" variable.")
()
("Incidentally, the variables local to each instance are called"
"/instance /variables."
"One way to distinguish one instance from another is to look"
"at the state information contained in the instance variables."
"That is, of course, if the object will let us look at them.")
()
()
("instance" "instance variable"))
(frame
()
("Some object-oriented systems allow only instance variables;"
"that is, an instance cannot refer to any other variables than its own."
"Other systems allow varying degrees of freedom in where an instance"
"can look."
"For example, SCOOPS allows /class /variables."
"These are variables maintained by the class itself rather than"
"by each instance."
"Data that would be common to every instance can be factored out"
"into the class and stored just once, rather than repeating it"
"in every instance."
"It also provides a way for an instance to transfer data to other"
"similar instances.")
()
()
()
()
("class variable" ))
(frame
()
("So far what we've said makes objects sound very much like"
"conventional data structures such as records."
"But objects are not just places that hold variables--they hold"
"code too."
"These are the local procedures, or /methods, of an object."
"They're called methods to distinguish them from procedures"
"in a conventional language, which can be directly invoked by name."
"Methods cannot be directly invoked."
"Instead, an object, upon getting a message, decides what method"
"gets invoked."
"This determination can get quite involved, as you will see;"
"a conventional language has nothing quite like it.")
()
()
()
()
("method"))
(frame
()
("Unlike instance variables, which must all be declared in"
"a class declaration, so that every instance gets the same set,"
"methods can be added anytime to a class."
"Methods are local to a class, really, rather than each instance,"
"and so the code exists in the class, avoiding duplication for"
"each instance."
"More importantly, when a method is added or altered, all instances"
"\"see\" the effects immediately.")
()
() ;slot for text below
; ("For the record, to show some of the possibilities,"
; "some object-oriented systems"
; "actually do allow \"instance methods\"."
; "The \"ultimate\" architecture for an object-oriented programming"
; "system has yet to be determined.")
()
()
("method"))
(frame
()
("You've probably noticed that sometimes we're a little sloppy"
"in our terminology, for example, confusing \"instance\" and \"object\"."
"An \"object\" is really an abstract entity while an \"instance\""
"is its realization on a computer, but in practice everyone knows"
"what you mean."
"The words \"program\" and \"algorithm\" are also often used"
"interchangeably; it's no different here.")
()
("Similarly, we've talked about instances having \"instance variables\""
"and \"methods\"."
"Looked at abstractly, an instance does have these properties."
"On a real machine, though, it'd be real expensive if each instance"
"had to have its own copy of its methods, and so the implementation"
"collects them in the class to save space."
"But that is the implementor's worry and shouldn't be yours."
"The whole idea of objects is that you can't peer inside one."
"If you could seriously take advantage of what you might find there,"
"then it only indicates that the implementation must leave"
"something to be desired.")
()
()
("instance" "object" "method" "abstraction vs. implementation"))
(frame
()
("Now that you've got the general idea, let's get acquainted with SCOOPS"
"so that you can see objects in action and how you go about"
"constructing a program with objects."))
(frame
CLASS
("Objects often model real-world items."
"For the tutorial, we will construct a \"graphics world\""
"populated with shapes like points, lines, and rectangles."
"We will model the kinds of shapes with classes, and"
"individual shapes will be instances of those classes."
"To start out, then, we use the special form /DEFINE-CLASS"
"to create a class."
"For example:")
(:eval (or (getprop 'define-class 'pcs*macro)
(load "scoops.fsl"))
:data (define-class point (instvars (x 0) (y 0)))
:data-eval :pp-data)
("This defines a class named \"POINT\". Each instance of the class"
"contains two instance variables called X and Y, and each"
"is initialized to zero."
"! !This form of the definition allows us to create instances,"
"but that's all."
"We cannot create them with different initial values,"
"and once created, we cannot look at or change them in any way.")
()
"Defining a Class"
("DEFINE-CLASS"))
(frame
()
("Let's explore some of the possibilities of DEFINE-CLASS."
"First let's change POINT's definition so that we can create"
"points whose X and Y values won't always be zero."
"It would be rather dull to have all our points"
"be synonymous with the origin.")
(:data (define-class point (instvars (x 0) (y 0))
(options inittable-variables)) :data-eval :pp-data)
("The /inittable-variables option allows us to override"
"the default instance variable values whenever we create a point."
"The form used allows all of them to be initialized."
"If there is some reason to restrict which variables can be"
"initialized, instead of saying \"inittable variables\""
"we could have said something like \"(inittable variables x)\","
"which would allow only X to be initialized--Y would always get"
"its default value.")
()
()
("inittable-variables" "class options"))
(frame
()
("So far we can create points,"
"but we can't do anything with the X,Y values."
"They are inside a point object and are hidden to any caller."
"To do anything further requires object-local procedures--methods--to"
"handle the point's representation for the outside world."
"! !The simplest methods are those that just retrieve instance"
"variable values and return them. They are so simple, in fact,"
"that SCOOPS can create them on its own.")
(:data (define-class point (instvars (x 0) (y 0))
(options gettable-variables inittable-variables)) :data-eval :pp-data)
("We have a new option, /gettable-variables."
"This creates two messages, GET-X and GET-Y;"
"two methods, one to retrieve X and one to retrieve Y,"
"and associates the methods with the messages."
"As before, we can restrict which instance variables"
"get the gettable methods.")
()
()
("gettable-variables" "class options"))
(frame
()
("For the final touch, let's be able to change the instance variables."
"We have a new option.")
(:data (define-class point (instvars (x 0) (y 0))
(options settable-variables
gettable-variables
inittable-variables)) :data-eval :pp-data)
("The /settable-variables option creates the messages SET-X and SET-Y,"
"methods to change X and Y, and associates them."
"Here, too, we can restrict which instance variables are settable.")
()
()
("settable-variables" "class options"))
(frame
()
("You should note that the different options are mutually exclusive."
"You can have settable but not gettable variables, settables but"
"not inittables, or any other combination. And if you have no options"
"you get immutable objects that can't be initialized, examined, or"
"altered.")
()
("We should emphasize that"
"the notions of \"gettable\", \"settable\", and \"inittable\" are all"
"relative to what a caller sees."
"To the object's own methods, the instance variables are always"
"accessible at all times with no restrictions."
"This will be clearer when we define a method ourselves rather"
"than letting the system do it.")
()
()
("settable-variables" "gettable-variables" "inittable-variables"
"class options"))
(frame
()
("Although we haven't exhausted all the features of DEFINE-CLASS,"
"let's move on."
"We'll explore more of them as we need them."))
(frame
()
("Let's detour for a moment."
"We've being redefining our class so much, what does it really"
"look like at this moment?"
"Using /(DESCRIBE class-name) will tell us."
"Here's what it says for POINT.")
(:output (DESCRIBE POINT))
("The class name, instance variables, and methods we have already described;"
"the other items we have yet to discuss."
"DESCRIBE doesn't indicate which variables are initializable,"
"nor which methods are automatically generated.")
()
()
("DESCRIBE"))
(frame
COMPILE-CLASS
("Before we can create instances, we need to /compile the class."
"We don't mean here that we generate code for the class,"
"but rather we (re)organize the class's inheritance structure"
"for efficient execution."
"This can take time, depending on the complexity of the"
"inheritance structure."
"We don't have to do anything special, since the class"
"can be compiled when its first instance is made."
"Often, though, we know the class's complete inheritance structure"
"at compile (as in \"generate code\") time."
"If so, we can let the compiler compile the class."
"Then the system needn't do it while executing the program."
"We can use the special forms COMPILE-CLASS to compile the class"
"and CLASS-COMPILED? to see whether it has been or not.")
(:data (COMPILE-CLASS POINT) :data-eval :pp-data
:eval (fresh-line)
:data (CLASS-COMPILED? POINT) :data-eval :pp-data :yields :pp-evaled-data)
()
()
()
("compiling a class" "COMPILE-CLASS" "CLASS-COMPILED?"))
(frame
MAKE-INSTANCE
("To create an instance of a class you use the special form"
"MAKE-INSTANCE. The simplest format of it is:")
(:data (DEFINE P1 (MAKE-INSTANCE POINT)) :data-eval :pp-data)
("We've created a POINT instance and assigned it to variable P1."
"Since we said nothing special about initializing anything,"
"X and Y get their default values of zero.")
()
"Defining Instances"
("MAKE-INSTANCE" "creating instances"))
(frame
()
("To verify what we just said, we can DESCRIBE an instance as well"
"as a class."
"\"(DESCRIBE P1)\" gives this output:")
(:output (DESCRIBE P1))
("This tells us which class the object is an instance of"
"and the values of all the variables it can access.")
()
()
("DESCRIBE"))
(frame
()
("We can create arbitrary points by initializing them with"
"appropriate X and Y values.")
(:data (define p2 (make-instance point 'y 10)) :data-eval :pp-data
:eval (fresh-line)
:data (define p3 (make-instance point 'x 5 'y 15)) :data-eval :pp-data)
("For point P2 we initialized Y but let X default to zero."
"For point P3 we initialized everything."
"! !The next frame has DESCRIBE's of P2 and P3.")
()
()
("MAKE-INSTANCE"))
(frame
()
()
(:output (describe p2) :output (describe p3)))
(frame
SEND
("In order to change the values of X and Y we would send a message to P1"
"specifying the method we want to use to manipulate the data. For example,"
"the command:")
(:data (SEND P1 SET-X 50) :data-eval :pp-data)
("would change the value of X from 0, the initial value, to"
"50.")
()
"Sending Messages")
(frame
DEFINE-METHOD
("To define a method for a class you would use the special form"
"/DEFINE-METHOD. Let's define a method to display the instances of"
"the point class we've created. For example:")
(:data (DEFINE-METHOD (POINT DRAW) () (DRAW-POINT X Y)) :data-eval :pp-data)
("What we would have to do now is to send two messages, one"
"to change the value of X or Y and another to draw the point."
"This would be fine if we only wanted to put points on the"
"screen that were the same color and didn't mind old occurances"
"hanging around.")
()
"Defining Methods")
(frame
()
("First we can modify the class definition to include color. This is"
"simply adding another instance variable to be used to define the"
"color. Our class \"POINT\" could now be defined as:")
(:data (define-class point
(instvars (x 0)
(y 0)
(color 7))
(options settable-variables))
:data-eval :pp-data)
("Now we have another method defined for us, SET-COLOR. And we can"
"manipulate the COLOR variable as we have manipulated the X variable."
"The problem of having to send two messages, one to set the value and"
"the other to draw the point still exists, however."))
(frame
ACTIVE-VALUES
("We can modify the class definition to include /ACTIVE /VALUES."
"Active values are used to trigger procedure invocations whenever"
"the value of the variable is accessed or updated. The special form"
"-\"(ACTIVE 'INITIAL-VALUE' 'GET-FN' 'SET-FN')\" is used. Now when"
"we use SET-X, SET-X will call the \"set-fn\" and perform whatever action"
"that method indicates and will set the X to whatever value the"
"\"set-fn\" returns. Our class definition is now:")
(:data (define-class point
(instvars (x (active 0 () move-x))
(y (active 0 () move-y))
(color (active 7 () change-color))))
:data-eval :pp-data)
("Active values are automatically gettable and settable so we don't need to"
"specify those options.")
()
"Active Values")
(frame
()
("Now when we send a message to P1 to set X to some"
"value, the procedure MOVE-X is called automatically."
"Of course we still need to"
"write the procedures MOVE-X, MOVE-Y and CHANGE-COLOR.")
(:data (compile-class point) :data-eval))
(frame
()
("For example we will define the MOVE-Y method. First we will define"
"an ERASE method to erase the previous position of the point and then"
"we will define a REDRAW method to redraw the point in its new location.")
(:data (define-method (point erase) () (set-pen-color! 'black)
(draw-point x y)) :data-eval :pp-data :fresh-line
:data (define-method (point redraw) () (set-pen-color! color)
(draw-point x y)) :data-eval :pp-data :fresh-line
:data (define-method (point move-y) (new-y) (erase) (set! y new-y)
(redraw) new-y) :data-eval :pp-data)
())
(frame
()
("The methods for MOVE-X and CHANGE-COLOR would be very similar to MOVE-Y"
"now that we have the ERASE and REDRAW methods."
"-We could, if we wanted, send a message to P1 and have the"
"X value changed two ways. Either you can send a message to the"
"MOVE-X method with a new value to which to set the variable or you"
"can send a message to the SET-X method with a value and let Scheme"
"call the MOVE-X method automatically.")
(:data (define p1 (make-instance point)) :data-eval
:data (send p1 move-y -50) :data-eval :pp-data :fresh-line
:data (send p1 set-y -50) :data-eval :pp-data
:data (send p1 erase) :data-eval)
("These two calls are equivalent since SET-Y will automatically call"
"MOVE-Y."))
(frame
INHERITANCE
("Another powerful feature of object oriented programming is"
"/inheritance. Classes can inherit variables from previously"
"defined classes. For example the class \"LINE\" can inherit the"
"variables X, Y and COLOR from \"POINT\", and only need to define"
"length and direction. For example:")
(:data (define-class line
(instvars (len (active 50 () change-length))
(dir (active 0 () change-direction)))
(mixins point))
:data-eval :pp-data)
("Remember that for active values there is no need to specify options."
"The set and get methods are automatically generated. If we had some"
"procedure to be performed by the get-function, besides returning the"
"current value, then we could"
"specify a method to be executed automatically by substituting the"
"name where the \"()\" is before the set-function name.")
()
"Inheritance")
(frame
()
("In addition to inheriting variables from other classes, methods"
"are also inherited. This means that we do not have to define an"
"erase method, we inherited it from \"POINT\". In fact the only methods"
"we have to define are CHANGE-LENGTH, CHANGE-HEIGHT and DRAW."
"We need our own draw method to draw a line instead of a point."
"The practice of writing your methods to be as general as"
"possible facilitates the inheritance feature."))
(frame
()
("Having defined the CHANGE-LENGTH and CHANGE-DIRECTION methods,"
"we could modify the LINE by sending messages to the SET-LEN"
"and SET-DIR methods. If we then decide to change LINE to be another"
"set of X and Y coordinates, instead of a length and direction,"
"we could modify CHANGE-LENGTH to calculate the new position."
"Since CHANGE-LENGTH is called automatically by SET-LEN, the user"
"code would not"
"have to be changed. It would keep sending a message to SET-LEN"
"with a new length and never know that we modified two variables and"
"changed the representation of line. This is another powerful"
"feature of object oriented programming, the ability to change"
"the way the data is structured and not have to change the user"
"program!"))
(frame
CONCLUSION
("You may want to print out the file scpsdemo.s, if you haven't already"
"done so, and look at the definitions of the classes. You"
"will notice that the class \"RECTANGLE\" inherits \"POINT's\""
"variables indirectly by inheriting \"LINE\".")
()
("Following this tutorial there is a demonstration using the class"
"\"RECTANGLE\". During the demonstration it is not possible to go"
"backwards, only forwards. A light touch on the keyboard is advised.")
()
"Conclusion")


60
edwin/nstring.scm Normal file
View File

@ -0,0 +1,60 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Character string operations
(define (substring-append string1 start1 end1
string2 start2 end2)
(%string-append string1 start1 end1
nil
string2 start2 end2))
(define (string-delete string start end)
(%string-append string 0 start
nil
string end (string-length string)))
(define (string-insert-substring string1 start1 string2 start2 end2)
(%string-append string1 0 start1
(substring string2 start2 end2)
string1 start1 (string-length string1)))


125
edwin/parens.scm Normal file
View File

@ -0,0 +1,125 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 8/15/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (backward-one-list start end)
(backward-sexp:top start end 0))
(define backward-sexp:top
(lambda (start end depth)
(letrec
((backward-sexp:top
(lambda (start end depth)
(and (mark> start end)
(search-backward start end depth))))
(search-backward
(lambda (start end depth)
(let ((mark (find-previous-char-in-set start end sexp-delims)))
(and mark
(cond
((char=? (mark-left-char mark) ;;; (
#\) )
(list-backward-close (mark-1+ mark #!false) end depth))
(else
(if (and (<>? depth 1)
(terminate? mark))
#!false
(list-backward-open (mark-1+ mark #!false)
end depth))))))))
(terminate?
(lambda (mark)
(and (= 1 (mark-position mark))
(let ((m (line-start mark -1 #!false)))
(and m
(line-blank? m))))))
(list-backward-close
(lambda (start end depth)
(if (= depth -1)
start
(backward-sexp:top start end (1+ depth)))))
(list-backward-open
(lambda (start end depth)
(and (> depth 0)
(if (= depth 1)
start
(backward-sexp:top start end (-1+ depth)))))))
(backward-sexp:top start end depth))))
(define with-reverse-attributes
(let ((reverse-attr
(if (= pcs-machine-type 1) ;;; recode for unknown machine type
31 ;;; TI
112)) ;;; IBM
(display-matching-paren
(lambda (old)
(let ((x (%reify-port buffer-screen screen:cursor-x))
(y (%reify-port buffer-screen screen:cursor-y)))
(princ #\( buffer-screen) ;;;;)
(delay-input 50 buffer-screen)
(%reify-port! buffer-screen 7 old)
(%reify-port! buffer-screen screen:cursor-x x)
(%reify-port! buffer-screen screen:cursor-y y)
(princ #\( buffer-screen))))) ;;;;;)
(lambda ()
(let ((old (%reify-port buffer-screen 7)))
(update-display! (current-window))
(%reify-port! buffer-screen 7 reverse-attr)
(display-matching-paren old)))))
(define delay-input
(let ((delay-time
(if (= pcs-machine-type 1) ;;; recode for unknown machine type
500 ;;; TI
1200))) ;;; IBM
(lambda (n screen)
((rec loop
(lambda (n)
(if (char-ready? screen)
#!true
(if (zero? n)
#!false
(loop (-1+ n)))))) delay-time))))


444
edwin/redisp1.scm Normal file
View File

@ -0,0 +1,444 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 10/21/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; define-integrables
(begin
(define-integrable inferior:x-start cddr)
(define-integrable inferior:y-start cadr)
(define-integrable inferior:line caar)
(define-integrable inferior:y-size cdar)
(define-integrable set-inferior:x-start!
(lambda (inferior val)
(set-cdr! (cdr inferior) val)))
(define-integrable set-inferior:y-start!
(lambda (inferior val)
(set-car! (cdr inferior) val)))
(define-integrable set-inferior:line!
(lambda (inferior val)
(set-car! (car inferior) val)))
(define-integrable set-inferior:y-size!
(lambda (inferior val)
(set-cdr! (car inferior) val)))
(define-integrable screen:cursor-y 0)
(define-integrable screen:cursor-x 1)
(define-integrable screen:x-size 5)
(define-integrable screen:y-size 4)
(define-integrable window:point 0)
(define-integrable window:lines 1)
(define-integrable window:map 2)
(define-integrable window:screen 3)
(define-integrable window:y-size 4)
(define-integrable window:start 5)
(define-integrable window:end 6)
(define-integrable window:buffer 7)
(define-integrable window:cursor-x 8)
(define-integrable window:cursor-y 9)
(define-integrable window:redisplay-window-flag 10)
(define-integrable window:redisplay-cursor-flag 11)
(define-integrable window:start-mark 12)
(define-integrable window:end-mark 13)
(define-integrable window:last-inferior-y 14)
(define-integrable window-point
(lambda (window)
(vector-ref window window:point)))
(define-integrable window-point-x
(lambda (window)
(vector-ref window window:cursor-x)))
(define-integrable window-point-y
(lambda (window)
(vector-ref window window:cursor-y)))
(define-integrable window-buffer
(lambda (window)
(vector-ref window window:buffer)))
(define-integrable window-screen
(lambda (window)
(vector-ref window window:screen)))
(define-integrable window-y-size
(lambda (window)
(vector-ref window window:y-size)))
(define-integrable window-x-size
(lambda (window)
80))
)
(define update-cursor!
(lambda (window)
(let ((screen (vector-ref window window:screen))
(x (vector-ref window window:cursor-x))
(y (vector-ref window window:cursor-y)))
(vector-set! window window:redisplay-cursor-flag #!false)
(if (and (not (negative? x))
(not (negative? y)))
(set-screen-cursor! screen x y)))))
(define (set-screen-cursor! screen x y)
(%reify-port! screen screen:cursor-x x)
(%reify-port! screen screen:cursor-y y))
(define set-cursor-pos
(lambda (window x y)
(vector-set! window window:cursor-x x)
(vector-set! window window:cursor-y y)
(vector-set! window window:redisplay-cursor-flag #!true)))
(define write-string!
(lambda (screen string x y)
(set-screen-cursor! screen x y)
(princ string screen)))
(define (make-buffer-window screen buffer)
(define (setup-inferior-table table y-size)
(do ((i 0 (1+ i))
(table table))
((= i y-size) table)
(vector-set! table i (cons (cons #!false #!false) (cons i 0)))))
(define initialize!
(lambda (window buffer)
(add-buffer-window! buffer window)
;;;; this is for the speed up hack insertch.scm
(%create-char-daemon window)
(let ((group (buffer-group buffer)))
(add-group-delete-daemon! group (make-delete-daemon window))
(add-group-insert-daemon! group (make-insert-daemon window)))
(vector-set! window window:point (buffer-point buffer))))
(let ((window (make-vector 15 #!false))
(start-buffer (buffer-start buffer))
(y-size (%reify-port screen screen:y-size)))
(let ((table (setup-inferior-table (make-vector y-size) y-size)))
(vector-set! window window:y-size y-size)
(vector-set! window window:lines table)
(vector-set! window window:screen screen)
(vector-set! window window:buffer buffer)
(update-bottom-inferior! (mark-line start-buffer) 0 0
(vector-ref table 0) table y-size)
(map-changed! window)
(vector-set! window window:start 0)
(vector-set! window window:end 0)
(vector-set! window window:cursor-x 0)
(vector-set! window window:cursor-y 0)
(vector-set! window window:start-mark start-buffer)
(vector-set! window window:end-mark start-buffer)
(vector-set! window window:last-inferior-y 0)
(initialize! window buffer)
window)))
(define window-y-size-changed
(lambda (window)
(vector-set! window window:y-size
(%reify-port (vector-ref window window:screen)
screen:y-size))
(vector-set! window window:map '())
(window-redraw! window)))
(define line->y
(lambda (window line)
(let ((entry (assq line (vector-ref window window:map))))
(and entry
(cdr entry)))))
(define set-window-point!
(lambda (window mark)
(let ((buffer (vector-ref window window:buffer)))
(set-buffer-point! buffer mark)
(vector-set! window window:point (buffer-point buffer))
(cursor-moved! window))))
(define cursor-moved!
(lambda (window)
(let ((point (vector-ref window window:point)))
(if (window-mark-visible? window point)
(set-cursor-coordinates window point)
(window-redraw! window)))))
(define (map-changed! window)
(define (loop tail n table y-size)
(if (or (>= n y-size)
(null? (inferior:line (vector-ref table n))))
tail
(let ((inferior (vector-ref table n)))
(loop (cons (cons (inferior:line inferior) n)
tail)
(+ (inferior:y-start inferior) (inferior:y-size inferior))
table y-size))))
(let ((map (loop '() 0 (vector-ref window window:lines)
(vector-ref window window:y-size))))
(vector-set! window window:map map)
(vector-set! window window:last-inferior-y (cdar map))))
(define clear-subscreen!
(lambda (screen xl yl lin col)
(let ((sxl (%reify-port screen 3))
(syl (%reify-port screen 2))
(slin (%reify-port screen 4))
(scol (%reify-port screen 5))
(change-cord
(lambda (x y l c)
(%reify-port! screen 3 x)
(%reify-port! screen 2 y)
(%reify-port! screen 4 l)
(%reify-port! screen 5 c))))
(change-cord (+ sxl xl) (+ syl yl) lin col)
(%clear-window screen)
(change-cord sxl syl slin scol))))
(define (redisplay window table start end)
(let loop ((screen (window-screen window)) (n start) (end end)
(table table) (y-size (vector-ref window window:y-size)))
(if (> n end)
'()
(let ((inferior (vector-ref table n)))
(if (inferior:line inferior)
(begin
(let ((y-start (inferior:y-start inferior))
(ys (inferior:y-size inferior))
(string (line-string (inferior:line inferior))))
(set-screen-cursor! screen 0 (max 0 y-start))
(%substring-display string 0 (string-length string) y-start
screen)
(loop screen (+ y-start ys) end table y-size)))
(clear-subscreen! screen 0 n (1+ (- end n)) 80))))))
(define update-window!
(lambda (window)
(let ((table (vector-ref window window:lines))
(start (vector-ref window window:start))
(end (vector-ref window window:end)))
(redisplay window table start end)
(vector-set! window window:redisplay-window-flag #!false))))
(define update-display!
(lambda (window)
(if (vector-ref window window:redisplay-window-flag)
(update-window! window))
(if (vector-ref window window:redisplay-cursor-flag)
(update-cursor! window))))
(define reset-buffer-window
(lambda (window)
(vector-set! window window:start 0)
(vector-set! window window:end
(-1+ (vector-ref window window:y-size)))
(vector-set! window window:redisplay-window-flag #!true)
(vector-set! window window:redisplay-cursor-flag #!true)
(update-display! window)))
;;; redisp2
(define window-redraw!
(letrec ((%receiver (lambda (w) (error "window-redraw"))))
(lambda (window)
(let ((mark (vector-ref window window:point))
(y (quotient (vector-ref window window:y-size) 2)))
(set-start-end! window 0 (-1+ (vector-ref window window:y-size)))
(redraw-screen! window mark y)
(everything-changed! window %receiver)))))
(define redraw-screen!
(lambda (window mark y)
(let ((line (mark-line mark))
(table (vector-ref window window:lines))
(y-size (vector-ref window window:y-size))
(position (mark-position mark))
(string (line-string (mark-line mark))))
(let ((y* (index->y (char->x string position) 80 position string)))
(let ((start (max 0 (- y y*)))
(ys (find-y-size line))
(y-start (- y y*)))
(clean-up-table table 0 y-size)
(update-inferior! line 0 y-start ys (vector-ref table start))
(if (> ys 1)
(fill-entries (1+ start) (min y-size (+ y-start ys))
start table y-size))
(fill-top! window line table y-size start #!TRUE))))))
(define everything-changed!
(lambda (window if-not-visible)
(map-changed! window)
(start-mark-changed! window)
(end-mark-changed! window)
(if (window-mark-visible? window (vector-ref window window:point))
(begin
(cursor-moved! window))
(if-not-visible window))))
(define (window-mark-visible? window mark)
(and (mark<= (vector-ref window window:start-mark) mark)
(mark<= mark (vector-ref window window:end-mark))))
(define (line-visible? window point)
(assq (mark-line point)
(vector-ref window window:map)))
;;; coordinates
(define window-coordinates->mark
(lambda (window x y)
(let* ((table (vector-ref window window:lines))
(inferior (vector-ref table y)))
(make-mark (inferior:line inferior)
(x->char (line-string (inferior:line inferior))
(+ x (* (- y (inferior:y-start inferior)) 79)))))))
(define (start-mark-changed! window)
(vector-set! window window:start-mark
(window-coordinates->mark window 0 0)))
(define (end-mark-changed! window)
(let ((inferior (vector-ref (vector-ref window window:lines)
(vector-ref window window:last-inferior-y)))
(y-size (vector-ref window window:y-size)))
(let ((line (inferior:line inferior))
(y-start (inferior:y-start inferior))
(ys (inferior:y-size inferior)))
(vector-set! window window:end-mark
(make-mark
line
(end-column->index
(line-string line)
(+ 79 (* (- (-1+ (min y-size (+ y-start ys))) y-start) 79))))
))))
(define (maybe-marks-changed window y)
(if (= y 0)
(start-mark-changed! window))
(if (= y (vector-ref window window:last-inferior-y))
(end-mark-changed! window)))
;;; index->column
(define (char->x string char-no)
(let loop ((start 0)(tot 0)(end char-no)(string string))
(let ((index (substring-find-next-char-in-set string start end
non-graphic-chars)))
(if index
(let ((tot (+ tot (- index start))))
(loop (1+ index)
(+ tot (if (char-ci=? #\tab (string-ref string index))
(- 8 (remainder tot 8))
2))
end string))
(+ tot (- end start))))))
;;; column->index
(define (x->char string column)
(let loop ((string string)(start 0)(c 0)(end (string-length string))
(column column))
(let ((i (substring-find-next-char-in-set string start end
non-graphic-chars)))
(if i
(let ((new-c (+ c (- i start))))
(if (<= column new-c)
(+ start (- column c))
(let ((new-c (+ new-c
(if (char-ci=? #\tab (string-ref string i))
(- 8 (remainder new-c 8))
2))))
(if (<= column new-c)
(1+ i)
(loop string (1+ i) new-c end column)))))
(min (+ start (- column c)) end)))))
(define (end-column->index string column)
(let loop ((string string)(start 0)(c 0)(end (string-length string))
(column column))
(let ((i (substring-find-next-char-in-set string start end
non-graphic-chars)))
(if i
(let ((new-c (+ c (- i start))))
(if (<= column new-c)
(+ start (- column c))
(let ((new-c (+ new-c
(if (char-ci=? #\tab (string-ref string i))
(- 8 (remainder new-c 8))
2))))
(cond ((<? column new-c) i)
((=? column new-c)
(if (=? 1 (- end i)) (1+ i) i))
(else (loop string (1+ i) new-c end column))))))
(let ((i (+ start (- column c))))
(cond ((<? end i) end)
((=? end i) end)
(else (-1+ i))))))))


428
edwin/redisp2.scm Normal file
View File

@ -0,0 +1,428 @@
;;;
;;; Copyright (c) 1985 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of
;;; Electrical Engineering and Computer Science. Permission to
;;; copy this software, to redistribute it, and to use it for any
;;; purpose is granted, subject to the following restrictions and
;;; understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a)
;;; to return to the MIT Scheme project any improvements or
;;; extensions that they make, so that these may be included in
;;; future releases; and (b) to inform MIT of noteworthy uses of
;;; this software.
;;;
;;; 3. All materials developed as a consequence of the use of
;;; this software shall duly acknowledge such use, in accordance
;;; with the usual standards of acknowledging credit in academic
;;; research.
;;;
;;; 4. MIT has made no warrantee or representation that the
;;; operation of this software will be error-free, and MIT is
;;; under no obligation to provide any services, by way of
;;; maintenance, update, or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the
;;; Massachusetts Institute of Technology nor of any adaptation
;;; thereof in any advertising, promotional, or sales literature
;;; without prior written consent from MIT in each case.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modified by Texas Instruments Inc 10/21/85
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (window-scroll-y-absolute! window y-point)
(window-scroll-y-relative! window (- (window-point-y window) y-point)))
(define window-scroll-y-relative!
(letrec ((%receiver
(lambda (w)
(let ((buffer (vector-ref w window:buffer))
(table (vector-ref w window:lines)))
(set-buffer-point! buffer (window-coordinates->mark w 0 0))
(vector-set! w window:point (buffer-point buffer))
(cursor-moved! w)))))
(lambda (window y-delta)
(cond ((negative? y-delta) (scroll-down-y! window (- y-delta)))
((positive? y-delta) (scroll-up-y! window y-delta)))
(if (<> y-delta 0)
(begin
(set-start-end! window 0 (-1+ (vector-ref window window:y-size)))
(everything-changed! window %receiver))))))
;;; Scrolling
;;; Scrolling down
(define (scroll-down-y! window y-delta)
(define (check-y-start y-delta table y-size)
(let ((y-start (inferior:y-start (vector-ref table y-delta))))
(if (< y-start y-delta)
(let ((y (max 0 y-start)))
(fill-entries y y-delta y-delta table y-size)
y)
y-delta)))
(let ((table (vector-ref window window:lines))
(y-size (vector-ref window window:y-size)))
(if (< y-delta y-size)
(begin
(scroll-lines-down! window y-delta y-size table 0)
(let ((y (check-y-start y-delta table y-size)))
(fill-top! window (inferior:line (vector-ref table y))
table y-size y #!false)))
(redraw-screen! window
(line-start
(make-mark (inferior:line (vector-ref table 0)) 0)
(- 0 y-delta) 'ERROR)
0))))
(define (scroll-lines-down! window y-delta y-size table y)
(let loop ((n (-1+ (- y-size y-delta)))
(table table))
(if (< n y)
'()
(let ((inferior (vector-ref table n)))
(if (inferior:line inferior)
(begin
(set-inferior:line! (vector-ref table (+ n y-delta))
#!false)
(exchange-inferiors table n (+ n y-delta))))
(loop (-1+ n) table)))))
(define (scroll-up-y! window y-delta)
(let ((table (vector-ref window window:lines))
(y-size (vector-ref window window:y-size)))
(if (< y-delta y-size)
(if (inferior:line (vector-ref table y-delta))
(scroll-lines-up! window y-delta y-size table y-delta)
'())
(redraw-screen! window
(line-start
(make-mark (inferior:line (vector-ref table 0)) 0)
y-delta 'ERROR)
0))))
(define (scroll-lines-up! window y-delta y-size table y)
(define (loop n y-size table)
(let ((move-to (- n y-delta)))
(if (or (>= n y-size)
(not (inferior:line (vector-ref table n))))
(fill-bottom! move-to y-size table
(inferior:line (vector-ref table (-1+ move-to))))
(begin
(set-inferior:line! (vector-ref table move-to) #!false)
(exchange-inferiors table move-to n)
(loop (1+ n) y-size table)))))
(loop y y-size table))
;;; Fill top and Bottom
(define (fill-top! window %line table y-size n fill-bottom?)
(define (loop y table line)
(cond ((< y 0)
(if fill-bottom?
(let ((inferior (vector-ref table n)))
(let ((ys (inferior:y-size inferior))
(y-start (inferior:y-start inferior)))
(fill-bottom! (+ ys y-start) y-size table %line)))))
((null? line)
(scroll-lines-up! window (+ y 1) y-size table (+ y 1)))
(else
(let ((inferior (vector-ref table y)))
(update-top-inferior! 0 y line table inferior y-size)
(loop (- y (inferior:y-size inferior)) table
(line-previous line))))))
(loop (-1+ n) table (line-previous %line)))
(define (update-top-inferior! x y line table inferior ys)
(let ((y-size (find-y-size line)))
(update-inferior! line x (1+ (- y y-size)) y-size inferior)
(if (> y-size 1)
(fill-entries (max 0 (1+ (- y y-size))) y y table ys))))
;;; Fill Bottom
(define (fill-bottom! n y-size table line)
(define (loop n line y-size table)
(if (< n y-size)
(let ((inferior (vector-ref table n)))
(if (null? line)
(begin
(set-inferior:line! inferior #!false)
(loop (1+ n) '() y-size table))
(begin
(update-bottom-inferior! line 0 n inferior table y-size)
(loop (+ n (inferior:y-size inferior)) (line-next line)
y-size table))))))
(loop n (line-next line) y-size table))
(define (update-bottom-inferior! line x y inferior table ys)
(let ((y-size (find-y-size line)))
(update-inferior! line x y y-size inferior)
(if (> y-size 1)
(fill-entries (1+ y) (min ys (+ y y-size)) y table ys))))
(define (update-inferior! line x y y-size inferior)
(set-inferior:x-start! inferior x)
(set-inferior:y-start! inferior y)
(set-inferior:line! inferior line)
(set-inferior:y-size! inferior y-size))
;;; Fill enteries
(define (fill-entries start end copy-entry table ys)
(let ((copy-entry (vector-ref table copy-entry)))
(do ((x-start (inferior:x-start copy-entry))
(y-start (inferior:y-start copy-entry))
(y-size (inferior:y-size copy-entry))
(line (inferior:line copy-entry))
(n start (1+ n)))
((or (>= n ys) (= n end)) #!true)
(and (>= n 0)
(let ((entry (vector-ref table n)))
(set-inferior:x-start! entry x-start)
(set-inferior:y-start! entry y-start)
(set-inferior:y-size! entry y-size)
(set-inferior:line! entry line))))))
(define (exchange-inferiors table n1 n2)
(let ((inferior1 (vector-ref table n1))
(inferior2 (vector-ref table n2))
(diff (- n2 n1)))
(set-inferior:y-start! inferior1
(+ diff (inferior:y-start inferior1)))
(set-inferior:y-start! inferior2
(- (inferior:y-start inferior2) diff))
(vector-set! table n1 inferior2)
(vector-set! table n2 inferior1)))
(define (clean-up-table table n1 n2)
(do ((i n1 (1+ i))
(table table))
((= i n2) table)
(set-inferior:line! (vector-ref table i) #!false)))
(define (find-y-size line)
(let* ((string (line-string line))
(x (char->x string (string-length string))))
(if (zero? x)
1
(let ((q (quotient x 79))
(r (remainder x 79)))
(if (zero? r)
q
(1+ q))))))
(define (set-cursor-coordinates window mark)
(let ((line (mark-line mark))
(position (mark-position mark))
(string (line-string (mark-line mark)))
(x-size (window-x-size window))
(table (vector-ref window window:lines)))
(let ((y (inferior:y-start
(vector-ref table (line->y window line))))
(x (char->x string position)))
(set-cursor-pos window
(index->x x x-size position string)
(+ y (index->y x x-size position string))))))
(define (index->x column x-size index string)
(if (zero? column)
0
(let ((r (remainder column (-1+ x-size))))
(if (zero? r)
(if (=? index (string-length string))
(-1+ x-size)
r)
r))))
(define (index->y column x-size index string)
(if (zero? column)
0
(let ((q (quotient column (-1+ x-size)))
(r (remainder column (-1+ x-size))))
(if (zero? r)
(if (=? index (string-length string))
(-1+ q)
q)
q))))
(define make-insert-daemon
(lambda (window)
(letrec
((%receiver
(lambda (region)
(region-components region
(lambda (start-line start-position end-line end-position)
(let* ((table (vector-ref window window:lines))
(inferior (vector-ref table y)))
(let ((y-size (vector-ref window window:y-size))