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))
(old-ys (inferior:y-size inferior))
(new-ys (find-y-size start-line)))
(cond
((eq? start-line end-line)
(if (= old-ys new-ys)
(begin
(maybe-marks-changed window y)
(set-start-end! window y y)
(cursor-moved! window))
(begin
(scroll-lines-down! window (- new-ys old-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!))))
(else
(update-bottom-inferior! start-line 0 y
inferior table y-size)
(fill-bottom! (+ y new-ys) y-size table start-line)
(set-start-end! window y (-1+ y-size))
(everything-changed! window window-redraw!)))))))))
(y '()))
(lambda (mark)
(if (line-visible? window mark)
(begin
(set! y (line->y window (mark-line mark)))
%receiver))))))
(define set-start-end!
(lambda (window start end)
(if (vector-ref window window:redisplay-window-flag)
(begin
(vector-set! window window:start
(min start (vector-ref window window:start)))
(vector-set! window window:end
(max end (vector-ref window window:end))))
(begin
(vector-set! window window:start start)
(vector-set! window window:end end)))
(vector-set! window window:redisplay-window-flag #!TRUE)))
(define make-delete-daemon
(lambda (window)
(letrec
((start-y '())
(end-y '())
(mark '())
(%receiver
(lambda (region)
(let ((table (vector-ref window window:lines))
(line (mark-line mark))
(y-size (vector-ref window window:y-size)))
(set! mark '()) ;; clean up
(cond ((not start-y) ;;; deleted top
(cond ((not end-y)
(window-redraw! window))
(else
(clean-up-table table 0 y-size)
(update-bottom-inferior! line 0 end-y
(vector-ref table end-y) table y-size)
(fill-top! window line table y-size end-y #!true)
(set-start-end! window 0 (-1+ y-size))
(everything-changed! window window-redraw!))))
((and end-y (=? start-y end-y))
(let ((inferior (vector-ref table start-y)))
(let ((old-ys (inferior:y-size inferior))
(new-ys (find-y-size line))
(y start-y))
(if (= old-ys new-ys)
(begin
(maybe-marks-changed window y)
(set-start-end! window y y)
(cursor-moved! window))
(begin
(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!))))))
(else
(let ((inferior (vector-ref table start-y)))
(let ((ys (find-y-size line))
(y start-y))
(update-bottom-inferior! line 0 y inferior table y-size)
(fill-bottom! (+ y ys) y-size table line)
(set-start-end! window y (-1+ y-size))
(everything-changed! window window-redraw!)))))))))
(lambda (region)
(let ((start (region-start region))
(end (region-end region)))
(let ((*line (mark-line start))
(*pos (mark-position start)))
(set! start-y (line->y window *line))
(set! end-y (line->y window (mark-line end)))
(set! mark (if (and start-y end-y (= start-y end-y))
start
(mark-permanent! start)))
%receiver))))))
(define direct-output-for-insert!
(lambda (window char)
(let ((x (vector-ref window window:cursor-x))
(y (vector-ref window window:cursor-y))
(screen (vector-ref window window:screen)))
(maybe-marks-changed window y)
(write-string! screen char x y )
(vector-set! window window:cursor-x
(1+ x)))))
(define direct-output-forward-character!
(lambda (window)
(let ((screen (vector-ref window window:screen))
(buffer (vector-ref window window:buffer))
(point (vector-ref window window:point))
(x (vector-ref window window:cursor-x)))
(set-buffer-point! buffer (mark1+ point #!false))
(vector-set! window window:point (buffer-point buffer))
(%reify-port! screen screen:cursor-x (1+ x))
(vector-set! window window:cursor-x (1+ x)))))
(define direct-output-backward-character!
(lambda (window)
(let ((screen (vector-ref window window:screen))
(buffer (vector-ref window window:buffer))
(point (vector-ref window window:point))
(x (vector-ref window window:cursor-x)))
(set-buffer-point! buffer (mark-1+ point #!false))
(vector-set! window window:point (buffer-point buffer))
(%reify-port! screen screen:cursor-x (-1+ x))
(vector-set! window window:cursor-x (-1+ x)))))


405
edwin/regops.scm Normal file
View File

@ -0,0 +1,405 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Region Operations
;;;; String <-> Region
(define (string->region string)
(substring->region string 0 (string-length string)))
(define (substring->region string start end)
(let ((nl (substring-find-next-char string start end #\Newline)))
(if (not nl)
(let ((line (make-line (substring string start end))))
(lines->region line line))
(let ((first-line (make-line (substring string start nl)))
(group (make-group #!FALSE)))
(define (loop previous-line n start)
(let ((nl (substring-find-next-char string start end #\Newline)))
(if (not nl)
(let ((last-line (make-line (substring string start end))))
(connect-lines! previous-line last-line)
(set-line-group! last-line group)
(set-line-number! last-line n)
(let ((region
(components->region first-line 0 last-line
(line-length last-line))))
(%set-group-region! group region)
region))
(let ((this-line (make-line (substring string start nl))))
(connect-lines! previous-line this-line)
(set-line-group! this-line group)
(set-line-number! this-line n)
(loop this-line (+ n line-number-increment) (1+ nl))))))
(set-line-group! first-line group)
(set-line-number! first-line 0)
(loop first-line line-number-increment (1+ nl))))))
(define (region->string region)
(region-components region
(lambda (start-line start-position end-line end-position)
(if (eq? start-line end-line)
(substring (line-string start-line) start-position end-position)
(let ((result (string-allocate (region-count-chars region))))
(define (loop target line)
(string-set! result target #\Newline)
(if (eq? line end-line)
(substring-move-right! (line-string end-line) 0 end-position
result (1+ target))
(begin (substring-move-right! (line-string line) 0
(line-length line)
result (1+ target))
(loop (+ target (line-length line) 1)
(line-next line)))))
(substring-move-right! (line-string start-line) start-position
(line-length start-line) result 0)
(loop (- (line-length start-line) start-position)
(line-next start-line))
result)))))
;;;; Copy Region
(define (region-copy region)
(region-components region
(lambda (start-line start-position end-line end-position)
(if (eq? start-line end-line)
(let ((line (subline start-line start-position end-position)))
(lines->region line line))
(let ((new-start (subline start-line
start-position
(line-length start-line)))
(group (make-group #!FALSE)))
(define (loop this-line n new-previous)
(if (eq? this-line end-line)
(let ((new-end (subline end-line 0 end-position)))
(connect-lines! new-previous new-end)
(set-line-group! new-end group)
(set-line-number! new-end n)
(let ((region
(components->region new-start 0
new-end (line-length new-end))))
(%set-group-region! group region)
region))
(let ((new-this (line-copy this-line)))
(connect-lines! new-previous new-this)
(set-line-group! new-this group)
(set-line-number! new-this n)
(loop (line-next this-line)
(+ n line-number-increment)
new-this))))
(set-line-group! new-start group)
(set-line-number! new-start 0)
(loop (line-next start-line)
line-number-increment
new-start))))))
;;;; Extract Region
(define (region-extract! region)
(let ((sync (region-delete-starting! region)))
(let ((extracted-region (region-components region %region-extract!)))
(sync extracted-region)
extracted-region)))
(define %region-extract!
(letrec
((%start-pos '())
(%end-pos '())
(%offset '())
(%new-line '())
(%receiver1
(lambda (mark cursor?)
(cond ((> (mark-position mark) %end-pos)
(set-mark-position! mark (- (mark-position mark) %offset)))
((> (mark-position mark) %start-pos)
(set-mark-position! mark %start-pos)))))
(%receiver2
(lambda (mark cursor?)
((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
(set-mark-position! mark
(if (> (mark-position mark) %end-pos)
(- (mark-position mark) %offset)
%start-pos))))
(%receiver3
(lambda (mark cursor?)
((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
(set-mark-position! mark %start-pos)))
(%receiver4
(lambda (mark cursor?)
((if cursor? %set-mark-line! set-mark-line!) mark %new-line)
(if (> (mark-position mark) %start-pos)
(set-mark-position! mark %start-pos)))))
(lambda (start-line start-pos end-line end-pos)
(letrec
((move-marks!
(lambda (line)
(if (eq? line end-line)
(for-each-mark! end-line %receiver2)
(begin (for-each-mark! line %receiver3)
(move-marks! (line-next line)))))))
(set! %start-pos start-pos)
(set! %end-pos end-pos)
(if (eq? start-line end-line)
(let ((offset (- end-pos start-pos)))
(set! %offset offset)
(for-each-mark! start-line %receiver1)
(let ((line (subline-extract! start-line start-pos end-pos)))
(lines->region line line)))
(let ((new-line (line-extract! start-line start-pos end-line end-pos))
(offset (- end-pos start-pos))
(start-previous (line-previous start-line))
(end-next (line-next end-line)))
(set! %new-line new-line)
(set! %offset offset)
(for-each-mark! start-line %receiver4)
(move-marks! (line-next start-line))
(set-line-group! new-line (line-group start-line))
(set! %new-line '())
(disconnect-lines! start-line end-line)
(connect-lines! start-previous new-line)
(connect-lines! new-line end-next)
(number-lines! new-line new-line)
(lines->region start-line end-line)))))))
;;;; Insert Region
(define (region-insert! mark region)
(let ((sync (region-insert-starting! mark)))
(let ((region*
(region-components region
(lambda (start-line start-pos end-line end-pos)
((lambda (line pos)
(%region-insert! line pos
start-line start-pos
end-line end-pos))
(mark-line mark) (mark-position mark) )))))
(sync region*)
region*)))
(define %region-insert!
(letrec
((%pos '())
(%offset '())
(%end-line '())
(%end-pos '())
(%receiver1
(lambda (mark cursor?)
(if (or (> (mark-position mark) %pos)
(and (= (mark-position mark) %pos)
(mark-left-inserting? mark)))
(set-mark-position! mark (+ (mark-position mark) %offset)))))
(%receiver2
(lambda (mark cursor?)
(cond ((> (mark-position mark) %pos)
((if cursor? %set-mark-line! set-mark-line!) mark %end-line)
(set-mark-position! mark (+ (mark-position mark) %offset)))
((and (= (mark-position mark) %pos)
(mark-left-inserting? mark))
((if cursor? %set-mark-line! set-mark-line!) mark %end-line)
(set-mark-position! mark %end-pos))))))
(lambda (line pos start-line start-pos end-line end-pos)
(set! %pos pos)
(if (eq? start-line end-line)
(let ((offset (- end-pos start-pos)))
(set! %offset offset)
(for-each-mark! line %receiver1)
(line-insert! line pos start-line start-pos end-pos)
(%make-region (%make-mark line pos #!FALSE)
(%make-mark line (+ pos offset) #!TRUE)))
(let ((offset (- end-pos pos)))
(set! %end-line end-line)
(set! %offset offset)
(set! %end-pos end-pos)
(for-each-mark! line %receiver2)
(line-splice! line pos start-line start-pos end-line end-pos)
(set! %end-line '())
(connect-lines! end-line (line-next line))
(connect-lines! line (line-next start-line))
(number-lines! (line-next line) end-line)
(%make-region (%make-mark line pos #!FALSE)
(%make-mark end-line end-pos #!TRUE)))))))
;;; These are overwritten by the routines in insertch.scm
;;;(define (region-insert-char! mark char)
;;; (if (char= char #\Newline)
;;; (region-insert-newline! mark)
;;; (let ((sync (region-insert-starting! mark)))
;;; (let ((region (mark-components mark
;;; (lambda (line pos)
;;; (%region-insert-char! line pos char)))))
;;; (sync region)
;;; region))))
;;;
;;;(define (%region-insert-char! line pos char)
;;; (for-each-mark! line
;;; (lambda (mark)
;;; (if (or (> (mark-position mark) pos)
;;; (and (= (mark-position mark) pos)
;;; (mark-left-inserting? mark)))
;;; (set-mark-position! mark (1+ (mark-position mark))))))
;;; (line-insert-char! line pos char)
;;; (%make-region (%make-mark line pos #!FALSE)
;;; (%make-mark line (1+ pos) #!TRUE)))
;;;
(define (region-insert-newline! mark)
(let ((sync (region-insert-starting! mark)))
(let ((region
((lambda (line pos)
(%region-insert-newline! line pos))
(mark-line mark) (mark-position mark))))
(sync region)
region)))
(define %region-insert-newline!
(letrec
((%pos '())
(%new-next '())
(%receiver
(lambda (mark cursor?)
(cond ((> (mark-position mark) %pos)
((if cursor? %set-mark-line! set-mark-line!) mark %new-next)
(set-mark-position! mark (- (mark-position mark) %pos)))
((and (= (mark-position mark) %pos)
(mark-left-inserting? mark))
((if cursor? %set-mark-line! set-mark-line!) mark %new-next)
(set-mark-position! mark 0))))))
(lambda (line pos)
(let ((new-next (subline-extract! line pos (line-length line))))
(set! %pos pos)
(set! %new-next new-next)
(for-each-mark! line %receiver)
(set! %new-next '())
(connect-lines! new-next (line-next line))
(connect-lines! line new-next)
(number-lines! new-next new-next)
(%make-region (%make-mark line (line-length line) #!FALSE)
(%make-mark new-next 0 #!TRUE))))))
;;; This should be implemented later for speed.
(define region-delete!
region-extract!)
(define (region-insert mark region)
(region-insert! mark (region-copy region)))
(define (region-insert-string! mark string)
(region-insert! mark (string->region string)))
;;;; Line String Operations
(define (subline line start end)
(make-line (substring (line-string line) start end)))
(define (line-copy line)
(make-line (line-string line)))
(define (subline-extract! line start end)
(let ((new-line (subline line start end)))
(set-line-string! line (string-delete (line-string line) start end))
new-line))
(define (line-extract! start-line start-pos end-line end-pos)
(let ((start-string (line-string start-line))
(end-string (line-string end-line)))
(let ((AD (substring-append start-string 0 start-pos
end-string end-pos (string-length end-string)))
(B (substring start-string start-pos (string-length start-string)))
(C (substring end-string 0 end-pos)))
(set-line-string! start-line B)
(set-line-string! end-line C)
(make-line AD))))
(define (line-insert! line1 start1 line2 start2 end2)
(set-line-string!
line1
(string-insert-substring (line-string line1) start1
(line-string line2) start2 end2)))
(define (line-insert-char! line start char)
(set-line-string!
line
(let ((string (line-string line)))
(%string-append string 0 start
char
string start (string-length string)))))
(define (line-splice! line1 position1 line2 position2 line3 position3)
(let ((string1 (line-string line1))
(string2 (line-string line2))
(string3 (line-string line3)))
(set-line-string! line1
(substring-append string1 0 position1
string2
position2
(string-length string2)))
(set-line-string! line3
(substring-append string3 0 position3
string1
position1
(string-length string1)))))
(define (mark-left-char mark)
(cond ((group-start? mark)
(error "No left character" mark))
((line-start? mark)
#\Newline)
(else
(string-ref (line-string (mark-line mark))
(-1+ (mark-position mark))))))
(define (mark-right-char mark)
(cond ((group-end? mark)
(error "No right character" mark))
((line-end? mark)
#\Newline)
(else
(string-ref (line-string (mark-line mark))
(mark-position mark)))))

120
edwin/ring.scm Normal file
View File

@ -0,0 +1,120 @@
;;;
;;; 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 make-ring)
(define ring-size)
(define ring-clear!)
(define ring-empty?)
(define ring-push!)
(define ring-pop!)
(define ring-stack-pop!)
(define ring-ref)
(define ring-set!)
(let ()
(define (list-ref l i)
(cond ((null? l) (error "Index too large" 'LIST-REF))
((zero? i) (car l))
(else (list-ref (cdr l) (-1+ i)))))
(define (list-set! l i o)
(define (loop l i)
(cond ((null? l) (error "Index too large" 'LIST-SET!))
((zero? i) (set-car! l o))
(else (list-ref (cdr l) (-1+ i)))))
(loop l i))
(define (list-truncate! l i)
(cond ((null? l) 'DONE)
((= i 1) (set-cdr! l '()))
(else (list-truncate! (cdr l) (-1+ i)))))
(set! make-ring
(named-lambda (make-ring size)
(if (< size 1)
(error "Ring size too small" size)
(let ((vec (make-vector 3)))
(vector-set! vec 0 "Ring")
(vector-set! vec 1 size)))))
(set! ring-size
(named-lambda (ring-size ring)
(length (vector-ref ring 2))))
(set! ring-clear!
(named-lambda (ring-clear! ring)
(vector-set! ring 2 '())))
(set! ring-empty?
(named-lambda (ring-empty? ring)
(null? (vector-ref ring 2))))
(set! ring-push!
(named-lambda (ring-push! ring object)
(vector-set! ring 2 (cons object (vector-ref ring 2)))
(list-truncate! (vector-ref ring 2) (vector-ref ring 1))))
(set! ring-pop!
(named-lambda (ring-pop! ring)
(let ((l (vector-ref ring 2)))
(if (null? l)
(error "Ring empty" ring)
(let ((object (car l)))
(vector-set! ring 2 (append! (cdr l) (list object)))
object)))))
(set! ring-stack-pop!
(named-lambda (ring-stack-pop! ring n)
(let ((l (vector-ref ring 2)))
(if (> n (length l))
(error "Ring does not have enteries" ring)
(vector-set! ring 2 (list-tail l n))))))
(set! ring-ref
(named-lambda (ring-ref ring index)
(list-ref (vector-ref ring 2) index)))
(set! ring-set!
(named-lambda (ring-set! ring index object)
(list-set! (vector-ref ring 2) index object)))
)


278
edwin/search1.scm Normal file
View File

@ -0,0 +1,278 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Searches
;;; **** For the time being all search and match operations are case
;;; insensitive. This needs to be fixed later. Also, the code has
;;; been bummed to know that strings are implemented as vectors of
;;; ASCII, and that char-sets are implemented as vectors of numbers.
;;;; Character Search
(define (make-find-next-char substring-find-next-char)
(lambda (start end char)
(let ((start-line (mark-line start))
(end-line (mark-line end)))
(define (loop line)
(if (eq? line end-line)
(let ((index
(substring-find-next-char (line-string line)
0
(mark-position end)
char)))
(and index (make-mark line index)))
(or (let ((index
(substring-find-next-char (line-string line)
0
(line-length line)
char)))
(and index (make-mark line index)))
(loop (line-next line)))))
(cond ((char=? #\newline char)
(and (not (eq? start-line end-line))
(make-mark start-line (line-length start-line))))
((eq? start-line end-line)
(let ((index
(substring-find-next-char (line-string start-line)
(mark-position start)
(mark-position end)
char)))
(and index (make-mark start-line index))))
(else
(or (let ((index
(substring-find-next-char (line-string start-line)
(mark-position start)
(line-length start-line)
char)))
(and index (make-mark start-line index)))
(loop (line-next start-line))))))))
(define find-next-char
(make-find-next-char substring-find-next-char-ci))
(define (find-next-newline start end)
(and (not (eq? (mark-line start) (mark-line end)))
(make-mark (mark-line start) (line-length (mark-line start)))))
(define (make-find-previous-char substring-find-previous-char)
(lambda (start end char)
;; Here START must come after END in the mark ordering.
;; The search begins at START and proceeds back until END.
(let ((start-line (mark-line start))
(end-line (mark-line end)))
(define (loop line)
(if (eq? line end-line)
(let ((index
(substring-find-previous-char (line-string line)
(mark-position end)
(line-length line)
char)))
(and index (make-mark line (1+ index))))
(let ((index
(substring-find-previous-char (line-string line)
0
(line-length line)
char)))
(if index
(make-mark line (1+ index))
(loop (line-previous line))))))
(cond ((char=? #\newline char))
((eq? start-line end-line)
(let ((index
(substring-find-previous-char (line-string start-line)
(mark-position end)
(mark-position start)
char)))
(and index (make-mark start-line (1+ index)))))
(else
(let ((index
(substring-find-previous-char (line-string start-line)
0
(mark-position start)
char)))
(if index
(make-mark start-line (1+ index))
(loop (line-previous start-line)))))))))
(define find-previous-char
(make-find-previous-char substring-find-previous-char-ci))
(define (find-previous-newline start end)
(and (not (eq? (mark-line start) (mark-line end)))
(make-mark (mark-line start) 0)))
;;;; Character-set Search
(define ((char-set-forward-search char-set) start end limit?)
(or (find-next-char-in-set start end char-set)
(limit-mark-motion limit? end)))
(define ((char-set-backward-search char-set) start end limit?)
(or (find-previous-char-in-set start end char-set)
(limit-mark-motion limit? end)))
(define (find-next-char-in-set start end char-set)
(let ((line (mark-line start))
(position (mark-position start))
(end-line (mark-line end))
(char-set-length (string-length char-set)))
(define (loop line)
(if (eq? line end-line)
(let ((index
(substring-find-next-char-in-set (line-string line)
0
(mark-position end)
char-set)))
(and index (make-mark line index)))
(or (let ((index
(substring-find-next-char-in-set (line-string line)
0
(line-length line)
char-set)))
(and index (make-mark line index)))
(loop (line-next line)))))
(if (eq? line end-line)
(let ((index
(substring-find-next-char-in-set (line-string line)
position
(mark-position end)
char-set)))
(and index (make-mark line index)))
(or (let ((index
(substring-find-next-char-in-set (line-string line)
position
(line-length line)
char-set)))
(and index (make-mark line index)))
;;; (if (char-set-member? char-set #\Newline)
(if (substring-find-next-char-in-set char-set 0 char-set-length
#\newline)
(make-mark line (line-length line))
(loop (line-next line)))))))
(define (find-previous-char-in-set start end char-set)
;; Here START must come after END in the mark ordering.
;; The search begins at START and proceeds back until END.
(let ((line (mark-line start))
(position (mark-position start))
(end-line (mark-line end))
(char-set-length (string-length char-set)))
(define (loop line)
(if (eq? line end-line)
(let ((index
(substring-find-previous-char-in-set (line-string line)
(mark-position end)
(line-length line)
char-set)))
(and index (make-mark line (1+ index))))
(or (let ((index
(substring-find-previous-char-in-set (line-string line)
0
(line-length line)
char-set)))
(and index (make-mark line (1+ index))))
(loop (line-previous line)))))
(if (eq? line end-line)
(let ((index
(substring-find-previous-char-in-set (line-string line)
(mark-position end)
position
char-set)))
(and index (make-mark line (1+ index))))
(or (let ((index
(substring-find-previous-char-in-set (line-string line)
0
position
char-set)))
(and index (make-mark line (1+ index))))
;;; (if (char-set-member? char-set #\Newline)
(if (substring-find-next-char-in-set char-set 0 char-set-length
#\newline)
(make-mark line 0)
(loop (line-previous line)))))))
;;;; String Search
(define (find-next-string start-mark end-mark string)
(find-next-substring start-mark end-mark
string 0 (string-length string)))
(define (find-next-substring start-mark end-mark
string start end)
(if (= start end)
start-mark
(let ((start-bound (mark- end-mark (-1+ (- end start)) #!false)))
(define (find-first mark)
(let ((first-char (find-next-char mark start-bound
(string-ref string start))))
(and first-char
(if (match-next-substring first-char end-mark
string start end)
first-char
(find-first (mark1+ first-char #!false))))))
(and start-bound
(mark< start-mark start-bound)
(find-first start-mark)))))
(define (find-previous-string start-mark end-mark string)
(find-previous-substring start-mark end-mark
string 0 (string-length string)))
(define (find-previous-substring start-mark end-mark
string start end)
(if (= start end)
start-mark
(let ((start-bound (mark+ end-mark (-1+ (- end start)) #!false)))
(define (find-first mark)
(let ((first-char
(find-previous-char mark start-bound
(string-ref string (-1+ end)))))
(and first-char
(if (match-previous-substring first-char end-mark
string start end)
first-char
(find-first (mark-1+ first-char #!false))))))
(and start-bound
(mark> start-mark start-bound)
(find-first start-mark)))))


220
edwin/search2.scm Normal file
View File

@ -0,0 +1,220 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; String Match
(define (match-next-strings start end strings)
(define (loop strings)
(and (not (null? strings))
(or (match-next-string start end (car strings))
(loop (cdr strings)))))
(loop strings))
(define (match-next-string start end string)
(match-next-substring start end string 0 (string-length string)))
(define (substring-next-newlines string start end)
(define (loop start)
(let ((newline (substring-find-next-char string start end #\newline)))
(if (not newline)
(list (- end start))
(cons newline (loop (1+ newline))))))
(loop start))
(define (match-previous-strings start end strings)
(define (loop strings)
(and (not (null? strings))
(or (match-previous-string start end (car strings))
(loop (cdr strings)))))
(loop strings))
(define (match-previous-string start end string)
(match-previous-substring start end string 0 (string-length string)))
(define (substring-previous-newlines string start end)
(define (loop end)
(let ((newline
(substring-find-previous-char string start end #\newline)))
(if (not newline)
(list (- end start))
(cons (1+ newline) (loop newline)))))
(loop end))
(define (match-next-substring start-mark end-mark string start end)
(let ((newlines (substring-next-newlines string start end))
(start-line (mark-line start-mark))
(start-position (mark-position start-mark))
(end-line (mark-line end-mark))
(end-position (mark-position end-mark)))
(define (match-rest line start newlines)
(cond ((eq? line end-line)
(and (null? (cdr newlines))
(<= (car newlines) end-position)
(substring-equal-ci? string start end
(line-string line) 0
(car newlines))
(make-mark line (car newlines))))
((null? (cdr newlines))
(and (<= (car newlines) (line-length line))
(substring-equal-ci? string start end
(line-string line) 0
(car newlines))
(make-mark line (car newlines))))
(else
(and (substring-equal-ci? string start (car newlines)
(line-string line) 0
(line-length line))
(match-rest (line-next line)
(1+ (car newlines))
(cdr newlines))))))
(cond ((eq? start-line end-line)
(and (null? (cdr newlines))
(let ((end-position* (+ start-position (car newlines))))
(and (<= end-position* end-position)
(substring-equal-ci? string start end
(line-string start-line)
start-position
end-position*)
(make-mark start-line end-position*)))))
((null? (cdr newlines))
(let ((end-position* (+ start-position (car newlines))))
(and (<= end-position* (line-length start-line))
(substring-equal-ci? string start end
(line-string start-line)
start-position
end-position*)
(make-mark start-line end-position*))))
(else
(and (substring-equal-ci? string start (car newlines)
(line-string start-line)
start-position
(line-length start-line))
(match-rest (line-next start-line)
(1+ (car newlines))
(cdr newlines)))))))
(define (match-previous-substring start-mark end-mark string start end)
;; Here START-MARK must come after END-MARK in the mark ordering.
;; The match begins at START-MARK and proceeds back until END-MARK.
(let ((newlines (substring-previous-newlines string start end))
(start-line (mark-line start-mark))
(start-position (mark-position start-mark))
(end-line (mark-line end-mark))
(end-position (mark-position end-mark)))
(define (match-rest line end newlines)
(cond ((eq? line end-line)
(and (null? (cdr newlines))
(<= end-position (car newlines))
(substring-equal-ci? string start end
(line-string line) (car newlines)
(line-length line))
(make-mark line (car newlines))))
((null? (cdr newlines))
(and (<= 0 (car newlines))
(substring-equal-ci? string start end
(line-string line) (car newlines)
(line-length line))
(make-mark line (car newlines))))
(else
(and (substring-equal-ci? string (car newlines) end
(line-string line) 0
(line-length line))
(match-rest (line-next line)
(-1+ (car newlines))
(cdr newlines))))))
(cond ((eq? start-line end-line)
(and (null? (cdr newlines))
(let ((end-position* (- start-position (car newlines))))
(and (<= end-position end-position*)
(substring-equal-ci? string start end
(line-string start-line)
end-position* start-position)
(make-mark start-line end-position*)))))
((null? (cdr newlines))
(let ((end-position* (- start-position (car newlines))))
(and (<= 0 end-position*)
(substring-equal-ci? string start end
(line-string start-line)
end-position* start-position)
(make-mark start-line end-position*))))
(else
(and (substring-equal-ci? string (car newlines) end
(line-string start-line) 0
start-position)
(match-rest (line-next start-line)
(-1+ (car newlines))
(cdr newlines)))))))
;;;; Character Match
(define (match-next-char start end char)
(and (mark< start end)
(let ((line (mark-line start))
(position (mark-position start)))
(if (= position (line-length line))
(and (char=? char #\newline)
(make-mark (line-next line) 0))
(and (char=? char (string-ref (line-string line) position))
(make-mark line (1+ position)))))))
(define (match-previous-char start end char)
(and (mark> start end)
(let ((line (mark-line start))
(position (-1+ (mark-position start))))
(if (negative? position)
(and (char=? char #\newline)
(make-mark (line-previous line)
(line-length (line-previous line))))
(and (char=? char (string-ref (line-string line) position))
(make-mark line position))))))
(define (match-next-char-in-set start end char-set)
(and (mark< start end)
(char-set-member? char-set (mark-right-char start))
(mark1+ start #!false)))
(define (match-previous-char-in-set start end char-set)
(and (mark> start end)
(char-set-member? char-set (mark-left-char start))
(mark-1+ start #!false)))

276
edwin/sentence.scm Normal file
View File

@ -0,0 +1,276 @@
;;;
;;; Copyright (c) 1984 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.
;;;
;;;; Sentences
(define char-set:sentence-terminators
(make-char-set #\. #\? #\!))
(define find-next-sentence-terminator
(char-set-forward-search char-set:sentence-terminators))
(define find-previous-sentence-terminator
(char-set-backward-search char-set:sentence-terminators))
(define char-set:not-closing-chars
(char-set-invert (make-char-set #\" #\' #\) #\])))
(define skip-next-closing-chars
(char-set-forward-search char-set:not-closing-chars))
(define skip-next-whitespace
(char-set-forward-search char-set:not-whitespace))
(define (forward-sentence mark n limit?)
(cond ((positive? n) (%forward-sentence mark n limit?))
((negative? n) (%backward-sentence mark (- n) limit?))
(else mark)))
(define (%forward-sentence mark n limit?)
(define (loop mark n)
(let ((sent-end (forward-one-sentence mark)))
(cond ((not sent-end) (limit-mark-motion limit? mark))
((= n 1) sent-end)
(else (loop sent-end (-1+ n))))))
(loop mark n))
(define (forward-one-sentence mark)
(define (loop mark)
(let ((this-line-end (line-end mark 0 #!false)))
(or (find-next-sentence-delimiter mark this-line-end)
(let ((next-line-start (line-start mark 1 #!false)))
(if (or (not next-line-start)
(paragraph-terminator? next-line-start))
(horizontal-space-start this-line-end)
(loop next-line-start))))))
(cond ((paragraph-delimiter? (line-start mark 0 #!false))
(let ((para-start (skip-next-paragraph-delimiters mark)))
(and para-start (loop para-start))))
((line-end? (horizontal-space-end mark))
(let ((next-line-start (line-start mark 1 #!false)))
(and next-line-start
(forward-one-sentence next-line-start))))
(else (loop mark))))
(define (backward-sentence mark n limit?)
(if (unassigned? limit?) (set! limit? #!FALSE))
(cond ((positive? n) (%backward-sentence mark n limit?))
((negative? n) (%forward-sentence mark (- n) limit?))
(else mark)))
(define (%backward-sentence mark n limit?)
(define (loop mark n)
(let ((sent-start (backward-one-sentence mark)))
(cond ((not sent-start) (limit-mark-motion limit? mark))
((= n 1) sent-start)
(else (loop sent-start (-1+ n))))))
(loop mark n))
(define (backward-one-sentence mark)
(define (find start)
(define (loop mark)
(let ((this-line-start (line-start mark 0 #!false)))
(or (find-previous-sentence-delimiter mark start this-line-start)
(if (paragraph-indentation? this-line-start)
(horizontal-space-end this-line-start)
(let ((previous-line-end (line-end mark -1 #!false)))
(if (or (not previous-line-end)
(paragraph-delimiter? previous-line-end))
this-line-start
(loop previous-line-end)))))))
(loop start))
(cond ((paragraph-delimiter? (line-start mark 0 #!false))
(let ((para-end (skip-previous-paragraph-delimiters mark)))
(and para-end
(find (mark-1+ (horizontal-space-start
(line-end para-end 0 #!false)) #!false)))))
((line-start? (horizontal-space-start mark))
(let ((previous-line-end (line-end mark -1 #!false)))
(and previous-line-end
(backward-one-sentence previous-line-end))))
(else (find mark))))
(define (find-next-sentence-delimiter start end)
(define (loop mark)
(let ((sent-term (find-next-sentence-terminator mark end #!FALSE)))
(and sent-term
(let ((sent-end (skip-next-closing-chars (mark1+ sent-term #!false)
end
'LIMIT)))
(if (sentence-end? sent-end)
sent-end
(loop sent-end))))))
(loop start))
(define (find-previous-sentence-delimiter mark start end)
(define (loop mark)
(let ((sent-term (find-previous-sentence-terminator mark end #!FALSE)))
(and sent-term
(let ((sent-end (skip-next-closing-chars sent-term start #!FALSE)))
(or (and sent-end
(sentence-end? sent-end)
(skip-next-whitespace sent-end start #!false))
(loop (mark-1+ sent-term #!false)))))))
(loop mark))
(define (sentence-end? sent-end)
(or (line-end? sent-end)
(and (char= #\Space (mark-right-char sent-end))
(let ((x (mark1+ sent-end #!false)))
(or (line-end? x)
(char= #\Space (mark-right-char x)))))))
;;; Pages
;;;; Paragraphs
(define paragraph-delimiters
(make-char-set #\.))
(define text-justifier-escape-chars
(make-char-set #\. #\' #\- #\\ #\@))
(define (page-mark-next? mark)
(match-next-strings mark (mark-end mark) page-delimiters))
(define (forward-paragraph mark n limit?)
(cond ((positive? n) (%forward-paragraph mark n limit?))
((negative? n) (%backward-paragraph mark (- n) limit?))
(else mark)))
(define (%forward-paragraph mark n limit?)
(define (loop mark n)
(let ((para-end (forward-one-paragraph mark)))
(cond ((not para-end) (limit-mark-motion limit? mark))
((= n 1) para-end)
(else (loop para-end (-1+ n))))))
(loop mark n))
(define (forward-one-paragraph mark)
(conjunction (not (group-end? mark))
(if (paragraph-delimiter? (line-start mark 0 #!false))
(let ((para-start (skip-next-paragraph-delimiters mark)))
(conjunction para-start
(skip-next-paragraph-body para-start)))
(skip-next-paragraph-body mark))))
(define (skip-next-paragraph-delimiters mark)
(let ((this-line-start (line-start mark 1 #!false)))
(conjunction this-line-start
(if (paragraph-delimiter? this-line-start)
(skip-next-paragraph-delimiters this-line-start)
this-line-start))))
(define (skip-next-paragraph-body mark)
(let ((this-line-start (line-start mark 1 #!false)))
(cond ((not this-line-start) (line-end mark 0 #!false))
((paragraph-terminator? this-line-start) this-line-start)
(else (skip-next-paragraph-body this-line-start)))))
(define (backward-paragraph mark n limit?)
(cond ((positive? n) (%backward-paragraph mark n limit?))
((negative? n) (%forward-paragraph mark (- n) limit?))
(else mark)))
(define (%backward-paragraph mark n limit?)
(define (loop mark n)
(let ((para-start (backward-one-paragraph mark)))
(cond ((not para-start) (limit-mark-motion limit? mark))
((= n 1) para-start)
(else (loop para-start (-1+ n))))))
(loop mark n))
(define (backward-one-paragraph mark)
(conjunction
(not (group-start? mark))
(cond ((conjunction (line-start? mark)
(paragraph-indentation? mark))
(let ((previous-line-start (mark-1+ mark #!false)))
(conjunction previous-line-start
(backward-one-paragraph previous-line-start))))
((paragraph-delimiter? (line-start mark 0 #!false))
(let ((para-end (skip-previous-paragraph-delimiters mark)))
(conjunction para-end
(skip-previous-paragraph-body para-end))))
(else
(skip-previous-paragraph-body (line-start mark 0 #!false))))))
(define (skip-previous-paragraph-delimiters mark)
(let ((this-line-start (line-start mark -1 #!false)))
(conjunction this-line-start
(if (paragraph-delimiter? this-line-start)
(skip-previous-paragraph-delimiters this-line-start)
this-line-start))))
(define (skip-previous-paragraph-body this-line-start)
(cond ((paragraph-indentation? this-line-start)
(let ((previous-line-start (line-start this-line-start -1 #!false)))
(if (conjunction previous-line-start
(paragraph-delimiter? previous-line-start))
previous-line-start
this-line-start)))
((paragraph-delimiter? this-line-start) this-line-start)
(else
(let ((previous-line-start (line-start this-line-start -1 #!false)))
(if (not previous-line-start)
this-line-start
(skip-previous-paragraph-body previous-line-start))))))
(define (paragraph-delimiter? this-line-start)
(disjunction
(line-blank? this-line-start)
(if (not *current-mode-scheme?*)
(conjunction
(not (group-end? this-line-start))
(let ((char (mark-right-char this-line-start)))
(char-set-member? text-justifier-escape-chars char)))
#!false)))
(define (paragraph-indentation? this-line-start)
(and (not *current-mode-scheme?*)
(not (line-blank? this-line-start))
(char-blank? (mark-right-char this-line-start))))
(define (paragraph-terminator? this-line-start)
(disjunction (paragraph-delimiter? this-line-start)
(paragraph-indentation? this-line-start)))

139
edwin/strcomp.scm Normal file
View File

@ -0,0 +1,139 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 4:01pm Tuesday, 25 June 1985
(begin
(define-integrable char-equal-ci? char-ci=?)
(define-integrable char-equal? char=?)
(define-integrable char-less-ci? char-ci<?)
(define-integrable char-less? char<?)
(define-integrable string-equal-ci? string-ci=?)
(define-integrable string-equal? string=?)
(define-integrable string-less-ci? string-ci<?)
(define-integrable string-less? string<?)
(define-integrable substring-equal-ci? substring-ci=?)
(define-integrable substring-equal? substring=?)
(define-integrable substring-less-ci? substring-ci<?)
(define-integrable substring-less? substring<?)
(define-integrable char= char=?)
(define-integrable char< char<?)
)
(define char-upper-case?
(lambda (c)
(char=? (char-upcase c) c)))
(define char-lower-case?
(lambda (c)
(char=? (char-downcase c) c)))
(macro string-allocate
(lambda (e)
(list 'make-string (cadr e) nil)))
;;;; Comparison Primitives
(define substring-match-forward)
(define substring-match-forward-ci)
(let ()
(define (make-substring-match-forward char-equal?)
(lambda (string1 start1 end1 string2 start2 end2)
(define (loop index1 index2 n)
(if (or (= index1 end1)
(= index2 end2)
(not (char-equal? (string-ref string1 index1)
(string-ref string2 index2))))
n
(loop (1+ index2) (1+ index2) (1+ n))))
(loop start1 start2 0)))
(set! substring-match-forward
(make-substring-match-forward char-equal?))
(set! substring-match-forward-ci
(make-substring-match-forward char-equal-ci?)))
(define string-match-forward)
(define string-match-forward-ci)
(let ()
(define (string-comparison substring-comparison)
(lambda (string1 string2)
(substring-comparison string1 0 (string-length string1)
string2 0 (string-length string2))))
(set! string-match-forward
(string-comparison substring-match-forward))
(set! string-match-forward-ci
(string-comparison substring-match-forward-ci)))
;;;; Character Search Primitives
(define substring-find-next-char-ci
(lambda (string start end char)
(let ((char1 (char-upcase char))
(char2 (char-downcase char)))
(let ((set (make-string 2 char1)))
(substring-find-next-char-in-set string start end
(string-set! set 1 char2))))))
(define substring-find-previous-char-ci
(lambda (string start end char)
(let ((char1 (char-upcase char))
(char2 (char-downcase char)))
(let ((set (make-string 2 char1)))
(substring-find-previous-char-in-set string start end
(string-set! set 1 char2))))))


437
edwin/struct.scm Normal file
View File

@ -0,0 +1,437 @@
;;;
;;; 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 %make-region
(lambda (start end)
(cons start end)))
(define-integrable region-start
(lambda (region)
(car region)))
(define-integrable region-end
(lambda (region)
(cdr region)))
(define-integrable region-group
(lambda (region)
(mark-group (region-start region))))
(define-integrable components->region
(lambda (start-line start-pos end-line end-pos)
(%make-region (mark-permanent! (%make-mark start-line start-pos #!FALSE))
(mark-permanent! (%make-mark end-line end-pos #!TRUE)))))
(define-integrable make-mark
(lambda (line position)
(%make-mark line position #!TRUE)))
(define-integrable %make-mark
(lambda (line position left-inserting?)
(let ((mark (make-vector 3)))
(vector-set! mark 0 line)
(vector-set! mark 1 position)
(vector-set! mark 2 left-inserting?)
mark)))
(define-integrable mark-line
(lambda (mark)
(vector-ref mark 0)))
(define-integrable %set-mark-line!
(lambda (mark line)
(vector-set! mark 0 line)))
(define-integrable mark-position
(lambda (mark)
(vector-ref mark 1)))
(define-integrable set-mark-position!
(lambda (mark position)
(vector-set! mark 1 position)))
(define-integrable mark-left-inserting?
(lambda (mark)
(vector-ref mark 2)))
(define-integrable mark-group
(lambda (mark)
(line-group (mark-line mark))))
(define-integrable line-tag 'line)
(define-integrable make-line
(lambda (string)
(let ((line (make-vector 8)))
(vector-set! line 3 line-tag)
(vector-set! line 1 string)
line)))
(define-integrable line-string
(lambda (line)
(vector-ref line 1)))
(define-integrable line-previous
(lambda (line)
(vector-ref line 2)))
(define-integrable line-next
(lambda (line)
(vector-ref line 0)))
(define-integrable line-marks
(lambda (line)
(vector-ref line 4)))
(define-integrable set-line-marks!
(lambda (line marks)
(vector-set! line 4 marks)))
(define-integrable line-group
(lambda (line)
(vector-ref line 5)))
(define-integrable set-line-group!
(lambda (line group)
(vector-set! line 5 group)))
(define-integrable line-number
(lambda (line)
(vector-ref line 6)))
(define-integrable set-line-number!
(lambda (line number)
(vector-set! line 6 number)))
(define-integrable line-alist
(lambda (line)
(vector-ref line 7)))
(define-integrable set-line-alist!
(lambda (line alist)
(vector-set! line 7 alist)))
)
;;;; Text Data Structures
;;; This file describes the data structures used to represent and
;;; manipulate text within the editor.
;;; The basic unit of text is the GROUP, which is essentially a type
;;; of character string with some special operations. Normally a
;;; group is modified by side effect; unlike character strings, groups
;;; will grow and shrink appropriately under such operations. Also,
;;; it is possible to have pointers into a group, called MARKs, which
;;; continue to point to the "same place" under these operations; this
;;; would not be true of a string, elements of which are pointed at by
;;; indices.
;;; As is stressed in the EMACS manual, marks point between characters
;;; rather than directly at them. This perhaps counter-intuitive
;;; concept may aid understanding.
;;; Besides acting as pointers into a group, marks may be compared.
;;; All of the marks within a group are totally ordered, and the
;;; standard order predicates are supplied for them. In addition,
;;; marks in different groups are unordered with respect to one
;;; another. The standard predicates have been extended to be false
;;; in this case, and another predicate, which indicates whether they
;;; are related, is supplied.
;;; Marks may be paired into units called REGIONs. Each region has a
;;; START mark and an END mark, and it must be the case that START is
;;; less than or equal to END in the mark ordering. While in one
;;; sense this pairing of marks is trivial, it can also be used to
;;; reduce overhead in the implementation since a region guarantees
;;; that its marks satisfy this very basic relation.
;;; As in most other editors of this type, there is a distinction
;;; between "temporary" and "permanent" marks. The purpose for this
;;; distinction is that temporary marks require less overhead to
;;; create. Conversely, temporary marks do not remain valid when
;;; their group is modified. They are intended for local use when it
;;; is known that the group will remain unchanged.
;;; The implementation of marks is different from previous
;;; implementations. In particular, it is not possible to tell
;;; whether a mark is temporary or permanent. Instead, a "caller
;;; saves"-like convention is used. Whenever any given mark needs to
;;; be permanent, one merely calls a procedure which "permanentizes"
;;; it. All marks are created temporary by default.
;;; Internally, groups are represented as an ordered set of objects,
;;; called LINEs, which are doubly linked to form a linear chain.
;;; Each line represents a string of characters without newlines, and
;;; two adjacent lines are separated by a "virtual newline". Thus
;;; this data structure directly corresponds to our intuitive concept
;;; of "line".
;;; In some sense the choice of lines are the unit of text is quite
;;; arbitrary; there are no real technical benefits to be gained from
;;; the choice. The decision to structure things this way was based
;;; on the fact that most current editors are built that way, and
;;; expediency demands that we not innovate too much.
;;; With that said, it is important to restate that lines are an
;;; INTERNAL data representation. Since the choice is arbitrary, they
;;; are not supported by any public operations.
;;;; Groups
;;; Every line belongs to a unique group, and every line belonging to
;;; the same group is related. That is, the lines in a group are
;;; totally ordered. Lines in different groups have no relation.
;;; There is no sharing of lines between groups. When lines are
;;; copied out of a group, they form a new group. When they are
;;; inserted into a group, they become part of that group.
(define make-group)
(let ()
(define group-tag 'group)
(set! make-group
(named-lambda (make-group region)
(let ((group (make-vector 6)))
(vector-set! group 2 group-tag)
(vector-set! group 1 region)
(vector-set! group 0 region)
(vector-set! group 5 #!FALSE)
group)))
)
(begin
(define-integrable group-index:total-region 1)
(define-integrable group-index:region 0)
(define-integrable group-index:delete-daemons 3)
(define-integrable group-index:insert-daemons 4)
(define-integrable group-index:read-only-flag 5)
(define-integrable group-region
(lambda (group)
(vector-ref group group-index:region)))
(define (%set-group-region! group region)
(vector-set! group group-index:total-region region)
(vector-set! group group-index:region region))
(define-integrable %group-start
(lambda (group)
(region-start (group-region group))))
(define-integrable %group-end
(lambda (group)
(region-end (group-region group))))
)
(define (group-read-only? group)
(vector-ref group group-index:read-only-flag))
(define (set-group-read-only! group)
(vector-set! group group-index:read-only-flag #!TRUE))
(define (set-group-writeable! group)
(vector-set! group group-index:read-only-flag #!FALSE))
;;;; Group Modification Daemons
(define (group-delete-daemons group)
(vector-ref group group-index:delete-daemons))
(define (add-group-delete-daemon! group daemon)
(vector-set! group group-index:delete-daemons
(cons daemon (vector-ref group group-index:delete-daemons))))
(define (region-delete-starting! region)
(if (group-read-only? (region-group region))
(editor-error "Trying to modify read only text."))
(region-modification-starting! (group-delete-daemons (region-group region))
region))
(define (group-insert-daemons group)
(vector-ref group group-index:insert-daemons))
(define (add-group-insert-daemon! group daemon)
(vector-set! group group-index:insert-daemons
(cons daemon (vector-ref group group-index:insert-daemons))))
(define (region-insert-starting! mark)
(if (group-read-only? (mark-group mark))
(editor-error "Trying to modified read only text."))
(region-modification-starting! (group-insert-daemons (mark-group mark))
mark))
(define (region-modification-starting! all-daemons argument)
(define (loop daemons)
(if (null? daemons)
'()
(let ((sync ((car daemons) argument)))
(if sync
(cons sync (loop (cdr daemons)))
(loop (cdr daemons))))))
(sync-daemons (loop all-daemons)))
(define ((sync-daemons daemons) region)
(define (loop daemons)
(if (not (null? daemons))
(begin ((car daemons) region)
(loop (cdr daemons)))))
(loop daemons))
;;;; Regions
(define (make-region start end)
(cond ((mark<= start end) (%make-region start end))
((mark<= end start) (%make-region end start))
(else (error "Marks not related" start end))))
(define (lines->region start-line end-line)
(let ((region (components->region start-line 0
end-line (line-length end-line))))
(set-line-group! start-line (make-group region))
(number-lines! start-line end-line)
region))
(define (region-components region receiver)
(receiver (mark-line (region-start region))
(mark-position (region-start region))
(mark-line (region-end region))
(mark-position (region-end region))))
;;;; Marks
(define (mark-components mark receiver)
(receiver (mark-line mark)
(mark-position mark)))
(define (mark-right-inserting mark)
(mark-permanent!
(if (mark-left-inserting? mark)
(%make-mark (mark-line mark) (mark-position mark) #!FALSE)
mark)))
(define (mark-left-inserting mark)
(mark-permanent!
(if (mark-left-inserting? mark)
mark
(%make-mark (mark-line mark) (mark-position mark) #!TRUE))))
;;;; Lines
;;; Instead of using VECTOR, MAKE-LINE is coded in a strange way to
;;; make it maximally fast. Both LIST->VECTOR and CONS are
;;; primitives. Also, VECTOR would cons a list, then vectorize it,
;;; creating a bunch of garbage, while this only makes one cons.
(define (set-line-string! line string)
(vector-set! line 1 string)
(set-line-alist! line '()))
(define (connect-lines! previous next)
(if (not (null? previous)) (vector-set! previous 0 next))
(if (not (null? next)) (vector-set! next 2 previous)))
(define (disconnect-lines! start end)
(vector-set! start 2 '())
(vector-set! end 0 '()))
;;; line-length clashes with a scheme-primitive. we have defined
;;; a macro line-length which will replace all occurrences of line-length
;;; to line-string-length. Maybe, we will change it all ove the source
;;; someday. The macro will be present only while compiling Edwin
;;; sources.
;;; (define-integrable (line-length line)
;;; (string-length (line-string line)))
;;;; Line Numbering
(define line-number-increment 256)
(define (number-lines! start-line end-line)
(define (number-upward group base increment)
(define (loop line number)
(set-line-group! line group)
(set-line-number! line number)
(if (not (eq? line end-line))
(loop (line-next line) (+ number increment))))
(loop start-line (+ base increment)))
(define (number-downward group base increment)
(define (loop line number)
(set-line-group! line group)
(set-line-number! line number)
(if (not (eq? line start-line))
(loop (line-previous line) (- number increment))))
(loop end-line (- base increment)))
(define (count-lines)
(define (loop line n)
(if (eq? line end-line)
n
(loop (line-next line) (1+ n))))
(loop start-line 1))
(let ((lower-limit (line-previous start-line))
(upper-limit (line-next end-line)))
(if (null? lower-limit)
(if (null? upper-limit)
;; Numbering entire group. The first line
;; had better be initialized correctly.
(number-upward (line-group start-line)
0
line-number-increment)
(number-downward (line-group upper-limit)
(line-number upper-limit)
line-number-increment))
(if (null? upper-limit)
(number-upward (line-group lower-limit)
(line-number lower-limit)
line-number-increment)
(number-upward (line-group lower-limit)
(line-number lower-limit)
(/ (- (line-number upper-limit)
(line-number lower-limit))
(1+ (count-lines))))))))

230
edwin/things.scm Normal file
View File

@ -0,0 +1,230 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Textual Entities
;;;; Motion Primitives
;;; This file "defines" various kinds of things like lines, pages,
;;; words, etc. The "definition" of a FOO entity consists of two
;;; procedures, FORWARD-FOO and BACKWARD-FOO, each of which takes
;;; three arguments: [1] a mark to start from, [2] the number of FOOs
;;; to traverse, and [3] a limit for LIMIT-MARK-MOTION. The value of
;;; the procedure should be either a mark or #!FALSE.
;;; If the number is positive, traverse that many FOOs in the given
;;; direction; if negative, in the opposite direction; and zero means
;;; don't move. It is assumed that no two FOOs overlap; they may or
;;; may not touch one another. When moving forward, stop to the right
;;; of the rightmost edge of the FOO. When moving backward, stop to
;;; the left of the leftmost edge.
;;; MAKE-MOTION-PAIR will generate these two procedures, given the
;;; simpler primitives to move forward or backward once.
(define (move-thing forward-thing argument)
(set-current-point! (forward-thing (current-point) argument 'BEEP)))
(define (make-motion-pair forward-one-thing backward-one-thing receiver)
(define (forward-thing mark n limit?)
(cond ((positive? n) (%forward-thing mark n limit?))
((negative? n) (%backward-thing mark (- n) limit?))
(else mark)))
(define (%forward-thing mark n limit?)
(define (loop mark n)
(let ((end (forward-one-thing mark (group-end mark))))
(cond ((not end) (limit-mark-motion limit? mark))
((= n 1) end)
(else (loop end (-1+ n))))))
(loop mark n))
(define (backward-thing mark n limit?)
(cond ((positive? n) (%backward-thing mark n limit?))
((negative? n) (%forward-thing mark (- n) limit?))
(else mark)))
(define (%backward-thing mark n limit?)
(define (loop mark n)
(let ((start (backward-one-thing mark (group-start mark))))
(cond ((not start) (limit-mark-motion limit? mark))
((= n 1) start)
(else (loop start (-1+ n))))))
(loop mark n))
(receiver forward-thing backward-thing))
;;;; Generic Operations
(define (move-thing-saving-point forward-thing argument)
(let ((mark (current-point)))
(push-current-mark! mark)
(set-current-point! (forward-thing mark argument 'BEEP))))
(define (mark-thing forward-thing n)
(push-current-mark! (forward-thing (current-point) n 'ERROR)))
(define (kill-thing forward-thing n)
(kill-region (forward-thing (current-point) n 'ERROR)))
;;;(define (transpose-things forward-thing n)
;;; (define (forward-once i)
;;; (let ((m4 (mark-right-inserting (forward-thing (current-point) 1 'ERROR))))
;;; (set-current-point! m4)
;;; (let ((m2 (mark-permanent! (forward-thing m4 -1 'ERROR))))
;;; (let ((m1 (mark-permanent! (forward-thing m2 -1 'ERROR))))
;;; (let ((m3 (forward-thing m1 1 'ERROR)))
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
;;; (region-insert! m1 (region-extract! (make-region m2 m4))))))))
;;;
;;; (define (backward-once i)
;;; (let ((m2 (mark-permanent! (forward-thing (current-point) -1 'ERROR))))
;;; (let ((m1 (mark-left-inserting (forward-thing m2 -1 'ERROR))))
;;; (let ((m3 (forward-thing m1 1 'ERROR))
;;; (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
;;; (region-insert! m1 (region-extract! (make-region m2 m4))))
;;; (set-current-point! m1))))
;;;
;;; (define (special)
;;; (let ((m1 (normalize (current-point)))
;;; (m2 (normalize (current-mark))))
;;; (cond ((mark< m1 m2)
;;; (exchange m1 m2
;;; (lambda (m1 m2)
;;; (set-current-point! m2)
;;; (set-current-mark! m1))))
;;; ((mark< m2 m1)
;;; (exchange m2 m1
;;; (lambda (m2 m1)
;;; (set-current-point! m2)
;;; (set-current-mark! m1)))))))
;;;
;;; (define (exchange m1 m2 receiver)
;;; (let ((m1 (mark-right-inserting m1))
;;; (m3 (forward-thing m1 1 'ERROR))
;;; (m2 (mark-permanent! m2))
;;; (m4 (mark-right-inserting (forward-thing m2 1 'ERROR))))
;;; (region-insert! m4 (region-extract! (make-region m1 m3)))
;;; (region-insert! m1 (region-extract! (make-region m2 m4)))
;;; (receiver m4 m1)))
;;;
;;; (define (normalize m)
;;; (forward-thing (forward-thing m 1 'ERROR) -1 'ERROR))
;;;
;;; (cond ((positive? n) (dotimes n forward-once))
;;; ((negative? n) (dotimes (- n) backward-once))
;;; (else (special))))
;;;; Horizontal Space
(define (region-blank? region)
(not (find-next-non-blank (region-start region)
(region-end region)
#!FALSE)))
(define (line-blank? mark)
(not (find-next-non-blank (line-start mark 0 #!false)
(line-end mark 0 #!false)
#!FALSE)))
(define (horizontal-space-region mark)
(make-region (horizontal-space-start mark)
(horizontal-space-end mark)))
(define (horizontal-space-start mark)
(find-previous-non-blank mark (line-start mark 0 #!false) 'LIMIT))
(define (horizontal-space-end mark)
(find-next-non-blank mark (line-end mark 0 #!false) 'LIMIT))
;(define (compute-horizontal-space c1 c2 receiver)
;;; ;; Compute the number of tabs/spaces required to fill from column C1
;;; ;; to C2 with whitespace. It is assumed that C1 >= C2.
;;; (if indent-tabs-mode
;;; (let ((qr (integer-divide c2 tab-width)))
;;; (receiver (- (integer-divide-quotient qr) (quotient c1 tab-width))
;;; (integer-divide-remainder qr)))
;;; (receiver (- c2 c1) 0)))
;;;
;;;(define (insert-horizontal-space target-column #!optional point)
;;; (set! point
;;; (if (unassigned? point) (current-point) (mark-left-inserting point)))
;;; (compute-horizontal-space (mark-column point) target-column
;;; (lambda (n-tabs n-spaces)
;;; (insert-chars #\Tab n-tabs point)
;;; (insert-chars #\Space n-spaces point))))
(define (delete-horizontal-space)
(let ((point (current-point)))
(region-delete! (horizontal-space-region point))))
(define find-next-non-blank (char-set-forward-search char-set:non-blanks))
(define find-previous-non-blank (char-set-backward-search char-set:non-blanks))
;;;; Lines
; I could not find any calls to the following functions, so I commented
; them out. Note, they must have the #!optional fixed before they are added
; back in
;;;(define (forward-line mark n #!optional limit?)
;;; (if (unassigned? limit?) (set! limit? #!FALSE))
;;; (cond ((positive? n) (%forward-line mark n limit?))
;;; ((negative? n) (%backward-line mark (- n) limit?))
;;; (else mark)))
;;;(define %forward-line
;;; line-start)
;;;(define (backward-line mark n #!optional limit?)
;;; (if (unassigned? limit?) (set! limit? #!FALSE))
;;; (cond ((positive? n) (%backward-line mark n limit?))
;;; ((negative? n) (%forward-line mark (- n) limit?))
;;; (else mark)))
;;;(define (%backward-line mark n limit?)
;;; (line-start mark
;;; (- (if (line-start? mark)
;;; n
;;; (-1+ n)))
;;; limit?))

227
edwin/toplevel.scm Normal file
View File

@ -0,0 +1,227 @@
;;;
;;; 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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; toplevel
(define edwin-editor)
(define *pcs-contents* '())
(define edwin
(letrec
((%edwin-reset
(lambda ()
(set! edwin-editor (make-editor "Edwin"))
(reset-display)
*the-non-printing-object*))
(reset-display
(lambda ()
(reset-buffer-window (current-buffer-window))
(reset-modeline-window)
(reset-typein-window))))
(lambda ()
(call/cc
(lambda (k)
(fluid-let ((editor-continuation k))
(save-console-contents)
(make-pcs-status-invisible)
(if (or (unassigned? edwin-editor)
(not edwin-editor))
(%edwin-reset)
(reset-display))
(top-level-command-reader)))))))
(define top-level-command-reader
(lambda ()
(letrec
((top-level-command-reader
(lambda ()
(catch
(lambda (k)
(fluid-let ((*error-continuation* k)
(*^G-continuation* k))
(command-reader))))
(top-level-command-reader)))
(command-reader
(lambda ()
(fluid-let ((*command-message* #!false))
(with-command-argument-reader
(lambda ()
(command-reader-loop))))))
(command-reader-loop
(lambda ()
(fluid-let ((*command-char* '())
(*command* '())
(*next-message* #!false))
(start-next-command)
(set-fluid! *command-message* (fluid *next-message*)))
(command-reader-loop )))
(start-next-command
(lambda ()
(reset-command-argument-reader!)
(reset-command-prompt!)
(read-and-dispatch-on-char))))
(top-level-command-reader))))
(define (throw continuation value)
(continuation value))
(define (abort-current-command)
(throw (error-continuation) 'abort))
(define (error-continuation)
(fluid *error-continuation*))
(define (editor-error . msg)
(beep)
(if msg (temporary-message (car msg)))
(abort-current-command))
(define (read-and-dispatch-on-char)
(dispatch-on-char (editor-read-char (window-screen (current-window)))))
(define ^G-char (integer->char 7))
(define editor-read-char
(lambda (screen)
(if (not (char-ready? screen))
(begin
(update-display! (current-window))
(update-modeline!)))
(if (not (eq? screen typein-screen))
(if (or (not (char-ready?))
(delay-input 50 screen))
(update-typein-window!)))
(let ((char (read-char screen)))
(cond ((eq? char ^G-char) (editor-error "Abort"))
((eof-object? char) ^Z-char)
(else char)))))
(define (dispatch-on-char char)
(set-fluid! *command-char* char)
(set-command-prompt!
(string-append-separated (command-argument-prompt)
(obj->string char)))
(dispatch-on-command (comtab-entry char) char))
(define (dispatch-on-command command char)
(set-fluid! *command* command)
(let ((procedure command)
(argument
(or (command-argument-value)
(and (command-argument-negative?) -1))))
(if (or argument)
;; The C-U for numeric arguments has already reset the paren cache,
;; so no need to do anything further about it here.
(procedure argument)
;; Reset the paren-cache on any non-insert or left-paren command.
;; Be careful we *don't* reset it on right-paren.
(cond ((eq? procedure ^r-insert-self-command)
(and (char=? #\( char) (cache-paren-mark '())) ;;;;;) 3.02
(let ((window (current-window))
(point (current-point)))
(if (and (buffer-modified? (window-buffer window))
(line-end? point)
(char-graphic? char)
(< (window-point-x window)
(-1+ (window-x-size window))))
(begin (%region-insert-char! (mark-line point)
(mark-position point)
char)
(direct-output-for-insert! window
char))
(region-insert-char! point char))))
((eq? procedure ^r-forward-character-command)
(cache-paren-mark '()) ;3.02
(let ((window (current-window))
(point (current-point)))
(if (and (not (group-end? point))
(char-graphic? (mark-right-char point))
(< (window-point-x window)
(- 2 (window-x-size window))))
;;; to take care of continuation lines
(direct-output-forward-character! window)
(procedure argument))))
((eq? procedure ^r-backward-character-command)
(cache-paren-mark '()) ;3.02
(let ((window (current-window))
(point (current-point)))
(if (and (not (group-start? point))
(char-graphic? (mark-left-char point))
;; Use 1 instead of 0 so we don't have
;; to worry about continuation lines.
(> (window-point-x window) 1))
(direct-output-backward-character! window)
(procedure argument))))
((eq? procedure ^r-lisp-insert-paren-command) ;3.02
(procedure argument)) ;3.02
(else
(cache-paren-mark '()) ;3.02
(procedure argument))))))
(define (current-command-char)
(fluid *command-char*))
(define (current-command)
(fluid *command*))
(define (set-command-message! tag . arguments)
(set-fluid! *next-message* (cons tag arguments)))
(define (command-message-receive tag if-received if-not-received)
(if (and (fluid *command-message*)
(eq? (car (fluid *command-message*)) tag))
(apply if-received (cdr (fluid *command-message*)))
(if-not-received)))
(define (beep)
(princ ^G-char typein-screen))


73
edwin/transpos.scm Normal file
View File

@ -0,0 +1,73 @@
;;;
;;; 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 (twiddle-characters m1 m2)
(let ((m* (mark-left-inserting m2)))
(region-insert! m* (region-extract! (make-region (mark-1+ m1 'ERROR) m1)))
(set-current-point! m*)))
(define (%edwin-transpose-characters argument)
(cond ((conjunction (= argument 1) (line-end? (current-point)))
(twiddle-characters (mark-1+ (current-point) 'ERROR)
(current-point)))
((positive? argument)
(twiddle-characters (current-point)
(mark+ (current-point) argument 'ERROR)))
((negative? argument)
(twiddle-characters (current-point)
(mark- (current-point) (1+ (- argument)) 'ERROR)))
(else
(let ((m1 (mark-right-inserting (current-point)))
(m2 (mark-right-inserting (current-mark))))
(let ((r1 (region-extract!
(make-region (current-point)
(mark1+ (current-point) 'ERROR))))
(r2 (region-extract!
(make-region (current-mark)
(mark1+ (current-mark) 'ERROR)))))
(region-insert! m1 r2)
(region-insert! m2 r1))
(set-current-point! m1)
(set-current-mark! m2)))))


96
edwin/words.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
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Words
(define (forward-word mark n limit?)
(cond ((positive? n) (%forward-word mark n limit?))
((negative? n) (%backward-word mark (- n) limit?))
(else mark)))
(define (%forward-word mark n limit?)
(let ((end (group-end mark)))
(define (loop mark n)
(let ((m (find-next-word-constituent mark end #!FALSE)))
(if (not m)
(limit-mark-motion limit? mark)
(let ((m (find-next-word-delimiter m end 'LIMIT)))
(if (= n 1)
m
(loop m (-1+ n)))))))
(loop mark n)))
(define (backward-word mark n limit?)
(cond ((positive? n) (%backward-word mark n limit?))
((negative? n) (%forward-word mark (- n) limit?))
(else mark)))
(define (%backward-word mark n limit?)
(let ((end (group-start mark)))
(define (loop mark n)
(let ((m (find-previous-word-constituent mark end #!FALSE)))
(if (not m)
(limit-mark-motion limit? mark)
(let ((m (find-previous-word-delimiter m end 'LIMIT)))
(if (= n 1)
m
(loop m (-1+ n)))))))
(loop mark n)))
(define (forward-to-word mark limit?)
(find-next-word-constituent mark (mark-end mark) limit?))
(define (find-next-word-constituent start end limit?)
(or (find-next-char-in-set start end word-constituent-chars)
(limit-mark-motion limit? end)))
(define (find-previous-word-constituent start end limit?)
(or (find-previous-char-in-set start end word-constituent-chars)
(limit-mark-motion limit? end)))
(define (find-next-word-delimiter start end limit?)
(or (find-next-char-in-set start end word-delimiter-chars)
(limit-mark-motion limit? end)))
(define (find-previous-word-delimiter start end limit?)
(or (find-previous-char-in-set start end word-delimiter-chars)
(limit-mark-motion limit? end)))


148
expand.scm Normal file
View File

@ -0,0 +1,148 @@
(define %sc-expand
(lambda (exp)
(letrec
;------!
(
(expand
(lambda (x env)
(cond ((atom? x)
(exp-atom x env))
((macro? (car x))
(exp-macro x env))
(else
(expand2 x env)))))
(exp-macro
(lambda (x env)
(let ((y (if (pair? macfun)
(cons (cdr macfun)(cdr x)) ; alias
(macfun x)))) ; macro
(if (or (atom? y)
(equal? x y))
(expand2 y env)
(expand y env)))))
(macfun '())
(macro?
(lambda (id)
(set! macfun
(and (symbol? id)
(or (getprop id 'pcs*macro))))
macfun))
(expand2
(lambda (x env)
(if (atom? x)
(exp-atom x env)
(case (car x)
((QUOTE) x)
((SET!) (exp-set! x env))
((DEFINE) (exp-define x env))
((LAMBDA) (exp-lambda x env))
((BEGIN IF) (exp-begin x env))
((LETREC) (exp-letrec x env))
(else (exp-application x env))
))))
(exp-atom
(lambda (x env)
(if (or (not (symbol? x))
(memq x env)
(memq x '(#!true #!false
#!unassigned ))
(getprop x 'pcs*macro)
(getprop x 'pcs*primop-handler))
x
(list '%%get-scoops%% (list 'quote x)))))
(exp-set!
(lambda (x env)
(pcs-chk-length= x x 3)
(let ((id (set!-id x))
(val (expand (set!-exp x) env)))
(if (or (not (symbol? id))
(memq id env)
(memq id '(#!true #!false
#!unassigned ))
(getprop id 'pcs*macro)
(getprop id 'pcs*primop-handler))
(list 'SET! id val)
(list '%%set-scoops%% (list 'QUOTE id) val)))))
(exp-define
(lambda (x env)
(pcs-chk-length= x x 3)
(let ((op (car x)) ; define!, define
(id (set!-id x))
(val (expand (set!-exp x) env)))
(list op id val))))
(exp-lambda
(lambda (x env)
(pcs-chk-length>= x x 3)
(let ((bvl (lambda-bvl x)))
(pcs-chk-bvl x bvl #!true)
(cons 'LAMBDA
(cons bvl
(exp-args (lambda-body-list x)
'()
(extend env bvl)))))))
(exp-begin
(lambda (x env)
(pcs-chk-length>= x x 1)
(cons (car x) ; begin, if
(exp-args (cdr x) '() env))))
(exp-letrec
(lambda (x env)
(pcs-chk-length>= x x 3)
(let ((pairs (letrec-pairs x)))
(pcs-chk-pairs x pairs)
(let ((newenv (extend env (mapcar car pairs))))
(cons 'LETREC
(cons (exp-pairs pairs '() newenv)
(exp-args (letrec-body-list x) '() newenv)))))))
(exp-pairs
(lambda (old new env)
(if (null? old)
(reverse! new)
(let ((id (caar old))
(exp (expand (cadar old) env)))
(exp-pairs (cdr old)
(cons (list id exp) new)
env)))))
(exp-application
(lambda (form env)
(pcs-chk-length>= form form 1)
(exp-args form '() env)))
(exp-args
(lambda (old new env)
(if (null? old)
(reverse! new)
(exp-args (cdr old)
(cons (expand (car old) env) new)
env))))
(extend
(lambda (env bvl)
(cond ((pair? bvl)
(extend (cons (car bvl) env) (cdr bvl)))
((null? bvl)
env)
(else
(cons bvl env)))))
;------!
)
(expand exp '()))))


631
frame.scm Normal file
View File

@ -0,0 +1,631 @@
(load "scoops.fsl")
(define extensions
(let ((blanks (make-string 4 #\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
("This tutorial will take you through defining your own instances"
"of SCOOPS classes and manipulating the instances. When the"
"tutorial is finished you will have an opportunity to try your"
"own hand at creating and manipulating SCOOPS classes. The"
"classes for this tutorial are POINT, LINE and RECTANGLE."
"Refer to chapter 5 in the Language Reference Manual for"
"additional information on SCOOPS."))
(frame
SCOOPS
("/SCOOPS is the /SCheme /Object /Oriented /Programming /System for PC Scheme,"
"similar to the LOOPS and FLAVORS systems available on various"
"makes of Lisp machines."
"Object oriented programming"
"involves the use of /objects as abstract data types. An object"
"is comprised of /variables, which determine the local state of"
"the object, and /methods which define the object's behavior.")
()
()
()
"Introduction to SCOOPS"
("SCOOPS" "object-oriented programming"
"object" "method"))
(frame
()
("In object oriented programming, all communication with an object"
"is through /messages. Objects use their own"
"procedures, called methods, to respond to the message and perform"
"some operation. A key to object oriented programming is that the"
"system performs many tasks that the programmer has to specify in"
"other types of programming styles.")
()
()
()
()
("message" "method"))
(frame
CLASS
("In our example the first thing that needs to be done with"
"SCOOPS is to define a /class. A class contains the description"
"of one or more similar objects. An object is an /instance of a class"
"with the same form as the class from which it was made, a copy. Scheme"
"uses the special form DEFINE-CLASS to create a class. For example:")
(:data (define-class point (instvars (x 0) (y 0))) :data-eval :pp-data)
("This defines a class named POINT. Each instance of the class"
"will contain two /instance /variables called X and Y and each is"
"initialized to zero.")
()
"Defining a Class"
("class" "DEFINE-CLASS" "instance variable" "instance"))
(frame
DEFINE-POINT-CLASS
("This is a simple definition and has the disadvantage that"
"when an instance is created it cannot be manipulated. No methods"
"have been included to interact with the class. A small"
"change to the definition is necessary to allow the variables"
"to be changed.")
(:data (define-class point (instvars (x 0) (y 0))
(options settable-variables)) :data-eval :pp-data)
("What this has done is to automatically define two methods for us,"
"SET-X and SET-Y. A /method is a type of function or procedure that"
"determines the behavior of a class. We will cover"
"methods a little later.")
()
()
("method" "options"))
(frame
DESCRIBE
("Now we can use the /DESCRIBE procedure. We can see that two"
"methods have already been defined, SET-X and SET-Y. The"
"DESCRIBE procedure can be used to describe either a class"
"or an instance. For example if we describe the class \"point\""
"with the command: (DESCRIBE POINT) the output will look like:")
(:output (DESCRIBE POINT))
()
()
"The DESCRIBE procedure"
("DESCRIBE"))
(frame
()
("This tells us several things:"
"]- we're describing a class"
"]- the class has no class variables"
"(this tutorial won't be discussing them)"
"]- there are two instance variables, X and Y"
"]- two methods have been defined, SET-X and SET-Y"
"]- there are no mixins"
"]- the class is not compiled"
"]- the class is not inherited"
"]We haven't yet discussed mixins or inheritance. We will discuss those"
"later. Compiling is the next topic."))
(frame
COMPILE-CLASS
("Now that you have defined a class you should /compile it."
"We're not actually generating code here but rather setting up"
"the actual inheritance structure for a class; we'll discuss"
"inheritance more later."
"If you don't use COMPILE-CLASS, it will be compiled"
"the first time you use the"
"special form MAKE-INSTANCE. Continuing with our example:")
(:data (COMPILE-CLASS POINT) :data-eval :pp-data)
()
()
"Compiling a Class"
("compile" "COMPILE-CLASS" "inheritance"))
(frame
MAKE-INSTANCE
("To create an instance of a class you would use the special form"
"/MAKE-INSTANCE. A simple instance creation would be:")
(:data (DEFINE P1 (MAKE-INSTANCE POINT)) :data-eval :pp-data)
("What this has done is to set up the data structure in memory"
"for the instance using all defaults.")
(define-point-class)
"Creating an Instance of a Class"
("MAKE-INSTANCE" ))
(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.")
(make-instance)
"Sending Messages"
("SEND"))
(frame
()
("We can use the DESCRIBE procedure to describe P1 and examine the values"
"of X and Y. This command would be: (DESCRIBE P1)")
(:output (DESCRIBE P1))
("As you can see we are told we are describing an instance. The instance"
"is of class POINT. There are no class variables."
"The instance variables are X with a value of 50"
"and Y with a value of 0. Which is what we would expect.")
()
()
("DESCRIBE"))
(frame
DEFINE-METHOD
("To define a method for a class you 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 occurrences"
"hanging around.")
()
"Defining Methods"
("DEFINE-METHOD"))
(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"
("active value"))
(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
MOVE-Y
("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.")
(ACTIVE-VALUES 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"
("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.")
()
()
()
()
("inheritance"))
(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 data is structured and yet not have to change"
"any code that uses the data."))
(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. In the file 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.")
()
"Conclusion"
("SCPSDEMO.S file"))
;
; This is an example of using SCOOPS. Please refer to chapter 5 in the
; Language Reference Manual for TI Scheme.
;
; The first thing that needs to be done is to define classes for different
; types. We will define three types, points, lines and rectangles.
;;;
;;; Point, Line and Rectangle
;;;
;;;
;;; Class POINT
;;;
(define-class point
(instvars (x (active 0 () move-x))
(y (active 0 () move-y))
(color (active 'yellow () change-color)))
(options settable-variables
inittable-variables))
(compile-class point) ; see page 45 in the language reference manual
;;;
;;; Class LINE
;;;
(define-class line
(instvars (len (active 50 () change-length))
(dir (active 0 () change-direction)))
(mixins point) ; inherit x, y, and color from point class.
(options settable-variables))
(compile-class line)
;;;
;;; Class RECTANGLE
;;;
(define-class rectangle
(instvars (height (active 60 () change-height)))
(mixins line) ; inherit color and width (len) from line
(options settable-variables))
(compile-class rectangle)
; In order to have an occurance of a class you will need to use the
; MAKE-INSTANCE procedure. For example:
; (define p1 (make-instance point))
; Then to change parts of the class use the send function. For example
; to change the color of the point previously defined:
; (send p1 change "color" 'cyan)
;
;;;
;;; Methods for POINT
;;;
(define-method (point erase) ()
(set-pen-color! 'black)
(draw))
(define-method (point draw) ()
(draw-point x y))
; having both a draw and redraw function here may seem to be unnecessary.
; you will see why both are needed as we continue
(define-method (point redraw) ()
(set-pen-color! color)
(draw))
(define-method (point move-x) (new-x)
(erase)
(set! x new-x)
(redraw)
new-x)
(define-method (point move-y) (new-y)
(erase)
(set! y new-y)
(redraw)
new-y)
(define-method (point change-color) (new-color)
(erase)
(set! color new-color)
(redraw)
new-color)
;;;
;;; Methods for LINE
;;;
; inherit erase, redraw, move-x, move-y and change-color from point.
(define-method (line draw) ()
(position-pen x y)
(draw-line-to (truncate (+ x (* len (cos dir))))
(truncate (+ y (* len (sin dir))))))
(define-method (line change-length) (new-length)
(erase)
(set! len new-length)
(redraw)
new-length)
(define-method (line change-direction) (new-dir)
(erase)
(set! dir new-dir)
(redraw)
new-dir)
;;;
;;; Methods for RECTANGLE
;;;
; inherit erase, redraw, move-x, move-y and change-color from point.
(define-method (rectangle draw) ()
(position-pen x y)
(draw-line-to (+ x len) y)
(draw-line-to (+ x len) (+ y height))
(draw-line-to x (+ y height))
(draw-line-to x y))
(define-method (rectangle change-height) (new-height)
(erase)
(set! height new-height)
(redraw)
new-height)
;
;these are routines necessary for the last part of the tutorial
;
(define small
(lambda ()
(let ((video 3)) ;this var is unused now
(set! *user-error-handler*
(lambda x
(display "There was an error. Please try again.")
(reset)))
(set-video-mode! 4)
(window-clear 'console)
(window-set-position! 'console 20 0)
(window-set-size! 'console 4 80)
(clear-graphics)
(if (equal? pcs-machine-type 1)
(begin ; for TI machines
(position-pen -360 -138)
(draw-box-to 359 -90))
(begin ; for IBM
(if (equal? (get-video-mode) 6)
(begin ; 640 x 200
(position-pen -320 -60)
(draw-line-to 319 -60))
(begin ; 320 x 200
(position-pen -160 -60)
(draw-line-to 159 -60)))))
video)))
(define finished
(lambda ()
(window-set-position! 'console 0 0)
(window-set-size! 'console 24 80)
(window-clear 'console)
(clear-graphics)
(set! *user-error-handler* nil)
(set-video-mode! 3)
))
(define pause
(lambda ()
(write-char (integer->char 2))
(read-char)
(newline)))
(define demo
(letrec ((B1 (make-instance rectangle))
(B2 (make-instance rectangle))
(L1 (make-instance line))
(prompt
(lambda (no command)
(princ "[")
(princ no)
(princ "] ")
(set! command (read))
(eval command (procedure-environment demo))
(if (equal? command (list 'finished))
0
(prompt (1+ no) command)))))
(lambda ()
(small)
(writeln " To create an instance of a class")
(writeln " use MAKE-INSTANCE. For example:")
(display " (DEFINE B1 (MAKE-INSTANCE RECTANGLE))")
(pause)
(writeln " Notice that the MAKE-INSTANCE doesn't")
(writeln " cause anything to appear on the screen.")
(writeln " All we have done so far is to define")
(display " the data strucure.")
(pause)
(writeln " To manipulate an instance we send ")
(writeln " messages to it. For example:")
(display " (SEND B1 SET-HEIGHT 40)")
(pause)
(send b1 set-height 40)
(writeln " Now let's create another instance.")
(display " (DEFINE B2 (MAKE-INSTANCE RECTANGLE))")
(pause)
(writeln " And change its x value to 100.")
(display " (SEND B2 SET-X 100)")
(pause)
(send b2 set-x 100)
(writeln " Since part of B1 was erased when we")
(writeln " moved B2, let's redraw B1.")
(display " (SEND B1 REDRAW)")
(pause)
(send b1 redraw)
(writeln " We can also change the color")
(writeln " of an instance.")
(display " (SEND B1 SET-COLOR 2)")
(pause)
(send b1 set-color 2)
(writeln " And change its width.")
(display " (SEND B2 SET-LEN 20)")
(pause)
(send b2 set-len 20)
(writeln " We can also make an instance of a line.")
(display " (DEFINE L1 (MAKE-INSTANCE LINE))")
(pause)
(writeln " With lines we can also change")
(writeln " directions, specified in radians.")
(display " (SEND L1 SET-DIR (/ 3.14 4))")
(pause)
(send l1 set-dir (/ 3.14 4))
(writeln " Of course we can also change the")
(writeln " length of the line.")
(display " (SEND L1 SET-LEN 100)")
(pause)
(send l1 set-len 100)
(writeln " Now's the time for you to try sending")
(writeln " messages on your own! You can define")
(writeln " new instances or manipulate B1, B2 and")
(display " L1.")
(pause)
(writeln " Enter (FINISHED) when you're through.")
(let ((command '()))
(prompt 1 command)))))


132
inht.scm Normal file
View File

@ -0,0 +1,132 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/29/85 ;;;
;;; ;;;
;;; File : inht.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains the inheritance details. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(define %inherit-method-vars
(lambda (class)
(or (%sc-class-inherited class)
(%inherit-from-mixins
(%sc-allcvs class)
(%sc-allivs class)
(%sc-method-structure class)
(%sc-mixins class)
class
(lambda (class cvs ivs methods)
(%sc-set-allcvs class cvs)
(%sc-set-allivs class ivs)
(%sc-set-method-structure class methods)
(%sc-set-class-inherited class #!true)
(%sign-on (%sc-name class) class)
class)))))
;;;
(define %sign-on
(lambda (name class)
(mapcar
(lambda (mixin)
(let* ((mixin-class (%sc-name->class mixin))
(subc (%sc-subclasses mixin-class)))
(if (not (%sc-class-inherited mixin-class))
(%inherit-method-vars mixin-class))
(or (memq name subc)
(%sc-set-subclasses mixin-class (cons name subc)))))
(%sc-mixins class))))
;;;
(define %inherit-from-mixins
(letrec
((insert-entry
(lambda (entry class1 method-entry name2 previous current)
(cond ((null? current)
(set-cdr! previous
(cons (cons (caadr method-entry) name2) '())))
((%before name2 (cdar current) (%sc-name class1))
(set-cdr! previous
(cons (cons (caadr method-entry) name2) current)))
(else '()))))
(insert
(lambda (struct1 entry class1 struct2 name2)
((rec loop-insert
(lambda (struct1 entry class1 struct2 name2 previous current)
(if (insert-entry entry class1 struct2 name2 previous current)
struct1
(loop-insert struct1 entry class1 struct2 name2
current (cdr current)))))
struct1 entry class1 struct2 name2 entry (cdr entry))))
(add-entry
(lambda (struct1 class1 method-entry name2)
(cons (list (car method-entry) (cons (caadr method-entry) name2))
struct1)))
(combine-methods
(lambda (struct1 class1 struct2 name2)
((rec loop-combine
(lambda (struct1 class1 struct2 name2)
(if struct2
(loop-combine
(let ((entry (assq (caar struct2) struct1)))
(if entry
(insert struct1 entry class1 (car struct2) name2)
(add-entry struct1 class1 (car struct2) name2)))
class1
(cdr struct2)
name2)
struct1)))
struct1 class1 struct2 name2)))
(combine-vars
(lambda (list1 list2)
((rec loop-combine
(lambda (list1 list2)
(if list2
(loop-combine
(if (assq (caar list2) list1)
list1
(cons (car list2) list1))
(cdr list2))
list1)))
list1 list2)))
)
(lambda (cvs ivs methods mixins class receiver)
((rec loop-mixins
(lambda (cvs ivs methods mixins class receiver)
(if mixins
(let ((mixin-class (%sc-name->class (car mixins))))
(%inherit-method-vars mixin-class)
(loop-mixins
(combine-vars cvs (%sc-allcvs mixin-class))
(combine-vars ivs (%sc-allivs mixin-class))
(combine-methods methods class
(%sc-method-structure mixin-class) (car mixins))
(cdr mixins)
class
receiver))
(receiver class cvs ivs methods ))))
cvs ivs methods mixins class receiver))))


38
install.bat Normal file
View File

@ -0,0 +1,38 @@
cls
rem
rem This batch copies the modified source files to the PC Scheme
rem source diskettes #1 through #4. This batch requires that this
rem batch be run from drive B: and that the source diskettes are
rem loaded into drive A: (which must be a High Density Floppy
rem Drive). If this is not the case, please halt the batch via
rem typing CONTROL C, otherwise hit any key to continue
pause
cls
rem
rem Place the PC Scheme source diskette #1 into drive A:
rem
pause
copy b:readme.* a: /v
copy b:*.bat a: /v
rem
rem Remove PC Scheme source diskette #1 from drive A: and
rem replace it with PC Scheme source diskette # 2
pause
copy b:pro2real.asm a: /v
rem
rem Remove PC Scheme source diskette #2 from drive A: and
rem replace it with PC Scheme source diskette # 3
pause
copy b:version.h a: /v
rem
rem Remove PC Scheme source diskette #3 from drive A: and
rem replace it with PC Scheme source diskette # 4
pause
copy b:smain.c a: /v
rem
rem Remove PC Scheme source diskette #4 from drive A:
pause
rem
rem The source diskettes have now been modified. You can now
rem begin the Build Procedure as specified in the README.PRO
rem file.

71
install2.bat Normal file
View File

@ -0,0 +1,71 @@
:
: PC Scheme installation batch stream, part 2
: call from part 1: install2 <f|f2|w> <dir> <memtype>
:
: then-parts of next 2 lines are never executed by a:install
if "%3" == "EXP" install2 %1 %2 exp
if "%3" == "EXT" install2 %1 %2 ext
if "%1" == "f2" goto floppy
echo If installing from 5 1/4" floppy, remove the PC Scheme Installation
echo disk from drive A and replace it with the PC Scheme Autoload disk.
echo If installing from a 3 1/2" diskette for PS2's, just press a key to
echo proceed.
pause
if "%1" == "w" goto windisk
if "%1" == "f" a:install2 f2 %2 %3
:
:floppy
:
: we are in the midst of creating the Boot diskette
a:pkxarc -r a:pkdisk2 make_fsl.exe scoops.fsl edit.fsl dummy.fsl
rename dummy.fsl edwin0.fsl
a:pkxarc -r a:pkdisk2 p*.fsl oldpmath.fsl
echo .
echo Remove the disk from drive B.
if "%3" == "" echo Label it "PCS Boot Diskette for Conventional Memory".
if "%3" == "exp" echo Label it "PCS Boot Diskette for Expanded Memory".
if "%3" == "ext" echo Label it "PCS Boot Diskette for Extended Memory".
echo Replace it with a blank, formatted diskette.
pause
echo -------------------- Creating Autoload diskette -----------------------
md %2
cd %2
a:pkxarc -r a:pkdisk2
del dummy.fsl
echo .
echo Remove the disk from drive B and label it "PCS Autoload Diskette".
echo Replace it with a blank, formatted diskette.
pause
echo -------------------- Creating Sources diskette -----------------------
md %2
cd %2
md xli
md sources
cd xli
a:pkxarc -r a:pkxli
cd ..\sources
a:pkxarc -r a:pksrc
cd ..
a:
cd \
echo .
echo Remove the disk from drive B and label it "PCS Sources Diskette".
pause
goto exit
:
:windisk
:
md xli
md sources
a:pkxarc -r a:pkdisk2
del dummy.fsl
cd xli
a:pkxarc -r a:pkxli
cd ..\sources
a:pkxarc -r a:pksrc
cd ..
:
:exit
:
echo *************** Installation of PC Scheme is complete ***************


14
install3.bat Normal file
View File

@ -0,0 +1,14 @@
:
: PC Scheme installation batch stream, part 2
: call from part 1: install2 <f|f2|w> <dir> <memtype>
:
: then-parts of next 2 lines are never executed by a:install
if "%3" == "EXP" install2 %1 %2 exp
if "%3" == "EXT" install2 %1 %2 ext
if "%1" == "f2" goto floppy
: Next 3 lines commented out for installations from 3.5" diskette
: echo Please remove the PC Scheme Installation disk from drive A
: echo and replace it with the PC Scheme Autoload disk.
: pause
if "%1" == "w" goto windisk
if "%1" =

98
instance.scm Normal file
View File

@ -0,0 +1,98 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/28/85 ;;;
;;; ;;;
;;; File : instance.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains the compiling and making of an instance. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(macro compile-class
(lambda (e)
(let ((name (cadr e))
(class (%sc-name->class (cadr e))))
(if (%sc-class-compiled class)
name
(begin
(%inherit-method-vars class)
(%make-template name class))))))
;;;
(define %sc-compile-class
(lambda (class)
(%inherit-method-vars class)
(eval (%make-template (%sc-name class) class)
user-initial-environment)))
;;;
(macro make-instance
(lambda (e)
(cons (list '%sc-inst-template (cadr e)) (cddr e))))
;;;
(define %uncompiled-make-instance
(lambda (class)
(lambda init-msg
(%sc-compile-class class)
(apply (%sc-inst-template class) init-msg))))
;;;
(define %make-template
(lambda (name class)
`(begin
;;; do some work to make compile-file work
(%sc-set-allcvs ,name ',(%sc-allcvs class))
(%sc-set-allivs ,name ',(%sc-allivs class))
(%sc-set-method-structure ,name
',(%sc-method-structure class))
;;; prepare make-instance template
(%sc-set-inst-template ,name
,(%make-inst-template (%sc-allcvs class)
(%sc-allivs class)
(%sc-method-structure class)
name class))
(%sc-set-class-compiled ,name #!TRUE)
(%sc-set-class-inherited ,name #!TRUE)
(%sign-on ',name ,name)
;;;
',name)))
;;;
(define %make-inst-template
(lambda (cvs ivs method-structure name class)
(let ((methods
(append
(mapcar
(lambda (a)
`(,(car a) (%sc-get-meth-value ',(car a) ,(caadr a))))
method-structure)
'((%*methods*% '-))))
(classvar (append cvs '((%*classvars*% '-))))
(instvar (append ivs '((%*instvars*% '-)))))
`(let ((%sc-class ,name))
(let ,methods
(%sc-set-method-env ,name (the-environment))
(let ,classvar
(%sc-set-class-env ,name (the-environment))
(lambda %sc-init-vals
(let ,instvar
(the-environment)))))))))


88
instpro.bat Normal file
View File

@ -0,0 +1,88 @@
ECHO OFF
CLS
a:
IF %1x==x INSTPRO C:
IF %2y==y INSTPRO %1 \
ECHO ------------------------------------------------------------------------
ECHO -
ECHO - Installing Protected Mode Scheme on disk %1 directory %2
ECHO -
ECHO - If after installation you encounter problems getting
ECHO - the protected mode application running, read PROREAD.ME
ECHO - for assistance.
ECHO -
ECHO ------------------------------------------------------------------------
PAUSE
CLS
IF EXIST %1%2 (pause, warning, will overwrite old files)
ECHO Creating the %2 directory structure on drive %1.
IF NOT EXIST %1%2 MKDIR %1%2
COPY a:\PROREAD.ME %1%2
COPY a:\MACHTYPE.EXE %1%2
ECHO Installing Protected Mode files in %1%2
COPY a:OS.286 %1%2
COPY a:PCSPRO.EXE %1%2
COPY a:REALSCHM.EXE %1%2
COPY a:REALIO.EXE %1%2
COPY a:GRAPHICS.EXE %1%2
if not exist %1\CONFIG.286 goto build_config
ECHO - config.286 already exists, new one will NOT be created.
GOTO config_ret
:build_config
ECHO Copying CONFIG.286 to %1\
ECHO
ECHO You may need to edit CONFIG.286 for your particular machine.
ECHO See %1%2\PROREAD.ME for details.
ECHO
MACHTYPE
IF NOT ERRORLEVEL 3 GOTO chk_newat
REM PS2 model 50,60, or 80 - note as such in config.286
ECHO ps2=1 >%1\config.286
ECHO shutdown=a >>%1\config.286
ECHO keyboardwait=1 >>%1\config.286
GOTO done_config
:chk_newat
IF NOT ERRORLEVEL 2 GOTO chk_oldat
REM newer at/bios, use fastest values in config.286
ECHO shutdown=a >%1\config.286
ECHO keyboardwait=1 >>%1\config.286
GOTO done_config
:chk_oldat
IF NOT ERRORLEVEL 1 GOTO chk_known
REM older at/bios, use relatively safe values in config.286
ECHO shutdown=9 >%1\config.286
ECHO keyboardwait=1 >>%1\config.286
GOTO done_config
:chk_known
IF NOT ERRORLEVEL 0 GOTO chk_error
REM unknown machine, create default values in config.286
ECHO shutdown=9 >%1\config.286
ECHO keyboardwait=200 >>%1\config.286
:done_config
REM append location of os286 kernel to config.286 file
ECHO kernel=%1%2\os.286 >>%1\config.286
GOTO config_ret
:chk_error
ECHO
ECHO Machine does not support extended memory and therefore doesn't
ECHO support protected mode applications 
ECHO
GOTO config_ret
:config_ret
%1:
CD %2
ECHO - End of Protected Mode Scheme installation.


205
interf.scm Normal file
View File

@ -0,0 +1,205 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/22/85 ;;;
;;; ;;;
;;; File : interf.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains class definition and processing of ;;;
;;; define-class. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(macro define-class
(lambda (e)
(let ((name (cadr e))(classvars '()) (instvars '()) (mixins '())
(options '())(allvars '())(method-values '())(inits '()))
(letrec
((chk-class-def
(lambda (classdef)
((rec loop
(lambda (deflist)
(if deflist
(begin
(cond ((eq? (caar deflist) 'classvars)
(set! classvars (cdar deflist)))
((eq? (caar deflist) 'instvars)
(set! instvars (cdar deflist)))
((eq? (caar deflist) 'mixins)
(set! mixins (cdar deflist)))
((eq? (caar deflist) 'options)
(set! options (cdar deflist)))
(else (error-handler (caar classdef) 0 '())))
(loop (cdr deflist))))))
classdef)
(set! allvars
(append (mapcar (lambda (a) (if (atom? a) a (car a)))
classvars)
(mapcar (lambda (a) (if (atom? a) a (car a)))
instvars)))))
(chk-option
(lambda (opt-list)
((rec loop
(lambda (opl meths)
(if opl
(loop
(cdr opl)
(cond ((eq? (caar opl) 'gettable-variables)
(append (generate-get (cdar opl)) meths))
((eq? (caar opl) 'settable-variables)
(append (generate-set (cdar opl)) meths))
((eq? (caar opl) 'inittable-variables)
(set! inits (cdar opl)) meths)
(else (error-handler (car opl) 1 '()))))
meths)))
opt-list '())))
(chk-cvs
(lambda (list-var)
(mapcar
(lambda (a)
(if (atom? a)
(list a '#!unassigned)
a))
list-var)))
(chk-init
(lambda (v-form)
(if (memq (car v-form) inits)
(list (car v-form)
(list 'apply-if
(list 'memq
(list 'quote (car v-form)) '%sc-init-vals)
'(lambda (a) (cadr a))
(cadr v-form)))
v-form)))
(chk-ivs
(lambda (list-var)
(mapcar
(lambda (var)
(chk-init
(cond ((atom? var) (list var '#!unassigned))
((not-active? (cadr var)) var)
(else (active-val (car var) (cadr var))))))
list-var)))
(not-active?
(lambda (a)
(or (atom? a)
(not (eq? (car a) 'active)))))
(empty-slot?
(lambda (form)
(or (not form)
(and (eq? 'nil form)
pcs-integrate-t-and-nil))))
(active-val
(lambda (var active-form)
((rec loop
(lambda (var active-form getfns setfns)
(if (not-active? (cadr active-form))
(create-active
var
(if (empty-slot? (caddr active-form))
getfns
(cons (caddr active-form) getfns))
(list 'set! var
(if (empty-slot? (cadddr active-form))
setfns
(list (cadddr active-form) setfns)))
(cadr active-form))
(loop
var
(cadr active-form)
(if (empty-slot? (caddr active-form))
getfns
(cons (caddr active-form) getfns))
(if (empty-slot? (cadddr active-form))
setfns
(list (cadddr active-form) setfns))))))
var active-form '() '%sc-val)))
(create-active
(lambda (var getfns setfns localstate)
(set! method-values
(cons (list 'cons
(list 'quote (concat "GET-" var))
(%sc-expand
(list 'lambda '() (expand-getfns var getfns))))
(cons (list 'cons
(list 'quote (concat "SET-" var))
(%sc-expand (list 'lambda '(%sc-val) setfns)))
method-values)))
(list var localstate)))
(expand-getfns
(lambda (var getfns)
((rec loop
(lambda (var gets exp-form)
(if gets
(loop
var
(cdr gets)
(list (car gets) exp-form))
exp-form)))
var getfns var)))
(concat
(lambda (str sym)
(string->symbol (string-append str (symbol->string sym)))))
(generate-get
(lambda (getlist)
(mapcar
(lambda (a)
(list 'cons (list 'quote (concat "GET-" a))
(%sc-expand (list 'lambda '() a))))
getlist)))
(generate-set
(lambda (setlist)
(mapcar
(lambda (a)
(list 'cons (list 'quote (concat "SET-" a))
(%sc-expand
(list 'lambda '(%sc-val)
(list 'set! a '%sc-val)))))
setlist)))
)
(chk-class-def (cddr e))
(set! method-values
(chk-option
(mapcar (lambda (a) (if (atom? a) (cons a allvars) a))
options)))
(list 'define
name
(list '%sc-make-class
(list 'quote name)
(if classvars
(list 'quote (chk-cvs classvars))
'())
(if instvars
(list 'quote (chk-ivs instvars))
'())
(list 'quote mixins)
(if method-values
(cons 'list method-values)
'())
))))))


3
ldscoop.scm Normal file
View File

@ -0,0 +1,3 @@
(define load-scoops
(lambda ()
'SCOOPS-LOADED))

159
master.bat Normal file
View File

@ -0,0 +1,159 @@
echo off
if "%1" == "protected" goto probuild
goto regbuild
:probuild
CLS
echo .
echo .
echo This batch stream which is on the PC SCHEME Source Diskette #1
echo has been envoked with the "protected" option, and will assemble,
echo compile, and link the PROTECTED MODE VERSION of PC SCHEME. The
echo diskette generated by this build procedure is:
echo .
echo . 2537903-1615 FDO, PC SCHEME PROTECTED MODE DISKETTE
echo .
echo .
echo The source for building is contained on the diskettes
echo labeled PC SCHEME Source Diskette #1 through #4.
echo .
echo .
echo Please press the RETURN key to continue.
echo .
PAUSE
CLS
echo A list of hardware and software required for the build is given below.
echo .
echo . TI Business Pro with:
echo . - 640K memory
echo . - 1.2 MB floppy disk drive (drive A)
echo . - 360 KB floppy disk drive (drive B)
echo . - a Winchester disk drive with at least 10 MB free space
echo .
echo .
echo . MS-DOS Operating System, version 3.21
echo . MS-Macro Assembler, version 4.00
echo . Lattice C Compiler, version 3.0
echo . Dater
echo .
echo Please press the RETURN key to continue.
echo .
pause
cls
echo Before continuing, make sure you have 1 blank, formatted
echo 360KB floppy disk available.
echo .
echo Also, the system must be booted with a CONFIG.SYS file
echo containing these 2 entries:
echo .
echo FILES=20
echo BUFFERS=15
echo .
echo Lastly, DOS files must be located in the root directory
echo (in particular, COMMAND.COM).
echo .
echo Use CTRL-C to exit this batch stream if these conditions have not
echo been met, else press the RETURN key to continue.
echo .
pause
echo ********************************************************************
echo .
echo Please press the PRINT key to echo print the execution of this batch.
echo .
echo Please press the RETURN key to continue.
PAUSE
goto continue
:regbuild
CLS
echo These commands will build 4 master distribution diskettes for PC SCHEME.
echo .
echo .
echo This batch stream which is on the PC SCHEME Source Diskette #1
echo assembles, compiles, and links PC SCHEME. The diskettes generated
echo by this build procedure are:
echo .
echo . 2537903-1610 FDO, PC SCHEME INSTALLATION DISKETTE
echo . 2537903-1611 FDO, PC SCHEME AUTOLOAD DISKETTE
echo . 2537903-1614 FDO, PC SCHEME 3 1/2" INSTALLATION DISKETTE
echo . 2537903-1615 FDO, PC SCHEME PROTECTED MODE DISKETTE
echo .
echo .
echo The source for building is contained on the diskettes
echo labeled PC SCHEME Source Diskette #1 through #4.
echo .
echo .
echo Please press the RETURN key to continue.
echo .
PAUSE
CLS
echo A list of hardware and software required for the build is given below.
echo .
echo . TI Business Pro with:
echo . - 640K memory
echo . - 1.2 MB floppy disk drive (drive A)
echo . - 360 KB floppy disk drive (drive B)
echo . - a Winchester disk drive with at least 10 MB free space
echo .
echo . A computer system with both:
echo . - one low-density 360 KB floppy disk drive
echo . - one 3 1/2" media drive
echo .
echo . MS-DOS Operating System, version 3.21
echo . MS-Macro Assembler, version 4.00
echo . Lattice C Compiler, version 3.0
echo . Dater
echo . PC Scheme 3.02
echo .
echo Please press the RETURN key to continue.
echo .
pause
cls
echo Before continuing, make sure you have 3 blank, formatted
echo 360KB floppy disks available and 1 blank, formatted
echo 3 1/2" diskette.
echo .
echo Also, the system must be booted with a CONFIG.SYS file
echo containing these 2 entries:
echo .
echo FILES=20
echo BUFFERS=15
echo .
echo Lastly, DOS files must be located in the root directory
echo (in particular, COMMAND.COM).
echo .
echo Use CTRL-C to exit this batch stream if these conditions have not
echo been met, else press the RETURN key to continue.
echo .
pause
echo ********************************************************************
echo .
echo Please press the PRINT key to echo print the execution of this batch.
echo .
echo Please press the RETURN key to continue.
PAUSE
:continue
echo on
CLS
rem
rem
rem Begin building PC SCHEME
rem
rem
MD \BUILD
MD \BUILD\EDWIN
MD \BUILD\NEWPCS
MD \BUILD\SCOOPS
MD \BUILD\SOURCES
MD \BUILD\XLI
MD \EXEC
MD \EXEC\MISC
MD \TOOLS
MD \LIB
MD \OBJECT
MD \OBJECTX
MD \OBJECTP
MD \PCS
COPY A:*.BAT \BUILD
PATH = \TOOLS;\PCS;\
CD \BUILD
SCHBUILD %1 %2


17
memory.bat Normal file
View File

@ -0,0 +1,17 @@
ECHO OFF
MEMTYPE
IF NOT ERRORLEVEL 3 GOTO NEXT1
ECHO Your computer contains both expanded and extended memory.
GOTO END
:NEXT1
IF NOT ERRORLEVEL 2 GOTO NEXT2
ECHO Your computer contains expanded memory.
GOTO END
:NEXT2
IF NOT ERRORLEVEL 1 GOTO NEXT3
ECHO Your computer contains extended memory.
GOTO END
:NEXT3
ECHO Your computer contains only conventional memory.
:END


138
meth2.scm Normal file
View File

@ -0,0 +1,138 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/29/85 ;;;
;;; ;;;
;;; File : meth2.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains the deleteion of methods from classes. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(macro delete-method
(lambda (e)
(let ((class-name (caadr e))
(method-name (cadr (cadr e))))
(list '%sc-class-del-method
(list 'quote class-name)
(list 'quote method-name)
(list 'quote class-name)
(list 'quote class-name)
(list 'lambda '(env val)
(list 'set! (list 'access method-name 'env) 'val))
(list 'quote '())))))
;;;
(define %deleted-method
(lambda (name)
(lambda args
(error-handler name 3 #!TRUE))))
;;;
(define %sc-class-del-method
(lambda (class-name method-name method-class mixin-class assigner del-value)
(let ((class (%sc-name->class class-name)))
(apply-if (assq method-name (%sc-method-values class))
(lambda (entry)
(%sc-set-method-values class
(delq! entry (%sc-method-values class)))
(%compiled-del-method class-name method-name method-class mixin-class
assigner del-value))
(error-handler method-name 4 #!TRUE)))))
;;;
(define %inform-del-subclasses
(lambda (class-name method-name method-class mixin-class assigner del-value)
((rec loop
(lambda (class-name method-name method-class mixin-class assigner
del-value subclass)
(if subclass
(begin
(%compiled-del-method (car subclass) method-name
method-class class-name assigner del-value)
(loop class-name method-name method-class mixin-class assigner
del-value (cdr subclass))))))
class-name method-name method-class mixin-class assigner del-value
(%sc-subclasses (%sc-name->class class-name)))))
;;;
(define %compiled-del-method
(lambda (class-name method-name method-class mixin-class assigner del-value)
(let ((class (%sc-name->class class-name)))
(letrec
((delete-entry
(lambda (previous current)
(cond ((eq? mixin-class (cdar current))
(set-cdr! previous (cdr current)) #!TRUE)
(else #!FALSE))))
(loop-delete
(lambda (previous current)
(cond ((or (null? current)
(%before mixin-class (cdar previous)
class-name))
(error-handler method-name 4 #!TRUE))
((delete-entry previous current) #!TRUE)
(else (loop-delete current (cdr current))))))
(delete
(lambda (entry)
(if (delete-entry entry (cdr entry)) ;;; delete at head
(modify-environment entry)
(loop-delete (cdr entry) (cddr entry)))))
(modify-environment
(lambda (entry)
(cond ((null? (cdr entry))
(%sc-set-method-structure class
(delq! (assq method-name (%sc-method-structure class))
(%sc-method-structure class)))
(if (%sc-class-compiled class)
(assigner (%sc-method-env class)
(or del-value
(set! del-value
(%deleted-method method-name)))))
(if (%sc-subclasses class)
(%inform-del-subclasses class-name method-name
method-class mixin-class assigner del-value)))
(else
(let ((meth-value
(%sc-get-meth-value method-name
(%sc-name->class (caadr entry)))))
(if (%sc-class-compiled class)
(assigner (%sc-method-env class) meth-value))
(if (%sc-subclasses class)
(%inform-subclasses class-name
method-name
method-class
mixin-class
meth-value assigner)))))))
)
(let ((method-entry (assq method-name (%sc-method-structure class))))
(if method-entry
(delete method-entry)
(error-handler method-name 4 #!TRUE))
method-name)))))

136
methods.scm Normal file
View File

@ -0,0 +1,136 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/29/85 ;;;
;;; ;;;
;;; File : methods.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains the adding of methods to classes ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; is class1 before class2 in class ?
;;; class1 is not equal to class2
(define %before
(lambda (class1 class2 class)
(or (eq? class1 class)
(memq class2 (memq class1 (%sc-mixins (%sc-name->class class)))))))
;;;
(macro define-method
(lambda (e)
(let ((class-name (caadr e))
(method-name (cadr (cadr e)))
(formal-list (caddr e))
(body (cdddr e)))
(list '%sc-class-add-method
(list 'quote class-name)
(list 'quote method-name)
(list 'quote class-name)
(list 'quote class-name)
(%sc-expand
(cons 'lambda (cons formal-list body)))
(list 'lambda '(env val)
(list 'set! (list 'access method-name 'env) 'val))))))
;;;
(define %sc-class-add-method
(lambda (class-name method-name method-class mixin-class method assigner)
(let ((class (%sc-name->class class-name)))
(apply-if (assq method-name (%sc-method-values class))
(lambda (entry)
(set-cdr! entry method))
(%sc-set-method-values class
(cons (cons method-name method) (%sc-method-values class)))))
(%compiled-add-method class-name method-name method-class mixin-class
method assigner)))
;;;
(define %inform-subclasses
(lambda (class-name method-name method-class mixin-class method assigner)
((rec loop
(lambda (class-name method-name method-class mixin-class
method assigner subclass)
(if subclass
(begin
(%compiled-add-method
(car subclass) method-name method-class class-name
method assigner)
(loop class-name method-name method-class mixin-class
method assigner
(cdr subclass))))))
class-name method-name method-class mixin-class method assigner
(%sc-subclasses (%sc-name->class class-name)))))
;;;
(define %compiled-add-method
(lambda (class-name method-name method-class mixin-class method assigner)
(letrec
((class (%sc-name->class class-name))
(insert-entry
(lambda (previous current)
(cond ((null? current)
(set-cdr! previous
(cons (cons method-class mixin-class) '())))
((eq? mixin-class (cdar current))
(set-car! (car current) method-class))
((%before mixin-class (cdar current)
class-name)
(set-cdr! previous
(cons (cons method-class mixin-class) current)))
(else '()))))
(loop-insert
(lambda (previous current)
(if (not (insert-entry previous current))
(loop-insert (current) (cdr current)))))
(insert
(lambda (entry)
(if (insert-entry entry (cdr entry)) ;;; insert at head
(add-to-environment)
(loop-insert (cdr entry) (cddr entry)))))
(add-to-environment
(lambda ()
(if (%sc-class-compiled class)
(assigner (%sc-method-env class) method))
(if (%sc-subclasses class)
(%inform-subclasses class-name method-name method-class
mixin-class method assigner))))
(add-entry
(lambda ()
(%sc-set-method-structure class
(cons (list method-name (cons method-class mixin-class))
(%sc-method-structure class)))
(add-to-environment)))
)
(let ((method-entry (assq method-name (%sc-method-structure class))))
(if method-entry
(insert method-entry)
(add-entry))
method-name))))

48
readme.1 Normal file
View File

@ -0,0 +1,48 @@
TEXAS INSTRUMENTS PROGRAM LICENSE AGREEMENT
Copyright (c) 1985, 1986, 1987, Texas Instruments Incorporated
This copyrighted software program is licensed, not sold. Title to the
original Program remains at all times with TI and/or its licensors.
Permission to copy and distribute this Program and to use it for any purpose
is granted, subject to the following restrictions and understandings.
1. Any copy made of this Program must include this copyright notice in full.
2. Users of this Program agree to make their best efforts to return to TI
any improvement, enhancement or extension that they make, so that such
improvement, enhancement or extension may be considered for future releases
of this Program. Such improvements, enhancements or extensions may be used
and/or adapted for use by TI, royalty free, without accounting to creator of
such improvements, enhancements or extensions in TI products. User agrees to
inform TI of noteworthy uses of this Program. Send improvements,
enhancements or extensions on magnetic media along with appropriate
documentation and/or information concerning noteworthy uses to
Herb Roehrig
Texas Instruments
PO Box 1444, MS 7722
Houston, TX 77251
3. All materials developed as a consequence of the use of this Program
shall duly acknowledge such use, in accordance with the usual standards of
acknowledgement accepted in the publishing industry.
4. THE PROGRAM IS NOT WARRANTED AND IS PROVIDED SOLELY ON AN "AS IS" BASIS.
TI AND ITS LICENSORS SHALL NOT BE RESPONSIBLE FOR INCIDENTAL, OR
CONSEQUENTIAL DAMAGES.
5. In conjunction with products arising from the use of this program, there
shall be no use of the name of Texas Instruments Incorporated nor any
adaptation thereof in any marketing literature without the prior written
consent of TI in each use.
RESTRUCTED RIGHTS LEGEND
Use, duplication, or disclosure by the Government is subject to restructions
as set forth in subdivision (c) (1) (ii) of the Rights in Technical Data and
Computer Software clause at DFAR 252.227.7013.
ATTN: Information Technology Group, M/S 2151
Texas Instruments Incorporated
PO Box 149149
Austin, TX 78714-9149

151
readme.2 Normal file
View File

@ -0,0 +1,151 @@
THIS IS THE README FILE FOR THE PC SCHEME 3.03 RELEASE
A. Materials to be provided by Software Control:
1.) Two blank, formatted, double-sided, double-density (360KB)
floppy diskettes. They should already be formatted.
2.) Business Pro with:
- 640K memory
- one high-density (1.2 MByte) floppy drive (drive A)
- one low-density (360 KByte) drive (drive B)
- a printer
- one Winchester hard disk drive with at least 10 Mbytes free
3.) MS-DOS Operating System diskette vers. 3.21 (P/N 2538155-1610
AND 1611)
4.) MACRO ASSEMBLER version 4.00 diskette (P/N 2546114).
5.) LATTICE 'C' COMPILER version 3.05 diskettes (P/N 2249759).
6.) Dater diskette version 1.20 (P/N 2223081-1610).
7.) PC SCHEME version 3.02 diskettes (P/N 2537901-0001, -0002).
B. Materials to be provided by the Scheme Development group:
1.) TI PC SCHEME SOURCE diskette #1 (P/N 2537903-2620).
2.) TI PC SCHEME SOURCE diskette #2 (P/N 2537903-2621).
3.) TI PC SCHEME SOURCE diskette #3 (P/N 2537903-2622).
4.) TI PC SCHEME SOURCE diskette #4 (P/N 2537903-2623).
C. Release procedure steps:
1.) Boot the PC from MS-DOS diskette.
2.) Enter the date and time when you are requested to do so.
3.) Format the Winchester as follows:
- Type FORMAT E: /S (and pressing RETURN).
- Respond to the prompt for drive type with appropriate number.
4.) Copy all the files on the MS-DOS diskette onto the Winchester by
typing:
COPY *.* E:/V (and pressing RETURN)
4.1) Modify the CONFIG.SYS file to include at least 15 files:
FILES=20
BUFFERS=15
5.) Reboot the system from the Winchester.
6.) Enter the date and time when you are requested to do so.
7.) Remove the MS-DOS diskette from drive A: and insert the PC SCHEME
SOURCE diskette #1 (P/N 2537903-2620) in drive A:
8.) Begin execution of the batch stream to build PC SCHEME:
- Press the PRNT key (to cause subsequent messages to be echoed
to the printer).
- Type A:MASTER
The batch stream will instruct you to insert the diskettes listed
above. Once the necessary files have been copied to the Winchester,
the actual build process will begin and no further attention is
required until the installation disks are ready to be made
(the batch stream will wait for you at that point).
9.) Each of the assemblies in the batch stream should terminate with the
following message:
Warning Severe
Errors Errors
0 0
10.) C compilations may produce warning messages and this is all right.
There should be no error messages, however.
11.) DOS messages about "unable to create directory" during CD commands
or "file not found" during DEL commands can be ignored.
11.) After the assemblies, compilations, and linking have completed, the
batch stream will invoke the PCS.EXE file several times to compile
the Scheme compiler source files, Scoops source files, and Edwin.
You will see some warning messages like
[WARNING: modifying an 'integrable' variable: xxxxxx]
displayed on the screen, however they will not be written to the
printer.
12.) When you are prompted to, insert the first blank formatted 360KB
diskette into drive B (*not* drive A) and press RETURN to continue.
At the next prompt, remove the diskette and replace it with the
second blank formatted 360KB diskette in drive B and press RETURN.
At the next prompt, remove the diskette and replace it with the
third blank formatted 360KB diskette in drive B and press RETURN.
At the next prompt, remove the diskette.
13.) Label the first diskettes as:
PC SCHEME INSTALLATION DISKETTE,
Master FDO diskette #1
(P/N 2537903-1610).
Label the second diskette as:
PC SCHEME AUTOLOAD DISKETTE,
Master FDO diskette #2
(P/N 2537903-1611).
Label the third diskette as:
PC SCHEME PROTECTED MODE INSTALLATION DISKETTE,
Master FDO diskette #3
(P/N 2537903-1615).
14.) You're done.
***** Addendum for creating 3.5-inch installation disks. *****
1.) Assuming that the 3.5" drive is drive C, do the following:
- Put a blank, formatted 3.5" diskette into drive C.
- Put the PC Scheme Installation diskette into drive A and do:
COPY A:*.* C:
- Put the PC Scheme Autoload diskette into drive A (do not
remove the diskette from drive C) and do:
COPY A:*.* C:
- You're done. There is only one installation diskette created
when using 3.5" media.


107
readme.pro Normal file
View File

@ -0,0 +1,107 @@
THIS IS THE README FILE FOR THE PROTECTED MODE SCHEME 4.0 RELEASE
This readme file provides the instructions for a build of the Protected
Mode Scheme Diskette by itself. It may also be built as a part of the
normal PC Scheme build procedure as described in the file README.
A. Materials to be provided by Software Control:
1.) One blank, formatted, double-sided, double-density (360KB)
floppy diskettes. They should already be formatted.
2.) Business Pro with:
- 640K memory
- one high-density (1.2 MByte) floppy drive (drive A)
- one low-density (360 KByte) drive (drive B)
- a printer
- one Winchester hard disk drive with at least 10 Mbytes free
3.) MS-DOS Operating System diskette vers. 3.21 (P/N 2538155-1610
AND 1611)
4.) MACRO ASSEMBLER version 4.00 diskette (P/N 2546114).
5.) LATTICE 'C' COMPILER version 3.05 diskettes (P/N 2249759).
6.) Dater diskette version 1.20 (P/N 2223081-1610).
B. Materials to be provided by the Scheme Development group:
1.) TI PC SCHEME SOURCE diskette #1 (P/N 2537903-2620).
2.) TI PC SCHEME SOURCE diskette #2 (P/N 2537903-2621).
3.) TI PC SCHEME SOURCE diskette #3 (P/N 2537903-2622).
4.) TI PC SCHEME SOURCE diskette #4 (P/N 2537903-2623).
C. Release procedure steps:
1.) Boot the PC from MS-DOS diskette.
2.) Enter the date and time when you are requested to do so.
3.) Format the Winchester as follows:
- Type FORMAT E: /S (and pressing RETURN).
- Respond to the prompt for drive type with appropriate number.
4.) Copy all the files on the MS-DOS diskette onto the Winchester by
typing:
COPY *.* E:/V (and pressing RETURN)
4.1) Modify the CONFIG.SYS file to include at least 15 files:
FILES=20
BUFFERS=15
5.) Reboot the system from the Winchester.
6.) Enter the date and time when you are requested to do so.
7.) Remove the MS-DOS diskette from drive A: and insert the PC SCHEME
SOURCE diskette #1 (P/N 2537903-2620) in drive A:
8.) Begin execution of the batch stream to build PC SCHEME:
- Press the PRNT key (to cause subsequent messages to be echoed
to the printer).
- Type A:MASTER protected
NOTE: protected must be in lower case!!!
The batch stream will instruct you to insert the diskettes listed
above. Once the necessary files have been copied to the Winchester,
the actual build process will begin and no further attention is
required until the installation disks are ready to be made
(the batch stream will wait for you at that point).
9.) Each of the assemblies in the batch stream should terminate with the
following message:
Warning Severe
Errors Errors
0 0
10.) C compilations may produce warning messages and this is all right.
There should be no error messages, however.
11.) DOS messages about "unable to create directory" during CD commands
or "file not found" during DEL commands can be ignored.
12.) When you are prompted to, insert a blank formatted 360KB diskette
into drive B (*not* drive A) and press RETURN to continue.
13.) Label the diskette as:
PC SCHEME PROTECTED MODE DISKETTE,
(P/N 2537903-1615).
14.) You're done.

209
schbuil2.bat Normal file
View File

@ -0,0 +1,209 @@
: =====> SCHBUIL2.BAT
cd \build
if "%1" == "protected" goto buildpro
PATH = \TOOLS;\PCS;\
rem
rem
rem Build conventional memory PCS
rem
rem
\TOOLS\MAKE PCS.MAK
rem
rem
rem Build protected memory PCS.
rem
rem
:buildpro
\TOOLS\MAKE PCSPRO.MAK
if "%1" == "protected" goto proutil
rem
rem
rem Build expanded memory PCS.
rem
rem
\TOOLS\MAKE PCSEXP.MAK
rem
rem
rem Build extended memory PCS.
rem
rem
\TOOLS\MAKE PCSEXT.MAK
rem
rem
rem Build utility .EXE's.
rem
rem
:proutil
COMMAND /C \BUILD\DO_UTIL %1
if "%1" == "protected" goto copybuild
rem
rem
rem Build Scheme compiler
rem (source compiler, autoloading compiler, runtime)
rem
rem
COMMAND /C \BUILD\DO_PCS
rem
rem
rem Build Scheme autoload files
rem
rem
COMMAND /C \BUILD\DO_AUTO
rem
rem
rem Build SCOOPS (there will be no prompts for 10-15 minutes)
rem
rem
COMMAND /C \BUILD\DO_SCOOPS
rem
rem
rem Build EDWIN (3 phases)
rem
rem
COMMAND /C \BUILD\DO_EDWIN
:copybuild
rem
rem Copy everything else to \EXEC directory
rem
cd \build
if "%1" == "protected" goto copypro
COPY read.me \exec /v
COPY install.bat \exec /v
COPY install2.bat \exec /v
COPY memory.bat \exec /v
COPY \tools\pkxarc.com \exec /v
COPY \exec\misc\compiler.fsl \exec /v
COPY \exec\misc\primops.fsl \exec /v
COPY \exec\misc\autocomp.fsl \exec /v
COPY \exec\misc\autoprim.fsl \exec /v
COPY \build\newpcs\edwin.ini \exec /v
COPY \build\scoops\scpsdemo.s \exec /v
COPY \build\newpcs\kldscope.s \exec /v
COPY \build\newpcs\help.s \exec /v
COPY \build\newpcs\graphics.s \exec /v
:copypro
COPY instpro.bat \exec /v
COPY proread.me \exec /v
COPY \tools\os.286 \exec /v
COPY \tools\vers8042.com \exec /v
rem
rem Get today's date on everything
rem
cd \exec
dater *.*
if "%1" == "protected" goto createpro
cd \build\sources
dater *.*
cd \build\xli
dater *.*
rem
rem Create .ARC files
rem
cd \exec
pkarc a pkdisk1 compiler.app pcs.exe pcsex?.exe newtrig.exe
pkarc a pkdisk2 *.s *.fsl runtime.app make_fsl.exe edwin.ini
pkarc a pksrc \build\sources\*.*
pkarc a pkxli \build\xli\*.*
dater *.arc
rem
rem Create the installation diskettes
rem
rem Please put blank 360KB floppy disk into drive B:.
pause
copy read.me b:
copy install.bat b:
copy install2.bat b:
copy memory.bat b:
copy memtype.exe b:
copy pkdisk1.arc b:
copy pkxarc.com b:
rem Remove the floppy disk from drive B: and label it
rem "PC Scheme Installation Diskette".
rem Put blank 360KB floppy disk into drive B:.
pause
copy install2.bat b:
copy pkdisk2.arc b:
copy pksrc.arc b:
copy pkxli.arc b:
copy pkxarc.com b:
rem Remove the floppy disk from drive B: and label it
rem "PC Scheme Autoload Diskette."
:createpro
rem Put a blank 360KB floppy disk into drive B:.
pause
copy proread.me b:
copy instpro.bat b:
copy pcspro.exe b:
copy machtype.exe b:
copy os.286 b:
copy realio.exe b:
copy graphics.exe b:
copy realschm.exe b:
copy vers8042.com b:
if "%1" == "" goto createreg
rem -
rem - Remove the floppy disk from drive B: and label it
rem - "PC Scheme Protected Mode Installation Diskette."
rem -
rem - Protected Mode build complete
rem -
goto finished
:createreg
ECHO OFF
cls
ECHO -
ECHO - Remove the floppy disk from drive B: and label it
ECHO - "PC Scheme Protected Mode Installation Diskette."
ECHO -
ECHO - Take the two diskettes:
ECHO -
ECHO - "PC Scheme Installation Diskette" p/n 2537903-1610 and
ECHO - "PC Scheme Autoload Diskette" p/n 2537903-1611
ECHO -
ECHO - along with a formatted 3 1/2" diskette to a system which
ECHO - contains both a 5 1/4" inch floppy drive and a 3 1/2"
ECHO - drive and do the following.
ECHO -
ECHO - 1. Place the 3 1/2" diskette into the 3 1/2" drive
ECHO - 2. Place the INSTALLATION DISKETTE into the floppy drive
ECHO - 3. COPY *.* the INSTALLATION DISKETTE to the 3 1/2" drive
ECHO - 4. Place the AUTOLOAD DISKETTE into the floppy drive
ECHO - 5. COPY *.* the AUTOLOAD DISKETTE to the 3 1/2" drive
ECHO - 6. Remove the 3 1/2" diskette and label:
ECHO - "PC Scheme 3 1/2" Installation Diskette"
ECHO -
ECHO - After completing the above procedure, the PC Scheme build
ECHO - will be complete.
:finished

108
schbuild.bat Normal file
View File

@ -0,0 +1,108 @@
: =====> SCHBUILD.BAT
rem SCHBUILD.BAT - Get all the PC SCHEME source files in
rem the proper places for the build.
cd \build
path = \tools;\pcs;\
rem
rem Copy source code
rem
copy a:\tools \tools
copy \tools\*.lib \lib
copy \tools\*.obj \lib
if "%1" == "protected" goto getrest
copy a:\edwin \build\edwin
copy a:\scoops \build\scoops
copy \tools\pboot.fsl \pcs
:getrest
copy a:*.*
rem
rem Remove the PC Scheme source diskette #1 from drive A: and
rem replace it with source diskette #2.
rem
pause
if "%1" == "protected" goto getrest2
copy a:\sources \build\sources
copy a:\xli \build\xli
copy a:\newpcs \build\newpcs
:getrest2
copy a:*.*
rem
rem Remove the PC Scheme source diskette #2 from drive A: and
rem replace it with source diskette #3.
rem
pause
copy a:*.*
rem
rem Remove the PC Scheme source diskette #3 from drive A: and
rem replace it with source diskette #4.
rem
pause
copy a:*.*
if "%1" == "skip" goto skip
if "%1" == "skip2" goto skip2
rem
rem Remove the PC Scheme source diskette #4 from drive A: and
rem replace it with the Microsoft Macro Assembler, version 4.0 diskette.
rem
pause
CD \TOOLS
COPY A:MASM.EXE /V
COPY A:LINK.EXE /V
COPY A:MAKE.EXE /V
COPY A:LIB.EXE /v
rem
rem Remove the Macro Assembler diskette from drive A: and
rem replace it with the Lattice C compiler, version 3.0, diskette #1.
pause
COPY A:LC.EXE /V
COPY A:LC1.EXE /V
COPY A:LC2.EXE /V
CD \TOOLS
rem
rem Remove the Lattice C compiler, diskette #1, from drive A: and
rem replace it with the Lattice C compiler version 3.0, diskette #3.
rem
pause
CD \LIB
COPY A:LCS.LIB LC.LIB /V
COPY A:LCMS.LIB LCM.LIB /V
COPY A:CS.OBJ C.OBJ /V
CD \TOOLS
rem
rem Remove the Lattice C compiler, diskette #3, from drive A: and
rem replace it with the Dater diskette.
rem
pause
copy a:dater.com /v
:
:skip
:
rem
rem Remove the Dater diskette from drive A:
if "%1" == "protected" goto skip3
rem and replace it with the PC Scheme version 3.02 Installation
rem diskette. Any notices about "unable to create directory" can
rem be ignored.
rem
pause
:
command /c a:install e: \pcs W
:
:skip2
:
rem
rem Remove any diskettes that may be in the drives.
rem
pause
:skip3
rem
rem All files are now in their proper places.
rem
rem Press the RETURN key to start the build proper.
pause
cd \build
schbuil2 %1


135
scpsdemo.s Normal file
View File

@ -0,0 +1,135 @@
;
; This is an example of using SCOOPS. Please refer to chapter 5 in the
; Language Reference Manual for TI Scheme.
;
; The first thing that needs to be done is to define classes for different
; types. We will define three types, points, lines and rectangles.
(load "scoops.fsl")
;;;
;;; Point, Line and Rectangle
;;;
;;;
;;; Class POINT
;;;
(define-class point
(instvars (x (active 0 () move-x))
(y (active 0 () move-y))
(color (active 'yellow () change-color)))
(options settable-variables
inittable-variables))
(compile-class point) ; see page 45 in the language reference manual
;;;
;;; Class LINE
;;;
(define-class line
(instvars (len (active 50 () change-length))
(dir (active 0 () change-direction)))
(mixins point) ; inherit x, y, and color from point class.
(options settable-variables))
(compile-class line)
;;;
;;; Class RECTANGLE
;;;
(define-class rectangle
(instvars (height (active 60 () change-height)))
(mixins line) ; inherit color and width (len) from line
(options settable-variables))
(compile-class rectangle)
; In order to have an occurance of a class you will need to use the
; MAKE-INSTANCE procedure. For example:
; (define p1 (make-instance point))
; Then to change parts of the class use the send function. For example
; to change the color of the point previously defined:
; (send p1 change "color" 'cyan)
;
;;;
;;; Methods for POINT
;;;
(define-method (point erase) ()
(set-pen-color! 'black)
(draw))
(define-method (point draw) ()
(draw-point x y))
; having both a draw and redraw function here may seem to be unnecessary.
; you will see why both are needed as we continue
(define-method (point redraw) ()
(set-pen-color! color)
(draw))
(define-method (point move-x) (new-x)
(erase)
(set! x new-x)
(redraw)
new-x)
(define-method (point move-y) (new-y)
(erase)
(set! y new-y)
(redraw)
new-y)
(define-method (point change-color) (new-color)
(erase)
(set! color new-color)
(redraw)
new-color)
;;;
;;; Methods for LINE
;;;
; inherit erase, redraw, move-x, move-y and change-color from point.
(define-method (line draw) ()
(position-pen x y)
(draw-line-to (truncate (+ x (* len (cos dir))))
(truncate (+ y (* len (sin dir))))))
(define-method (line change-length) (new-length)
(erase)
(set! len new-length)
(redraw)
new-length)
(define-method (line change-direction) (new-dir)
(erase)
(set! dir new-dir)
(redraw)
new-dir)
;;;
;;; Methods for RECTANGLE
;;;
; inherit erase, redraw, move-x, move-y and change-color from point.
(define-method (rectangle draw) ()
(position-pen x y)
(draw-line-to (+ x len) y)
(draw-line-to (+ x len) (+ y height))
(draw-line-to x (+ y height))
(draw-line-to x y))
(define-method (rectangle change-height) (new-height)
(erase)
(set! height new-height)
(redraw)
new-height)


239
scsend.scm Normal file
View File

@ -0,0 +1,239 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 5/16/85 ;;;
;;; ;;;
;;; File : scsend.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains send routines coded in assembler ;;;
;;; for speed. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; send for various arguments
;;; 0 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-0)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 2 ; close r1,label, 2 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 12 8 ; load r3,r2
225 12 ; %sge r3,r3
25 12 ; push r3
52 4 0 ; call-closure r1, 0 args
24 8 ; pop r2
225 8 ; %sge r2,r2
59))))
;;; 1 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-1)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 3 ; close r1,label, 3 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 16 12 ; load r4,r3
225 16 ; %sge r4,r4
25 16 ; push r4
52 8 1 ; call-closure r2, 1 args
24 12 ; pop r3
225 12 ; %sge r3,r3
59))))
;;; 2 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-2)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 4 ; close r1,label, 4 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 20 16 ; load r5,r4
225 20 ; %sge r5,r5
25 20 ; push r5
52 12 2 ; call-closure r3, 2 args
24 16 ; pop r4
225 16 ; %sge r4,r4
59))))
;;; 3 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-3)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 5 ; close r1,label, 5 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 24 20 ; load r6,r5
225 24 ; %sge r6,r6
25 24 ; push r6
52 16 3 ; call-closure r4, 3 args
24 20 ; pop r5
225 20 ; %sge r5,r5
59))))
;;; 4 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-4)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 6 ; close r1,label, 6 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 28 24 ; load r7,r6
225 28 ; %sge r7,r7
25 28 ; push r7
52 20 4 ; call-closure r5, 4 args
24 24 ; pop r6
225 24 ; %sge r6,r6
59))))
;;; 5 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-5)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 7 ; close r1,label, 7 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 32 28 ; load r8,r7
225 32 ; %sge r8,r8
25 32 ; push r8
52 24 5 ; call-closure r6, 5 args
24 28 ; pop r7
225 28 ; %sge r7,r7
59))))
;;; 6 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-6)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 8 ; close r1,label, 8 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 36 32 ; load r9,r8
225 36 ; %sge r9,r9
25 36 ; push r9
52 28 6 ; call-closure r7, 6 args
24 32 ; pop r8
225 32 ; %sge r8,r8
59))))
;;; 7 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-7)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 9 ; close r1,label, 9 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 40 36 ; load r10,r9
225 40 ; %sge r10,r10
25 40 ; push r10
52 32 7 ; call-closure r8, 7 args
24 36 ; pop r9
225 36 ; %sge r9,r9
59))))
;;; 8 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-8)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 10 ; close r1,label, 10 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 44 40 ; load r11,r10
225 44 ; %sge r11,r11
25 44 ; push r11
52 36 8 ; call-closure r9, 8 args
24 40 ; pop r10
225 40 ; %sge r10,r10
59))))
;;; 9 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-9)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 11 ; close r1,label, 11 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 48 40 ; load r12,r11
225 48 ; %sge r12,r12
25 48 ; push r12
52 40 9 ; call-closure r10, 9 args
24 44 ; pop r11
225 44 ; %sge r11,r11
59))))
;;; 10 args
(%execute (quote (pcs-code-block 1 30
(scoop-send-handler-10)
( 1 4 0 ; load-constant r1,c0
60 4 7 0 12 ; close r1,label, 12 args
31 4 0 ; define!
1 4 0 ; load-constant r1,c0
59 ; exit
;label
0 52 44 ; load r13,r12
225 52 ; %sge r13,r13
25 52 ; push r13
52 44 10 ; call-closure r11, 10 args
24 48 ; pop r12
225 48 ; %sge r12,r12
59))))


65
send.scm Normal file
View File

@ -0,0 +1,65 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ;;;
;;; S c o o p s ;;;
;;; ;;;
;;; (c) Copyright 1985 Texas Instruments Incorporated ;;;
;;; All Rights Reserved ;;;
;;; ;;;
;;; File updated : 8/29/85 ;;;
;;; ;;;
;;; File : send.scm ;;;
;;; ;;;
;;; Amitabh Srivastava ;;;
;;; ;;;
;;; This file contains the send macro. This utilizes an ;;;
;;; internal hack for speed. ;;;
;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
(macro send
(let ((names (vector 'scoop-send-handler-0
'scoop-send-handler-1
'scoop-send-handler-2
'scoop-send-handler-3
'scoop-send-handler-4
'scoop-send-handler-5
'scoop-send-handler-6
'scoop-send-handler-7
'scoop-send-handler-8
'scoop-send-handler-9
'scoop-send-handler-10)))
(lambda (e)
(let ((args (cdddr e)))
(let ((fn (vector-ref names (length args)))
(msg (caddr e))
(env (cadr e)))
(list 'let
(list (list '%sc-env env))
(append (cons fn args)
(list (list 'access msg '%sc-env) '%sc-env))))))))
;;; send-if-handles
(macro send-if-handles
(lambda (e)
(let ((obj (cadr e))
(msg (caddr e))
(args (cdddr e)))
(list 'let
(list (list '%sc-env obj))
(list 'if
(list 'assq
(list 'quote msg)
'(%sc-method-structure (access %sc-class %sc-env)))
(cons 'send (cons '%sc-env (cddr e)))
'())))))


BIN
tools/dater.com Normal file
View File

Binary file not shown.

BIN
tools/lc.lib Normal file
View File

Binary file not shown.

BIN
tools/lc1.exe Normal file
View File

Binary file not shown.

BIN
tools/lc2.exe Normal file
View File

Binary file not shown.

BIN
tools/lcm.lib Normal file
View File

Binary file not shown.

BIN
tools/link.exe Normal file
View File

Binary file not shown.

BIN
tools/make.exe Normal file
View File

Binary file not shown.

BIN
tools/mapsym.exe Normal file
View File

Binary file not shown.

Some files were not shown because too many files have changed in this diff Show More