commit e5f37aa17305ae00a46fc4c7bf6fb5458efa7244 Author: Lassi Kortela Date: Sat May 20 12:57:04 2023 +0300 Unpack disk1.tgz diff --git a/class.scm b/class.scm new file mode 100644 index 0000000..97c56ef --- /dev/null +++ b/class.scm @@ -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))))) + \ No newline at end of file diff --git a/compile.dem b/compile.dem new file mode 100644 index 0000000..e3aa62c --- /dev/null +++ b/compile.dem @@ -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) + \ No newline at end of file diff --git a/coscoops.scm b/coscoops.scm new file mode 100644 index 0000000..881ceaa --- /dev/null +++ b/coscoops.scm @@ -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) \ No newline at end of file diff --git a/debug.scm b/debug.scm new file mode 100644 index 0000000..80219ef --- /dev/null +++ b/debug.scm @@ -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)) + )) + \ No newline at end of file diff --git a/demstart.scm b/demstart.scm new file mode 100644 index 0000000..609ee01 --- /dev/null +++ b/demstart.scm @@ -0,0 +1,4 @@ + +(start-tutorial) +(demo) + \ No newline at end of file diff --git a/do_auto.bat b/do_auto.bat new file mode 100644 index 0000000..3613e5d --- /dev/null +++ b/do_auto.bat @@ -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 \ No newline at end of file diff --git a/do_edwin.bat b/do_edwin.bat new file mode 100644 index 0000000..43ed7cf --- /dev/null +++ b/do_edwin.bat @@ -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 diff --git a/do_pcs.bat b/do_pcs.bat new file mode 100644 index 0000000..4cbda32 --- /dev/null +++ b/do_pcs.bat @@ -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 \ No newline at end of file diff --git a/do_scoop.bat b/do_scoop.bat new file mode 100644 index 0000000..4200a3f --- /dev/null +++ b/do_scoop.bat @@ -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 diff --git a/do_util.bat b/do_util.bat new file mode 100644 index 0000000..6982cf2 --- /dev/null +++ b/do_util.bat @@ -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 \ No newline at end of file diff --git a/edwin/allcoms1.scm b/edwin/allcoms1.scm new file mode 100644 index 0000000..cab7938 --- /dev/null +++ b/edwin/allcoms1.scm @@ -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))) + + + \ No newline at end of file diff --git a/edwin/allcoms2.scm b/edwin/allcoms2.scm new file mode 100644 index 0000000..872ff18 --- /dev/null +++ b/edwin/allcoms2.scm @@ -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)))) + + + + + \ No newline at end of file diff --git a/edwin/allcoms3.scm b/edwin/allcoms3.scm new file mode 100644 index 0000000..30a5fce --- /dev/null +++ b/edwin/allcoms3.scm @@ -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))) + + diff --git a/edwin/argred.scm b/edwin/argred.scm new file mode 100644 index 0000000..38126b9 --- /dev/null +++ b/edwin/argred.scm @@ -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)))))) + + \ No newline at end of file diff --git a/edwin/argredp.scm b/edwin/argredp.scm new file mode 100644 index 0000000..5810b4c --- /dev/null +++ b/edwin/argredp.scm @@ -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))))) + + \ No newline at end of file diff --git a/edwin/autoload.scm b/edwin/autoload.scm new file mode 100644 index 0000000..ab9c77d --- /dev/null +++ b/edwin/autoload.scm @@ -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 +) + + \ No newline at end of file diff --git a/edwin/buffer.scm b/edwin/buffer.scm new file mode 100644 index 0000000..9b6608e --- /dev/null +++ b/edwin/buffer.scm @@ -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)))))) +;;; +;;; + + + + \ No newline at end of file diff --git a/edwin/bufset.scm b/edwin/bufset.scm new file mode 100644 index 0000000..b09a99e --- /dev/null +++ b/edwin/bufset.scm @@ -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)) + \ No newline at end of file diff --git a/edwin/bufsetp.scm b/edwin/bufsetp.scm new file mode 100644 index 0000000..32fcd9f --- /dev/null +++ b/edwin/bufsetp.scm @@ -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))) \ No newline at end of file diff --git a/edwin/charmac.scm b/edwin/charmac.scm new file mode 100644 index 0000000..ac67686 --- /dev/null +++ b/edwin/charmac.scm @@ -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)))))) + diff --git a/edwin/charset.scm b/edwin/charset.scm new file mode 100644 index 0000000..ecb1d1b --- /dev/null +++ b/edwin/charset.scm @@ -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)) + + + diff --git a/edwin/coedwin.scm b/edwin/coedwin.scm new file mode 100644 index 0000000..fac7a8d --- /dev/null +++ b/edwin/coedwin.scm @@ -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))) + + + + \ No newline at end of file diff --git a/edwin/coedwin2.scm b/edwin/coedwin2.scm new file mode 100644 index 0000000..206b50e --- /dev/null +++ b/edwin/coedwin2.scm @@ -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) + + + + \ No newline at end of file diff --git a/edwin/coedwin3.scm b/edwin/coedwin3.scm new file mode 100644 index 0000000..0dfef6c --- /dev/null +++ b/edwin/coedwin3.scm @@ -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) + + + + + \ No newline at end of file diff --git a/edwin/coedwin4.scm b/edwin/coedwin4.scm new file mode 100644 index 0000000..e9f4e5d --- /dev/null +++ b/edwin/coedwin4.scm @@ -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) + + + + \ No newline at end of file diff --git a/edwin/comfun.scm b/edwin/comfun.scm new file mode 100644 index 0000000..f64f77c --- /dev/null +++ b/edwin/comfun.scm @@ -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)) + + + + + diff --git a/edwin/commac.scm b/edwin/commac.scm new file mode 100644 index 0000000..c40f2f5 --- /dev/null +++ b/edwin/commac.scm @@ -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)))) + + + + \ No newline at end of file diff --git a/edwin/comtabv.scm b/edwin/comtabv.scm new file mode 100644 index 0000000..ca443f7 --- /dev/null +++ b/edwin/comtabv.scm @@ -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)))) + + \ No newline at end of file diff --git a/edwin/curr.scm b/edwin/curr.scm new file mode 100644 index 0000000..45b22a1 --- /dev/null +++ b/edwin/curr.scm @@ -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))) + \ No newline at end of file diff --git a/edwin/de.scm b/edwin/de.scm new file mode 100644 index 0000000..99aafa8 --- /dev/null +++ b/edwin/de.scm @@ -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) + '()))) + \ No newline at end of file diff --git a/edwin/demstart.scm b/edwin/demstart.scm new file mode 100644 index 0000000..609ee01 --- /dev/null +++ b/edwin/demstart.scm @@ -0,0 +1,4 @@ + +(start-tutorial) +(demo) + \ No newline at end of file diff --git a/edwin/doedwi2a.scm b/edwin/doedwi2a.scm new file mode 100644 index 0000000..62cb51d --- /dev/null +++ b/edwin/doedwi2a.scm @@ -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) + \ No newline at end of file diff --git a/edwin/doedwin1.scm b/edwin/doedwin1.scm new file mode 100644 index 0000000..a45219a --- /dev/null +++ b/edwin/doedwin1.scm @@ -0,0 +1,5 @@ +; this is the file "doedwin1.scm" + +(load "coedwin.scm") +(load "coedwin2.scm") + \ No newline at end of file diff --git a/edwin/doedwin2.scm b/edwin/doedwin2.scm new file mode 100644 index 0000000..bf8984a --- /dev/null +++ b/edwin/doedwin2.scm @@ -0,0 +1,5 @@ +; this is the file "doedwin2.scm" + +(load "coedwin.scm") +(load "coedwin3.scm") + \ No newline at end of file diff --git a/edwin/doedwin3.scm b/edwin/doedwin3.scm new file mode 100644 index 0000000..9f6d9bc --- /dev/null +++ b/edwin/doedwin3.scm @@ -0,0 +1,5 @@ +; this is the file "doedwin3.scm" + +(load "coedwin.scm") +(load "coedwin4.scm") + \ No newline at end of file diff --git a/edwin/dummy.scm b/edwin/dummy.scm new file mode 100644 index 0000000..0cea33b --- /dev/null +++ b/edwin/dummy.scm @@ -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)) + \ No newline at end of file diff --git a/edwin/dwind.scm b/edwin/dwind.scm new file mode 100644 index 0000000..dcaa281 --- /dev/null +++ b/edwin/dwind.scm @@ -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) + + \ No newline at end of file diff --git a/edwin/edinit.scm b/edwin/edinit.scm new file mode 100644 index 0000000..48b87cf --- /dev/null +++ b/edwin/edinit.scm @@ -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))) + \ No newline at end of file diff --git a/edwin/emacros.scm b/edwin/emacros.scm new file mode 100644 index 0000000..66cc89a --- /dev/null +++ b/edwin/emacros.scm @@ -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))) + + + + \ No newline at end of file diff --git a/edwin/incser.scm b/edwin/incser.scm new file mode 100644 index 0000000..005c0c3 --- /dev/null +++ b/edwin/incser.scm @@ -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))) +  \ No newline at end of file diff --git a/edwin/initkey.scm b/edwin/initkey.scm new file mode 100644 index 0000000..308a7cd --- /dev/null +++ b/edwin/initkey.scm @@ -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 + \ No newline at end of file diff --git a/edwin/initmac.scm b/edwin/initmac.scm new file mode 100644 index 0000000..854054f --- /dev/null +++ b/edwin/initmac.scm @@ -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))))))) \ No newline at end of file diff --git a/edwin/insert80.scm b/edwin/insert80.scm new file mode 100644 index 0000000..eab1b03 --- /dev/null +++ b/edwin/insert80.scm @@ -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))))) + + + + + diff --git a/edwin/io.scm b/edwin/io.scm new file mode 100644 index 0000000..4d39ddd --- /dev/null +++ b/edwin/io.scm @@ -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)"))) + + + \ No newline at end of file diff --git a/edwin/kill1.scm b/edwin/kill1.scm new file mode 100644 index 0000000..edd3388 --- /dev/null +++ b/edwin/kill1.scm @@ -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))) + + \ No newline at end of file diff --git a/edwin/kill2.scm b/edwin/kill2.scm new file mode 100644 index 0000000..2ab1fd0 --- /dev/null +++ b/edwin/kill2.scm @@ -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)) + + \ No newline at end of file diff --git a/edwin/ldall.scm b/edwin/ldall.scm new file mode 100644 index 0000000..d3eff14 --- /dev/null +++ b/edwin/ldall.scm @@ -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)) + \ No newline at end of file diff --git a/edwin/ldchset.scm b/edwin/ldchset.scm new file mode 100644 index 0000000..8cfcbc7 --- /dev/null +++ b/edwin/ldchset.scm @@ -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")) + \ No newline at end of file diff --git a/edwin/lisp.scm b/edwin/lisp.scm new file mode 100644 index 0000000..d18e60f --- /dev/null +++ b/edwin/lisp.scm @@ -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)))))) + + + + + diff --git a/edwin/main.scm b/edwin/main.scm new file mode 100644 index 0000000..9149746 --- /dev/null +++ b/edwin/main.scm @@ -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)))) \ No newline at end of file diff --git a/edwin/marks.scm b/edwin/marks.scm new file mode 100644 index 0000000..1d3ac4b --- /dev/null +++ b/edwin/marks.scm @@ -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)))))) + + diff --git a/edwin/messages.scm b/edwin/messages.scm new file mode 100644 index 0000000..eec712a --- /dev/null +++ b/edwin/messages.scm @@ -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)))) + + \ No newline at end of file diff --git a/edwin/modeln.scm b/edwin/modeln.scm new file mode 100644 index 0000000..98d9efe --- /dev/null +++ b/edwin/modeln.scm @@ -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))))) + + + + + + + \ No newline at end of file diff --git a/edwin/motion.scm b/edwin/motion.scm new file mode 100644 index 0000000..e8b103e --- /dev/null +++ b/edwin/motion.scm @@ -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)))))) \ No newline at end of file diff --git a/edwin/newframe.scm b/edwin/newframe.scm new file mode 100644 index 0000000..b86e3d2 --- /dev/null +++ b/edwin/newframe.scm @@ -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") + + \ No newline at end of file diff --git a/edwin/nstring.scm b/edwin/nstring.scm new file mode 100644 index 0000000..be2db52 --- /dev/null +++ b/edwin/nstring.scm @@ -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))) + + \ No newline at end of file diff --git a/edwin/parens.scm b/edwin/parens.scm new file mode 100644 index 0000000..9f268ad --- /dev/null +++ b/edwin/parens.scm @@ -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)))) + \ No newline at end of file diff --git a/edwin/redisp1.scm b/edwin/redisp1.scm new file mode 100644 index 0000000..69fc71c --- /dev/null +++ b/edwin/redisp1.scm @@ -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 ((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))))) + + + \ No newline at end of file diff --git a/edwin/regops.scm b/edwin/regops.scm new file mode 100644 index 0000000..0716d99 --- /dev/null +++ b/edwin/regops.scm @@ -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))))) \ No newline at end of file diff --git a/edwin/ring.scm b/edwin/ring.scm new file mode 100644 index 0000000..533f0be --- /dev/null +++ b/edwin/ring.scm @@ -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))) + +) + \ No newline at end of file diff --git a/edwin/search1.scm b/edwin/search1.scm new file mode 100644 index 0000000..d884934 --- /dev/null +++ b/edwin/search1.scm @@ -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))))) + \ No newline at end of file diff --git a/edwin/search2.scm b/edwin/search2.scm new file mode 100644 index 0000000..d6819f2 --- /dev/null +++ b/edwin/search2.scm @@ -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))) \ No newline at end of file diff --git a/edwin/sentence.scm b/edwin/sentence.scm new file mode 100644 index 0000000..859f9f7 --- /dev/null +++ b/edwin/sentence.scm @@ -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))) + + + diff --git a/edwin/strcomp.scm b/edwin/strcomp.scm new file mode 100644 index 0000000..a141725 --- /dev/null +++ b/edwin/strcomp.scm @@ -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-ciregion + (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)))))))) \ No newline at end of file diff --git a/edwin/things.scm b/edwin/things.scm new file mode 100644 index 0000000..799b08b --- /dev/null +++ b/edwin/things.scm @@ -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?)) \ No newline at end of file diff --git a/edwin/toplevel.scm b/edwin/toplevel.scm new file mode 100644 index 0000000..d53e289 --- /dev/null +++ b/edwin/toplevel.scm @@ -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)) + + + + + + + + \ No newline at end of file diff --git a/edwin/transpos.scm b/edwin/transpos.scm new file mode 100644 index 0000000..3045344 --- /dev/null +++ b/edwin/transpos.scm @@ -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))))) + + + + \ No newline at end of file diff --git a/edwin/words.scm b/edwin/words.scm new file mode 100644 index 0000000..93778e7 --- /dev/null +++ b/edwin/words.scm @@ -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))) + \ No newline at end of file diff --git a/expand.scm b/expand.scm new file mode 100644 index 0000000..0294329 --- /dev/null +++ b/expand.scm @@ -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 '())))) + + + + \ No newline at end of file diff --git a/frame.scm b/frame.scm new file mode 100644 index 0000000..221e715 --- /dev/null +++ b/frame.scm @@ -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 )\" !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))))) + + \ No newline at end of file diff --git a/inht.scm b/inht.scm new file mode 100644 index 0000000..11da096 --- /dev/null +++ b/inht.scm @@ -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)))) + + \ No newline at end of file diff --git a/install.bat b/install.bat new file mode 100644 index 0000000..eaa17bd --- /dev/null +++ b/install.bat @@ -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. diff --git a/install2.bat b/install2.bat new file mode 100644 index 0000000..c213c29 --- /dev/null +++ b/install2.bat @@ -0,0 +1,71 @@ +: +: PC Scheme installation batch stream, part 2 +: call from part 1: install2 +: +: 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 *************** + \ No newline at end of file diff --git a/install3.bat b/install3.bat new file mode 100644 index 0000000..1a880bb --- /dev/null +++ b/install3.bat @@ -0,0 +1,14 @@ +: +: PC Scheme installation batch stream, part 2 +: call from part 1: install2 +: +: 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" = \ No newline at end of file diff --git a/instance.scm b/instance.scm new file mode 100644 index 0000000..9c9a42f --- /dev/null +++ b/instance.scm @@ -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))))))))) + + \ No newline at end of file diff --git a/instpro.bat b/instpro.bat new file mode 100644 index 0000000..a48798c --- /dev/null +++ b/instpro.bat @@ -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. + \ No newline at end of file diff --git a/interf.scm b/interf.scm new file mode 100644 index 0000000..afbfc52 --- /dev/null +++ b/interf.scm @@ -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) + '()) + )))))) + \ No newline at end of file diff --git a/ldscoop.scm b/ldscoop.scm new file mode 100644 index 0000000..0264d17 --- /dev/null +++ b/ldscoop.scm @@ -0,0 +1,3 @@ +(define load-scoops + (lambda () + 'SCOOPS-LOADED)) \ No newline at end of file diff --git a/master.bat b/master.bat new file mode 100644 index 0000000..3cea707 --- /dev/null +++ b/master.bat @@ -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 + \ No newline at end of file diff --git a/memory.bat b/memory.bat new file mode 100644 index 0000000..5022903 --- /dev/null +++ b/memory.bat @@ -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 + \ No newline at end of file diff --git a/meth2.scm b/meth2.scm new file mode 100644 index 0000000..c504ee1 --- /dev/null +++ b/meth2.scm @@ -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))))) + + + + diff --git a/methods.scm b/methods.scm new file mode 100644 index 0000000..77dd582 --- /dev/null +++ b/methods.scm @@ -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)))) diff --git a/readme.1 b/readme.1 new file mode 100644 index 0000000..be169da --- /dev/null +++ b/readme.1 @@ -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 diff --git a/readme.2 b/readme.2 new file mode 100644 index 0000000..b52ced7 --- /dev/null +++ b/readme.2 @@ -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. + \ No newline at end of file diff --git a/readme.pro b/readme.pro new file mode 100644 index 0000000..9726df4 --- /dev/null +++ b/readme.pro @@ -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. diff --git a/schbuil2.bat b/schbuil2.bat new file mode 100644 index 0000000..08edb44 --- /dev/null +++ b/schbuil2.bat @@ -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 \ No newline at end of file diff --git a/schbuild.bat b/schbuild.bat new file mode 100644 index 0000000..946551d --- /dev/null +++ b/schbuild.bat @@ -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 + \ No newline at end of file diff --git a/scpsdemo.s b/scpsdemo.s new file mode 100644 index 0000000..d483ac8 --- /dev/null +++ b/scpsdemo.s @@ -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) + + \ No newline at end of file diff --git a/scsend.scm b/scsend.scm new file mode 100644 index 0000000..eb66185 --- /dev/null +++ b/scsend.scm @@ -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)))) + + + + + \ No newline at end of file diff --git a/send.scm b/send.scm new file mode 100644 index 0000000..09150bd --- /dev/null +++ b/send.scm @@ -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))) + '()))))) + + \ No newline at end of file diff --git a/tools/dater.com b/tools/dater.com new file mode 100644 index 0000000..837d996 Binary files /dev/null and b/tools/dater.com differ diff --git a/tools/lc.lib b/tools/lc.lib new file mode 100644 index 0000000..389e8cc Binary files /dev/null and b/tools/lc.lib differ diff --git a/tools/lc1.exe b/tools/lc1.exe new file mode 100644 index 0000000..7fdf222 Binary files /dev/null and b/tools/lc1.exe differ diff --git a/tools/lc2.exe b/tools/lc2.exe new file mode 100644 index 0000000..84663cd Binary files /dev/null and b/tools/lc2.exe differ diff --git a/tools/lcm.lib b/tools/lcm.lib new file mode 100644 index 0000000..fa3080d Binary files /dev/null and b/tools/lcm.lib differ diff --git a/tools/link.exe b/tools/link.exe new file mode 100644 index 0000000..7b7eb21 Binary files /dev/null and b/tools/link.exe differ diff --git a/tools/make.exe b/tools/make.exe new file mode 100644 index 0000000..403eaad Binary files /dev/null and b/tools/make.exe differ diff --git a/tools/mapsym.exe b/tools/mapsym.exe new file mode 100644 index 0000000..39c6595 Binary files /dev/null and b/tools/mapsym.exe differ diff --git a/tools/masm.exe b/tools/masm.exe new file mode 100644 index 0000000..5ae6c02 Binary files /dev/null and b/tools/masm.exe differ diff --git a/tools/pboot.fsl b/tools/pboot.fsl new file mode 100644 index 0000000..51fba31 Binary files /dev/null and b/tools/pboot.fsl differ diff --git a/tools/pkarc.com b/tools/pkarc.com new file mode 100644 index 0000000..3c599d6 Binary files /dev/null and b/tools/pkarc.com differ diff --git a/tools/pkxarc.com b/tools/pkxarc.com new file mode 100644 index 0000000..ef9f3dd Binary files /dev/null and b/tools/pkxarc.com differ diff --git a/tools/touch.exe b/tools/touch.exe new file mode 100644 index 0000000..6db95a8 Binary files /dev/null and b/tools/touch.exe differ diff --git a/tools/vers8042.com b/tools/vers8042.com new file mode 100644 index 0000000..cd40cc4 Binary files /dev/null and b/tools/vers8042.com differ diff --git a/tutorial.scm b/tutorial.scm new file mode 100644 index 0000000..da45db7 --- /dev/null +++ b/tutorial.scm @@ -0,0 +1,758 @@ +;;; ============================================= +;;; The Tutorial Engine +;;; +;;; Bob Beal +;;; ============================================= + + +;;; Auxiliary macros ========================= + +;; these might be useful anywhere + +;; form: (push value var) +;; push "value" onto list stored at "var" +;; not a generalized-variable push +(macro push + (lambda (e) + (let ((value (cadr e)) + (var (caddr e))) + `(set! ,var (cons ,value ,var))))) + +;; form: (in-bounds? low value high) +;; tests "low" <= "value" < "high" +(macro in-bounds? + (lambda (e) + (let ((lo (cadr e)) + (x (caddr e)) + (hi (cadddr e))) + `(and (<=? ,lo ,x) (number ,e))))) + +;; form: (set-frame-visited! frame true-or-false) +(macro set-frame-visited! + (lambda (e) + (let ((e (cadr e)) (value (caddr e))) + `(vector-set! (tutorial-visited-list *tutorial*) + (frame->number ,e) + ,value)))) + +;; form: (frame->number frame) +;; given a frame, return its number +(macro frame->number + (lambda (e) + (let ((e (cadr e))) + `(cdr (assq (frame-name ,e) (tutorial-name-list *tutorial*)))))) + +;; form: (name->frame name) +;; given a frame name, return its frame +(macro name->frame + (lambda (e) + (let ((name (cadr e))) + `(nth-frame (cdr (assq ,name (tutorial-name-list *tutorial*))))))) + +;; for the executing tutorial ------------------------- + +;; form: (unstarted-tutorial?) +;; has this tutorial been run since loading? +(macro unstarted-tutorial? + (lambda (e) + '(not (vector? (tutorial-frame-list *tutorial*))))) + +;; form: (tutorial-length) +;; returns the number of frames in the tutorial +(macro tutorial-length + (lambda (e) + '(vector-length (tutorial-frame-list *tutorial*)))) + +;; form: (frame-list) +;; returns the tutorial's frame-list +(macro frame-list + (lambda (e) + '(tutorial-frame-list *tutorial*))) + +;; form: (frame-number) +;; returns the frame-number of the current frame +(macro frame-number + (lambda (e) + '(tutorial-frame-number *tutorial*))) + +;; form: (current-frame) +;; returns the current frame +(macro current-frame + (lambda (e) + '(vector-ref (tutorial-frame-list *tutorial*) + (tutorial-frame-number *tutorial*)))) + +;; form: (demo-writeln-extensions) +;; returns the function that handles text in a text zone +(macro demo-writeln-extensions + (lambda (e) + `(tutorial-writeln-extensions *tutorial*))) + +;; this macro defines one "frame" ------------------------- + +(macro frame + (lambda (e) + `(push ',e (tutorial-frame-list *tutorial*)))) + +(macro frame-during-edit + (lambda (e) + `(set! *frame* ',e))) + +;; for popup windows (menus, help screens) ------------------------- + +;; form: (with-popup-window dummy-window-var +;; TITLE string +;; TEXT-ATTRIBUTES attributes +;; BORDER-ATTRIBUTES attributes +;; POSITION (row . column) +;; SIZE (rows . columns) +;; &BODY &body) +;; The keywords aren't evaluated but the associated values are. +(macro with-popup-window + (lambda (e) + (let ((w (cadr e)) + (title (cadr (memq 'title e))) + (text-attributes (cadr (memq 'text-attributes e))) + (border-attributes (cadr (memq 'border-attributes e))) + (position (cadr (memq 'position e))) + (size (cadr (memq 'size e))) + (body (cdr (memq '&body e)))) + `(let ((,w (make-window ,title #!true))) + ,(when text-attributes + `(window-set-attribute! ,w 'text-attributes ,text-attributes)) + ,(when border-attributes + `(window-set-attribute! ,w 'border-attributes ,border-attributes)) + ,(when position + `(window-set-position! ,w (car ,position) (cdr ,position))) + ,(when size + `(window-set-size! ,w (car ,size) (cdr ,size))) + (window-popup ,w) + (begin0 + (begin ,@body) + (window-popup-delete ,w)))))) + +;; other ------------------------- + +;; form: (center-at msg) +;; returns the column at which cursor must be positioned to +;; center msg on console window +(macro center-at + (lambda (e) + (let ((msg (cadr e))) + `(- 40 (floor (/ (string-length ,msg) 2)))))) + +;;; Auxiliary functions ========================= + +(define ATTR + (let ((attrs-ibm '((blink . 128) (bkg-white . 112) + (bkg-brown . 96) (bkg-magenta . 80) (bkg-cyan . 48) + (bkg-red . 64) (bkg-green . 32) (bkg-blue . 16) + (light-white . 15) + (yellow . 14) (light-magenta . 13) (light-red . 12) + (light-cyan . 11) (light-green . 10) (light-blue . 9) + (gray . 8) (white . 7) (brown . 6) (magenta . 5) + (red . 4) (cyan . 3) (green . 2) (blue . 1) (BLACK . 0))) + (attrs-ti '((ALTCHAR . 128) (BLINK . 64) + (UNDERLINE . 32) (REVERSE . 16) (NODSP . -8) + (WHITE . 7) (YELLOW . 6) (cyan . 5) (GREEN . 4) + (PURPLE . 3) (RED . 2) (blue . 1) (BLACK . 0))) + (default-attrs-ibm 15) + (default-attrs-ti 15) + (prime-ibm 0) + (prime-ti 8)) + (lambda x + (let ((work-fn + (LAMBDA (attrs default acc) + (COND + ((NULL? X) + (SET! ACC default)) + ((NUMBER? (CAR X)) + (SET! ACC (CAR X))) + (else + (MAPC + (LAMBDA (X) + (AND (ASSOC X ATTRS) + (SET! ACC (+ ACC (CDR (ASSOC X ATTRS)))))) X))) + (and (=? pcs-machine-type 1) ;keep text enabled in TI mode + (=? acc prime-ti) + (set! acc default)) + acc))) + (if (=? pcs-machine-type 1) + (work-fn attrs-ti default-attrs-ti prime-ti) + (work-fn attrs-ibm default-attrs-ibm prime-ibm)))))) + +(define demo-writeln + (lambda (x w) ;x=string of >=1 words, w=window + (mapc (lambda (word) + (cond (((demo-writeln-extensions) word w)) + (else (display word w)))) + (let loop ((word-list nil) (s x)) + (let ((n (substring-find-next-char-in-set s 0 (string-length s) " "))) + (cond (n (loop (cons (substring s 0 (1+ n)) word-list) + (substring s (1+ n) (string-length s)))) + (else (reverse (cons (string-append s " ") word-list))))))))) + +;; a "filler" function +(define (do-nothing . x) nil) + +;(define visited +; (lambda () +; (vector->list (tutorial-visited-list *tutorial*)))) + +;;; Advertised public interface ========================= + +;; Global variables ------------------------- + +(define *data-item*) +(define *evaled-data-item*) +(define *tutorial*) +(define *auto-tutorial?* nil) +(define *debug-tutorial* nil) ;not advertised +(define *frame* nil) ; " + +;; Exported functions ------------------------- + +(define start-tutorial) +(define resume-tutorial) + +;;; the tutorial "engine" ========================= + +(letrec + ((alert + (lambda (msg) + (with-popup-window w + title "" + size `(1 . ,(string-length msg)) + position `(5 . ,(center-at msg)) + border-attributes (attr 'red) + text-attributes (if (=? pcs-machine-type 1) + (attr 'red 'reverse) + (attr 'black 'bkg-red)) + &body + (beep) + (display msg w) + (read-char)))) + (banner + (lambda () + (window-clear 'console) + (with-popup-window w + title "" + size '(22 . 78) + position '(1 . 1) + &body + (let ((clear-msg "Press any key to continue.") + (banner + `("Texas Instruments" + "proudly presents:" + "" + "A PC Scheme Tutorial" + "on" + ,@(cond ((string? (tutorial-name *tutorial*)) + (list (tutorial-name *tutorial*))) + ((pair? (tutorial-name *tutorial*)) + (tutorial-name *tutorial*)) + (else + (list "The Reliance of Programming on Thaumaturgy")))))) + (window-set-cursor! w 3 1) + (for-each (lambda (s) + (window-set-cursor! + w + (car (window-get-cursor w)) + (center-at s)) + (print s w) + (newline w)) + banner) + (window-set-cursor! + w + 21 + (center-at clear-msg)) + (display clear-msg w) + (tutorial-read-char))))) + (beep + (lambda () + (display (integer->char 7)))) + (busy-window + (let ((w (make-window nil nil))) + (window-set-size! w 1 20) + (window-set-attribute! w 'text-attributes (attr 'green 'blink)) + w)) + (calc-zone + (lambda (e) + (window-set-attribute! 'console 'text-attributes (attr 'green)) + (clear-rest-of-visited-list (frame->number e)) ;force reanalysis of environment + (execute-frame-item e #!true eval?) + (fresh-line) + (newline))) + (clear-rest-of-visited-list + (lambda (n) + (cond ((>=? n (tutorial-length))) + (else + (vector-set! (tutorial-visited-list *tutorial*) n #!false) + (clear-rest-of-visited-list (1+ n)))))) + (clear-visited-list + (lambda () + (vector-fill! (tutorial-visited-list *tutorial*) nil))) + (collect-index + (lambda () + (set! (tutorial-index *tutorial*) + (sort! + (let loop ((n 0) (acc nil)) + (cond ((>=? n (tutorial-length)) acc) + (else + (for-each (lambda (string) + (let ((index-item (assoc string acc))) + (cond (index-item + (append! index-item (list n))) + (else + (push (list string n) acc))))) + (frame-index-entry (nth-frame n))) + (loop (1+ n) acc)))) + (lambda (x y) + (string-ci=? n (tutorial-length)) + (set! (tutorial-name-list *tutorial*) acc)) + ((frame-name (nth-frame n)) + (loop (1+ n) (cons (cons (frame-name (nth-frame n)) + n) + acc))) + (else ;give it a name and try again + (set-frame-name! (nth-frame n) (gensym)) + (loop n acc)))))) + (collect-tc + (lambda () + (set! (tutorial-tc *tutorial*) + (sort! + (let loop ((n 0) (acc nil)) + (cond ((>=? n (tutorial-length)) + acc) + ((frame-tc-entry (nth-frame n)) + (loop (1+ n) + (cons (list n (frame-tc-entry (nth-frame n))) acc))) + (else + (loop (1+ n) acc)))))) + (when (>=? (length (tutorial-tc *tutorial*)) 21) + (error "Only 20 entries are allowed in the tutorial table of contents.")))) + (continue + (lambda () + (let ((bad-key-msg "Invalid key pressed. \"?\" provides help.")) + (fresh-line) + (display (integer->char 2)) + (let again ((ch (tutorial-read-char))) + (case ch + (#\? (again (help))) + (#\backspace nil) + ((#\e #\E) (again (if *debug-tutorial* + (edit) + (alert bad-key-msg)))) + ((#\i #\I) (index)) + ((#\p #\P) (again (previous-frame))) + ((#\q #\Q) (quit)) + ((#\return #\space #\n #\N) (again (next-frame))) + ((#\t #\T) (table-of-contents)) +; (nil nil) ;this doesn't work for some reason + (#!true nil) ;so use this instead + (else (again (alert bad-key-msg)))))))) + (display-title-window + (let ((blanks (make-string 15 #\space))) + (lambda () + (window-clear title-window) + (display blanks title-window) + (print (frame-number) title-window) + (print blanks title-window) + (when (frame-tc-entry (current-frame)) + (demo-writeln (frame-tc-entry (current-frame)) title-window) + (fresh-line title-window) + (newline title-window))))) + (do-tutorial + (named-lambda (loop) + (frame-1 (current-frame)) + (loop))) + (edit + (lambda () + (let ((prev-defn (getprop 'frame 'pcs*macro))) + (putprop 'frame (getprop 'frame-during-edit 'pcs*macro) 'pcs*macro) + (begin0 + (with-popup-window + w + title "Edit menu" + size '(12 . 34) + position '(3 . 45) + &body + (print (assq (frame-name (current-frame)) (tutorial-name-list *tutorial*)) w) + (print (string-append "Frame evaluation is: " (if eval? "ON" "OFF")) w) + (print "" w) + (print "E - call Edwin" w) + (print "R - replace" w) + (print "T - new toplevel" w) + (print "V - toggle frame evaluation" w) + (print "and all standard keys" w) + (print "" w) + (let again ((ch (read-char))) + (case ch + ((#\e #\E) + (edwin) + (again (read-char))) + ((#\r #\R) + (cond ((frame? *frame*) + (set-frame-name! *frame* (frame-name (current-frame))) + (set! (current-frame) *frame*) + #!true) + (else + (alert "Frame has bad format. Replace not done.")))) + ((#\t #\T) ;will this work? YES!! + (beep) + (print "((fluid q)) quits new toplevel" w) + (let ((prev-history (getprop '%pcs-stl-history %pcs-stl-history))) + (call/cc + (lambda (k) + (fluid-let ((scheme-top-level nil) + (q (lambda () (k 'end-top-level)))) + (reset-scheme-top-level) + (reset)))) + (putprop '%pcs-stl-history prev-history %pcs-stl-history) + #!true)) + ((#\v #\V) + (set! eval? (not eval?)) + #\E) ;force redisplay of edit menu + (else ch)))) + (putprop 'frame prev-defn 'pcs*macro))))) + (end-frame + '(frame + () + ("You have reached the end of the tutorial." + "Please press \"Q\" to exit."))) + (eval? #!true) ;var used in edit mode + (execute-frame-item + (lambda (e print? eval?) + (cond ((eq? (frame-visited? e) #!true)) + ((null? (frame-dependencies e)) + (frame-item-parser (frame-item e) print? eval?) + (set-frame-visited! e #!true)) + (else + (when print? + (window-set-position! busy-window + (car (window-get-cursor 'console)) + 0) + (window-popup busy-window) ;popdown when output occurs + (display "Evaluating..." busy-window)) + (for-each (lambda (e) + (set! e (name->frame e)) + (execute-frame-item e #!false eval?)) + (frame-dependencies e)) +; (when print? +; (window-popup-delete busy-window)) + (frame-item-parser (frame-item e) print? eval?) + (set-frame-visited! e #!true))))) + (frame-1 + (lambda (e) + (window-clear 'console) + (display-title-window) + (when (frame-lines-before e) (text-zone (frame-lines-before e))) + (when (frame-item e) (calc-zone e)) + (when (frame-lines-after e) (text-zone (frame-lines-after e))) + (continue))) + (frame-item-parser + (lambda (cmds print? eval?) + (let loop ((cmds cmds)) + (cond ((null? cmds)) + (else + (case (car cmds) + (:data (set! *data-item* (cadr cmds)) + (set! cmds (cdr cmds))) +; (:read (set! *data-item* (read data-port))) + (:data-eval + (when eval? (set! *evaled-data-item* (eval *data-item*)))) + (:eval + (when eval? (eval (cadr cmds))) + (set! cmds (cdr cmds))) +; (:skip (read data-port)) + ((:pp-data :pp-evaled-data :yields :fresh-line :output) + (when print? + (window-popup-delete busy-window) ;popdown busy msg + (case (car cmds) + (:output (when eval? (eval (cadr cmds))) + (set! cmds (cdr cmds))) + (:pp-data (pp *data-item*)) + (:pp-evaled-data (pp *evaled-data-item*)) + (:yields (display " ---> ")) + (:fresh-line (fresh-line))))) + (else nil)) + (loop (cdr cmds))))))) + (help + (lambda () + (with-popup-window w + title "Help menu" + size '(12 . 34) + position '(3 . 45) + &body + (print "? - This menu" w) + (print "BACKSPACE - refresh screen" w) + (when *debug-tutorial* + (print "E - edit tutorial" w)) + (print "I - index" w) + (print "N, RETURN, SPACE - next frame" w) + (print "P - previous frame" w) + (print "T - table of contents" w) + (print "Q - quit tutorial" w) + (read-char)))) + (index + (lambda () + (let ((prompt-msg "Please type a frame number, nil, U, or D, then RETURN: ")) + (with-popup-window + w + title "Index" + size '(22 . 78) + position '(1 . 1) + &body + (let show-one-page ((n 0)) + (window-clear w) + (let vloop ((start (list-tail (tutorial-index *tutorial*) n)) + (end (list-tail (tutorial-index *tutorial*) (+ n 20)))) + (cond ((eq? start end)) + (else + (display " " w) + (display (caar start) w) + (let hloop ((tab-to 27) + (frame-no-list (cdar start))) + (cond ((null? frame-no-list)) + (else + (tab (current-column w) tab-to 4 w) + (display (car frame-no-list) w) + (display " " w) + (hloop (+ tab-to 4) (cdr frame-no-list))))) + (newline w) + (vloop (cdr start) end)))) + (window-set-cursor! 'console 22 (center-at prompt-msg)) + (display prompt-msg) + (let ((frame-no (read))) + (flush-input) + (cond ((and (number? frame-no) + (in-bounds? 0 frame-no (tutorial-length))) + (clear-visited-list) + (set! (frame-number) frame-no)) + ((eq? frame-no 'U) + (show-one-page (if (=? (+ n 20) (length (tutorial-index *tutorial*))) + n + (+ n 20)))) + ((and *debug-tutorial* + (assq frame-no (tutorial-name-list *tutorial*))) + (clear-visited-list) + (set! (frame-number) (cdr (assq frame-no (tutorial-name-list *tutorial*)))))) + #!true)))))) + (init-tutorial + (lambda (tutorial resume) + (when (not (equal? *debug-tutorial* '(#\?))) ;make it harder to enter debug mode + (set! *debug-tutorial* nil)) + (when tutorial + (set! *tutorial* tutorial)) + (when (not (tutorial? *tutorial*)) + (alert "There is no tutorial available.") + (quit)) + (when (and (unstarted-tutorial?) + resume) + (alert "You cannot resume an unstarted tutorial. Use (START-TUTORIAL).") + (quit)) + (when (unstarted-tutorial?) + (set! (frame-list) + (list->vector (cons start-frame + (reverse! (cons end-frame + (frame-list)))))) + (set! (tutorial-visited-list *tutorial*) + (make-vector (vector-length (frame-list)))) + (set! (frame-number) 0) + (set! eval? #!true) + (collect-names) + (collect-tc) + (collect-index)) + (begin ;make sure entire screen gets erased + (set-video-mode! 3) ;works for both TI and IBM CGA modes + (window-set-position! 'console 0 0) + (window-set-size! 'console 24 80) ;leave status line + (window-set-attribute! 'console 'text-attributes (attr)) + (window-clear 'console)) + (when (not resume) + (banner) + (set! (frame-number) 0) + (clear-visited-list)) + (call/cc + (lambda (k) + (set! quit-k (lambda () + (k nil))) + (call/cc (lambda (k) + (set! *user-error-handler* + (lambda x (user-error-handler k))))) + (do-tutorial))))) + (next-frame + (lambda () + (if (=? (frame-number) + (-1+ (tutorial-length))) + (if *auto-tutorial?* + #\q + (alert "You are on the last frame of the tutorial.")) + (begin (set! (frame-number) (1+ (frame-number))) + #!true)))) + (previous-frame + (lambda () + (if (zero? (frame-number)) + (alert "You are on the first frame of the tutorial.") + (begin (set! (frame-number) (-1+ (frame-number))) + #!true)))) + (print + (lambda (x w) + (display x w) + (newline w))) + (quit + (lambda () + (window-clear 'console) + (set! *user-error-handler* nil) + (quit-k))) + (quit-k do-nothing) ;the quit continuation + ;reassigned by init-tutorial + (start-frame + '(frame + () + () + (:data "A PC Scheme Tutorial" :pp-data) + ("The \"?\" is the help key." + "It displays a menu which tells you" + "about other important keys which enable you" + "to move around in the tutorial or to leave it." + "\"?\" or other single-keystroke keys are available" + "anytime you see the \"happy-face\" character towards" + "the bottom of the screen." + "Occasionally, typed input is requested." + "Typed input is" + "usually a number, or the atom NIL, followed by" + "the RETURN key." + "If you exit the tutorial in the middle, you can" + "continue from where you left off" + "(in the same session)" + "by typing (RESUME-TUTORIAL)." + "An \"Evaluating...\" message may appear while the" + "tutorial establishes" + "the proper execution environment for the examples in that" + "frame.") + () + "Directions for running the tutorial" + ("directions for running tutorial"))) + (tab + (lambda (cur goal multiple w) + (cond ((class ',class) + (%sc-set-name ,class ',new-name) + (set! (access ,new-name user-initial-environment) ,class) + (putprop ',new-name ,new-name '%class) + ',new-name)))) + +;;; (getcv class var) + +(macro getcv + (lambda (e) + (let ((class (cadr e)) + (var (caddr e))) + `(begin + (and (%sc-name->class ',class) + (%scoops-chk-class-compiled ',class ,class)) + (send (%sc-class-env ,class) ,(%sc-concat "GET-" var)))))) + +;;; (setcv class var val) + +(macro setcv + (lambda (e) + (let ((class (cadr e)) + (var (caddr e)) + (val (cadddr e))) + `(begin + (and (%sc-name->class ',class) + (%scoops-chk-class-compiled ',class ,class)) + (send (%sc-class-env ,class) ,(%sc-concat "SET-" var) ,val))))) + +;;; (class-compiled? class) + +(define class-compiled? + (lambda (class) + (%scoops-chk-class class) + (%sc-class-compiled class))) + + +;;; (class-of-object object) + +(define class-of-object + (lambda (obj) + (%sc-name (access %sc-class obj)))) + +;;; (name->class name) + +(define name->class + (lambda (name) + (%sc-name->class name))) + +;;; + +(define %sc-class-info + (lambda (fn) + (lambda (class) + (%scoops-chk-class class) + (mapcar car (fn class))))) + +;;; + +(define methods (%sc-class-info %sc-method-values)) + +;;; + +(define all-methods (%sc-class-info %sc-method-structure)) + +;;; + +(define classvars (%sc-class-info %sc-cv)) + +;;; + +(define all-classvars (%sc-class-info %sc-allcvs)) + +;;; + +(define instvars (%sc-class-info %sc-iv)) + +;;; + +(define all-instvars (%sc-class-info %sc-allivs)) + + +;;; + +(define mixins + (lambda (class) + (%scoops-chk-class class) + (%sc-mixins class))) \ No newline at end of file