mirror of
https://github.com/PDP-10/its.git
synced 2026-03-21 08:48:51 +00:00
799 lines
26 KiB
Plaintext
Executable File
799 lines
26 KiB
Plaintext
Executable File
;;; LISP Inferior-job Editing Package
|
||
|
||
(comment declarations and special variables)
|
||
|
||
(declare (special editor-jname editor-job null editor-usr-input editor-usr-output
|
||
lispt-read-loop crlf lispt-jname lispt-file
|
||
lispt-file-forced lispt-protect tty-return-prompt?
|
||
lispt-initial-sname lispt-text-string lispt-prompter
|
||
lispt-tty-to-ddt-msg lispt-tty-passing-msg tty-verbose
|
||
current-job tty-return-list default-tty-return-list
|
||
tty-passing-msg current-editor-buffer current-teco-buffer-block
|
||
roving-editor?)
|
||
(fixnum (examine-job fixnum))
|
||
(notype (deposit-job fixnum fixnum))
|
||
(*expr make-job load-job start-job job-returned-tty wait-for-job
|
||
deposit-job examine-job job-uset-write job-uset-read
|
||
set-job-start-adr usr-open-fix return-to-ddt
|
||
kill-job disown-job job-start-adr continue-job select-job
|
||
clear-tty-return set-jcl)
|
||
(genprefix /|lt))
|
||
|
||
(eval-when (eval compile)
|
||
(setq ibase 8)
|
||
(cond ((not (get '*uset 'macro))
|
||
(fasload lusets fasl dsk liblsp)))
|
||
(cond ((not (status feature lspmac))
|
||
(fasload lspmac fasl dsk liblsp)))
|
||
(setsyntax '/# 'macro '/#macro) ;enable #
|
||
(defun 6bit macro (x) (list 'car (list 'pnget (cadr x) 6)))
|
||
|
||
; TECO Buffer Block symbols and other things (.OPTION bits)
|
||
|
||
(setq beg 0 begv 1 pt 2 gpt 3 zv 4 z 5 extrac 6 crlf '|/
|
||
| null (ascii 0) bufblk 2 suparg 8 supcmd 7 read-jcl 1 edit-text 2
|
||
select-buffer 3 optddt 1_36))
|
||
|
||
; insert the kludgey LISP patch
|
||
(include |dsk:libdoc;lispt patch|)
|
||
|
||
(sstatus feature lispt) ; this comes after the patch
|
||
|
||
; LISP EXTERNAL REFERENCES FOR JOB MANIPULATION
|
||
|
||
(mapc '(lambda(x) (cond ((not (getl x '(subr expr autoload)))
|
||
(putprop x '(lddt fasl dsk liblsp) 'autoload))))
|
||
'(start-job set-job-start-adr continue-job wait-for-job make-job
|
||
set-job-start-adr disown-job job-start-adr))
|
||
|
||
(mapc '(lambda(x) (cond ((not (getl x '(subr autoload)))
|
||
(putprop x '(humble fasl dsk liblsp) 'autoload))))
|
||
'(select-job load-job kill-job examine-job deposit-job
|
||
job-uset-read job-uset-write))
|
||
|
||
;;; GLOBAL VARIABLES
|
||
|
||
(setq editor-job nil editor-usr-input nil editor-usr-output nil
|
||
editor-jname nil lispt-file-forced nil)
|
||
|
||
;;; These symbols may have previous definitions by the user
|
||
(special-init lispt-file '((dsk sys2) ts lispt))
|
||
(special-init lispt-initial-sname (status udir))
|
||
(special-init lispt-jname (cond ((status feature macsyma) 'macst) (t 'lispt)))
|
||
(special-init lispt-protect nil)
|
||
(special-init lispt-prompter (cond ((status feature macsyma) 'ttyretfun)
|
||
(t 'lisp-prompt)))
|
||
(special-init lispt-tty-passing-msg '|(Console Passing to the Editor)|)
|
||
(special-init lispt-tty-to-ddt-msg '|(Console Passing to DDT)|)
|
||
(special-init roving-editor? t)
|
||
|
||
(cond ((status feature macsyma)
|
||
(defprop $edprotect lispt-protect alias)
|
||
(defprop lispt-protect edprotect reversealias)
|
||
(defprop $rover roving-editor? alias)
|
||
(defprop roving-editor? rover reversealias)))
|
||
|
||
(COMMENT INTERRUPT HANDLER FOR /.BREAK 16 FROM TECO)
|
||
|
||
;;; THE .BREAK 16, CONVENTION FOR COMMUNICATING WITH AN INFERIOR TECO
|
||
;;; 100000 IS DECODED BY THE REMAINING BITS:
|
||
;;; 1 - DO A READ-EVAL-PRIN1 LOOP OVER THE WHOLE BUFFER.
|
||
;;; 2 - TRY ZAPPING MACSYMA CODE IF IN A MACSYMA
|
||
;;; 4 - random text
|
||
;;; 10 - return to DDT, and upon return, directly back to the editor
|
||
;;; 20 - return to DDT
|
||
;;; 40
|
||
;;; 100 - silent return (i.e. tty wasn't used by TECO
|
||
;;; 200
|
||
;;; 400
|
||
;;; 1000 - error return. Encountered errors while executing
|
||
;;; TECO commands requested by the superior. The
|
||
;;; error message is left in a buffer for the superior
|
||
;;; to read. After doing that, the superior should
|
||
;;; continue the teco to allow it to clean up, and then
|
||
;;; the teco will return silently.
|
||
;;; OTHERWISE JUST GENTLY RETURN
|
||
|
||
|
||
(SETQ *BREAK16-FUNCTION '*BREAK-TECO)
|
||
|
||
(defun *break-teco (eff)
|
||
(caseq (boole 1 7777 eff)
|
||
(1 (load-from-teco editor-job))
|
||
(2 (batch-from-teco editor-job))
|
||
(4 (lispt-read-text editor-job))
|
||
(10 (lispt-return-to-ddt t))
|
||
(20 (lispt-return-to-ddt nil))
|
||
(100 (clear-tty-return)) ; silent return
|
||
(1000 (lispt-teco-error editor-job)))
|
||
null)
|
||
|
||
(COMMENT LOAD AND START EDITOR)
|
||
|
||
|
||
(DEFUN MAKE-EDITOR NIL
|
||
(LET ((FILE LISPT-FILE-FORCED)
|
||
(JOB-ORIGIN) (JNAME-TAIL)
|
||
(JNAME-LIST (EXPLODEN LISPT-JNAME))
|
||
(FILE-LIST `(((DSK ,(STATUS hsname)) ,(status xuname) LISPT)
|
||
((DSK ,(STATUS hsname)) ,(status xuname) EDIT)
|
||
,LISPT-FILE)))
|
||
|
||
(IF (AND FILE (ATOM FILE)) (SETQ FILE `(TS ,FILE)))
|
||
(IF FILE (SETQ FILE-LIST
|
||
(NCONC (LIST (MERGEF FILE `((DSK ,(STATUS UDIR))))
|
||
(MERGEF FILE `((DSK ,(STATUS hsname))))
|
||
(MERGEF FILE `((DSK SYS)))
|
||
(MERGEF FILE `((DSK SYS1)))
|
||
(MERGEF FILE `((DSK SYS2))))
|
||
FILE-LIST)))
|
||
|
||
(DO ((FL FILE-LIST (CDR FL)))
|
||
((NULL FL) (ERROR '|Can't find editor on disk! |))
|
||
(IF (PROBEF (CAR FL)) (RETURN (SETQ FILE (CAR FL)))))
|
||
|
||
(IF (> (LENGTH JNAME-LIST) 6)
|
||
(DO ((L (NREVERSE JNAME-LIST) (CDR L)))
|
||
((NOT (> (LENGTH L) 6)) (SETQ JNAME-LIST (NREVERSE L)))))
|
||
|
||
|
||
(DO ((JNAME (PROG2 NIL (IMPLODE JNAME-LIST)
|
||
(SETQ JNAME-LIST (NREVERSE JNAME-LIST)
|
||
JNAME-TAIL
|
||
(IF (= 6 (LENGTH JNAME-LIST)) (RPLACA JNAME-LIST 0)
|
||
(CONS 0 JNAME-LIST))
|
||
JNAME-LIST (NREVERSE JNAME-TAIL)))
|
||
(PROG2 (RPLACA JNAME-TAIL (+ I 60)) (IMPLODE JNAME-LIST)))
|
||
(I 0 (1+ I)) (JOB))
|
||
((> I 7) (ERROR '|Can't create LISPT job |))
|
||
(SETQ JOB (MAKE-JOB JNAME)
|
||
JOB-ORIGIN (CAR JOB)
|
||
JOB (CADR JOB))
|
||
(IF (NULL JOB-ORIGIN) (ERROR '|Can't Create job (system full?) |))
|
||
(IF (NOT (EQ 'FOREIGN JOB-ORIGIN))
|
||
(RETURN (SETQ EDITOR-JNAME JNAME EDITOR-JOB JOB))))
|
||
|
||
(IF (NOT (GETL 'START-JOB '(EXPR SUBR))) ; need LDDT below
|
||
(LET ((^W T) (DEFAULTF))
|
||
(APPLY 'FASLOAD (GET 'START-JOB 'AUTOLOAD))))
|
||
|
||
(IF (NOT (EQ 'REOWNED JOB-ORIGIN))
|
||
(PROGN (IF (LOAD-JOB FILE) (ERROR '|Can't load LISPT job |))
|
||
(COND (TTY-VERBOSE
|
||
(IF (NOT (= 0 (CDR (CURSORPOS)))) (TERPRI))
|
||
(MAPC 'PRINC `(|; Editor job "| ,EDITOR-JNAME
|
||
|" Created | ,CRLF))))
|
||
(SET-JOB-START-ADR EDITOR-JOB (+ 2 (JOB-START-ADR EDITOR-JOB)))
|
||
(*USET *SSNAM (6BIT LISPT-INITIAL-SNAME)))
|
||
(IF (NOT (= 0 (CDR (CURSORPOS)))) (TERPRI))
|
||
(MAPC 'PRINC `(|; Editor job "| ,EDITOR-JNAME |" Reowned | ,CRLF))
|
||
(SET-JOB-START-ADR EDITOR-JOB 4002)) ; MAY NOT WIN. FOR $G RECOVERY.
|
||
|
||
(IF LISPT-PROTECT (VALRET* '|/..SAFE//1/î:VP |))
|
||
|
||
JOB-ORIGIN))
|
||
|
||
(defun start-editor nil
|
||
(if (not (inf-editor-test)) (make-editor))
|
||
(continue-editor t))
|
||
|
||
(defun GZP-editor nil
|
||
(if (not (inf-editor-test)) (make-editor))
|
||
(set-jcl '|100100. FS EXIT|)
|
||
(select-job editor-job)
|
||
(continue-job t)
|
||
(wait-for-editor)
|
||
T)
|
||
|
||
(defun continue-editor (tty-flag)
|
||
(setq tty-passing-msg lispt-tty-passing-msg)
|
||
(select-job editor-job)
|
||
(continue-job tty-flag))
|
||
|
||
(defun wait-for-editor nil (wait-for-job editor-job))
|
||
|
||
|
||
(COMMENT EDITOR JOB CONTROL)
|
||
|
||
(DEFUN KILL-EDITOR NIL
|
||
(IF EDITOR-JOB (PROGN (CLEAN-UP-EDITOR)
|
||
(SELECT-JOB EDITOR-JOB)
|
||
(KILL-JOB)
|
||
(PRINC0 '|; Job "|) (PRINC EDITOR-JNAME)
|
||
(PRINC '|" killed|) (TERPRI)
|
||
(SETQ EDITOR-JOB NIL EDITOR-JNAME NIL))
|
||
(PRINC0 '|; No editor job? |) (TERPRI))
|
||
'DONE)
|
||
|
||
(DEFUN $KILLEDITOR NIL (KILL-EDITOR) '$DONE)
|
||
|
||
(DEFUN DISOWN-EDITOR NIL
|
||
(IF EDITOR-JOB (PROG2 (CLEAN-UP-EDITOR)
|
||
(DISOWN-JOB EDITOR-JOB)
|
||
(PRINC0 '|; Job "|) (PRINC EDITOR-JNAME)
|
||
(PRINC '|" disowned |) (TERPRI)
|
||
(SETQ EDITOR-JOB NIL EDITOR-JNAME NIL))
|
||
(PRINC0 '|; No editor job? |) (TERPRI) NIL))
|
||
|
||
(DEFUN $DISOWNEDITOR NIL (IF (DISOWN-EDITOR) '$DONE))
|
||
|
||
(DEFUN REOWN-EDITOR (X)
|
||
(PROG NIL
|
||
(SETQ X (IF (NULL X) 'LISPT X))
|
||
(COND ((AND EDITOR-JOB (EQ EDITOR-JNAME X))
|
||
(PRINC0 '|; Editor already owned |)
|
||
(RETURN '*))
|
||
(EDITOR-JOB (CLOBBER-EDITOR?)))
|
||
(LET ((JOB (MAKE-JOB X)))
|
||
(COND ((EQ 'REOWNED (CAR JOB))
|
||
(SETQ EDITOR-JNAME X EDITOR-JOB (CADR JOB))
|
||
(SET-JOB-START-ADR EDITOR-JOB 4000)
|
||
(RETURN T))
|
||
(T (KILL-JOB)
|
||
(PRINC0 '|; Job "|) (PRINC X)
|
||
(IF (EQ 'FOREIGN (CAR JOB))
|
||
(PRINC '|" is owned by another job|)
|
||
(PRINC '|" not found |))
|
||
(TERPRI))))
|
||
(IF LISPT-PROTECT (VALRET* '|/..SAFE//1/î:VP |))))
|
||
|
||
(DEFUN $REOWNEDITOR MACRO (X)
|
||
`(PROGN (REOWN-EDITOR .,(IF X (MAPCAR 'STRIPDOLLAR X)))
|
||
'$DONE))
|
||
|
||
(DEFUN CLEAN-UP-EDITOR NIL
|
||
(IF EDITOR-USR-OUTPUT (CLOSE-EDITOR EDITOR-USR-OUTPUT))
|
||
(IF EDITOR-USR-INPUT (CLOSE-EDITOR EDITOR-USR-INPUT)))
|
||
|
||
|
||
(COMMENT Open and Closing files to Editor Buffers)
|
||
|
||
(DECLARE (SPECIAL TECO-PC))
|
||
(DEFUN OPEN-EDITOR (JOB MODE)
|
||
(COND ((EQ 'INPUT MODE)
|
||
(SETQ EDITOR-USR-INPUT (OPEN JOB '(IN ASCII)))
|
||
(USR-OPEN-FIX EDITOR-USR-INPUT (TECO-V #,ZV))
|
||
(FILEPOS EDITOR-USR-INPUT (TECO-V #,BEGV))
|
||
EDITOR-USR-INPUT)
|
||
(T (SETQ EDITOR-USR-OUTPUT (OPEN JOB '(OUT ASCII)))
|
||
(USR-OPEN-FIX EDITOR-USR-OUTPUT (TECO-V #,ZV))
|
||
(FILEPOS EDITOR-USR-OUTPUT (TECO-V #,PT))
|
||
EDITOR-USR-OUTPUT)))
|
||
|
||
(DEFUN CLOSE-EDITOR (FILE) ; not too exciting for now
|
||
(CLOSE FILE)
|
||
(SET (IF (EQ EDITOR-USR-INPUT FILE) 'EDITOR-USR-INPUT 'EDITOR-USR-OUTPUT)
|
||
NIL)
|
||
T)
|
||
|
||
(DEFUN TECO-V (X)
|
||
(LET ((BUFBLK (EXAMINE-JOB #,BUFBLK)))
|
||
(LET ((VX (EXAMINE-JOB (+ BUFBLK X))))
|
||
(COND ((NOT (< VX (EXAMINE-JOB (+ BUFBLK #,GPT))))
|
||
(+ VX (EXAMINE-JOB (+ BUFBLK #,EXTRAC))))
|
||
(T VX)))))
|
||
|
||
(setq current-editor-buffer nil)
|
||
(declare (*lexpr run-teco))
|
||
|
||
; Crufty TECO code below is for editor independence (ugh). It simply runs
|
||
; MM & LISPT SELECT WRITE BUFFER
|
||
|
||
(defun select-buffer (buffer)
|
||
(let ((tty-return))
|
||
(if (not (inf-editor-test))
|
||
(error '|Can't select buffer - No editor job.|))
|
||
(if (not (atom buffer))
|
||
(error '|Buffer names must be atoms.|))
|
||
(if editor-usr-output (close-editor editor-usr-output))
|
||
(setq current-editor-buffer buffer)
|
||
(select-job editor-job)
|
||
(set-jcl buffer)
|
||
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)))
|
||
(declare (fixnum bb save-pc))
|
||
(deposit-job (+ bb #,suparg) #,select-buffer)
|
||
(*uset *supc (+ bb #,supcmd))
|
||
(continue-job T) ; JCL hacker gives tty back too
|
||
(wait-for-editor)
|
||
(setq current-teco-buffer-block (examine-job #,bufblk))
|
||
(continue-job T)
|
||
(wait-for-job editor-job)
|
||
(*uset *supc save-pc))
|
||
(open-editor editor-job 'output)
|
||
T))
|
||
|
||
(defun run-teco-command (cmd)
|
||
(select-job editor-job)
|
||
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)) (TTY-RETURN))
|
||
(declare (fixnum bb save-pc))
|
||
(deposit-job (+ bb #,suparg) cmd)
|
||
(*uset *supc (+ bb #,supcmd))
|
||
(continue-job T) ; JCL hacker gives tty back too
|
||
(wait-for-editor)
|
||
(*uset *supc save-pc))
|
||
t)
|
||
|
||
(defun run-teco n
|
||
(select-job editor-job)
|
||
(apply 'set-jcl (listify n))
|
||
(let ((save-pc (*uset *rupc)) (bb (examine-job #,bufblk)))
|
||
(declare (fixnum bb save-pc))
|
||
(deposit-job (+ bb #,suparg) #,read-jcl)
|
||
(*uset *supc (+ bb #,supcmd))
|
||
(let ((tty-return))
|
||
(continue-job T)
|
||
(wait-for-job editor-job))
|
||
(*uset *supc save-pc))
|
||
t)
|
||
|
||
; ERROR Handling for Errors in TECO while executing JCL commands
|
||
; assumes that TECO has closed the gap in the current buffer
|
||
|
||
(defun lispt-teco-error (job)
|
||
(clear-tty-return)
|
||
(let ((editor-usr-input) (lispt-text-string))
|
||
(princ0 '|; Error while editor executing commands requested by LISP:|)
|
||
(terpri) (princ (lispt-read-text job)) (terpri)
|
||
(nointerrupt nil)
|
||
(select-job job)
|
||
(let ((tty-return))
|
||
(continue-job T)
|
||
(wait-for-job job))
|
||
(tyipeek nil tyi)))
|
||
|
||
|
||
(COMMENT READ-EVAL ROUTINE)
|
||
|
||
(special-init lispt-read-loop 'default-lispt-read-eval-print-loop)
|
||
(special-init lispt-readtable readtable)
|
||
|
||
(defun load-from-teco (job)
|
||
(let ((prompt? tty-return-prompt?))
|
||
(clear-tty-return)
|
||
(open-editor job 'input)
|
||
(funcall lispt-read-loop)
|
||
(close-editor editor-usr-input)
|
||
(if prompt? (funcall lispt-prompter nil))))
|
||
|
||
(defun default-lispt-read-eval-print-loop nil
|
||
(let ((errlist '((princ '|; Reading from the editor aborted|) (terpri))))
|
||
(cursorpos 'c) ; start with a fresh screen
|
||
(princ0 '|; Reading from the editor |) (terpri)
|
||
(do ((infile editor-usr-input) (^Q T) (expr))
|
||
(NIL)
|
||
(setq expr (funcall (or read 'read) 'LISPT-EOF))
|
||
(IF (EQ 'LISPT-EOF EXPR) (RETURN NIL))
|
||
(setq + expr)
|
||
(if (and (not (atom expr)) (eq 'INCLUDE (car expr)))
|
||
(let ((file (cadr expr)))
|
||
(princ0 '|; Including File |) (princ file)
|
||
(funcall 'load file)
|
||
(terpri) (princ '|; End of File |)
|
||
(princ file)))
|
||
(terpri) (funcall (or prin1 'prin1) (setq * (eval expr)))))
|
||
(terpri) (terpri) (princ '|; Finished reading |))
|
||
|
||
|
||
(COMMENT OUTPUT TO EDITOR BUFFERS)
|
||
|
||
(defun eprinc n ; doesn't force output
|
||
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
|
||
(select-buffer (arg 2)))
|
||
(princ (if (> n 0) (arg 1)) editor-usr-output)
|
||
T)
|
||
|
||
(defun eprint n
|
||
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
|
||
(select-buffer (arg 2)))
|
||
(print (if (> n 0) (arg 1)) editor-usr-output)
|
||
(eforce-output)
|
||
T)
|
||
|
||
(defun eprin1 n
|
||
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
|
||
(select-buffer (arg 2)))
|
||
(prin1 (if (> n 0) (arg 1)) editor-usr-output)
|
||
(eforce-output)
|
||
T)
|
||
|
||
(defun eterpri n
|
||
(if (and (> n 0) (not (eq (arg 1) current-editor-buffer)))
|
||
(select-buffer (arg 1)))
|
||
(terpri editor-usr-output)
|
||
(eforce-output)
|
||
T)
|
||
|
||
(defun esprinter n (editor-output 'sprinter (listify n)))
|
||
|
||
(defun egrindef fexpr (x) (editor-output 'grindef x))
|
||
|
||
(defun etyo n
|
||
(if (and (> n 1) (not (eq (arg 2) current-editor-buffer)))
|
||
(select-buffer (arg 2)))
|
||
(tyo (if (> n 0) (arg 1) 0) editor-usr-output)
|
||
t)
|
||
|
||
(defun eforce-output nil (force-output editor-usr-output))
|
||
|
||
(defun eclose nil (close-editor editor-usr-output))
|
||
|
||
(declare (macros t))
|
||
(defun editt macro (form)
|
||
(if (null (inf-editor-test)) (GZP-EDITOR))
|
||
(select-buffer 'LISP-EDIT)
|
||
(mapc '(lambda (x) (editor-output 'grindef x)) (cdr form))
|
||
(run-teco-command #,edit-text)
|
||
T)
|
||
(declare (macros nil))
|
||
|
||
(defun editor-output (op x)
|
||
(if (not (inf-editor-test)) (error '|No editor job|))
|
||
(if (= 2 (length x)) (select-buffer (cadr x)))
|
||
(if (null (and editor-usr-output current-editor-buffer))
|
||
(error '|No channel open to the editor or no buffer selected.|))
|
||
|
||
(if (null (getl 'grindef '(fsubr fexpr))) (grindef))
|
||
(let ((^w t) (^d nil) (outfiles (list editor-usr-output)) (^r t))
|
||
(apply op (list (car x))))
|
||
(eforce-output)
|
||
'*)
|
||
|
||
(COMMENT BATCH MACSYMA COMMAND FROM TECO)
|
||
|
||
(DECLARE (SPECIAL $DEMOMODE $TRANSLMODE $BATCHKILL $LINENUM CR LF TAB ST FF SP
|
||
$INCHAR $OUTCHAR REPHRASE $% $NOLABELS LINELABLE $LASTTIME
|
||
UPCASEP $CURSOR POS $DISPFLAG $FUNCTIONS $ARRAYS $ALL $INPUT
|
||
$STRDISP OLDST THISTIME IMAGE-STRING $ERRORFUN)
|
||
(*LEXPR PRINT-CONSOLE-MSG)
|
||
(*EXPR KILL1 STRIPDOLLAR TYI* PARSE1 CONTINUE1 TRANSLATE-MACEXPR
|
||
PRINTLABEL DISPLAY* MAKELABEL $RESET MAKSTRING GETLABELS
|
||
STRMEVAL GETLABELS* CONSFUNDEF MGET LISTARGP ERLIST REPRINT
|
||
CHECKLABEL))
|
||
|
||
(SETQ $DEMOMODE NIL $TRANSLMODE NIL)
|
||
|
||
(DEFUN BATCH-FROM-TECO (JOB)
|
||
(LET ((PROMPT? TTY-RETURN-PROMPT?))
|
||
(IF (NOT (STATUS FEATURE MACSYMA))
|
||
(ERROR '|Zapping MACSYMA code into a LISP without MACSYMA? |))
|
||
(CLEAR-TTY-RETURN)
|
||
(CURSORPOS 'C)
|
||
(PRINT-CONSOLE-MSG '|(Reading Commands from the Editor)|)
|
||
(OPEN-EDITOR JOB 'INPUT)
|
||
(COND ((PROG2 NIL (TECO-BATCH)
|
||
(CLOSE-EDITOR EDITOR-USR-INPUT))
|
||
(PRINT-CONSOLE-MSG '|(Finished)|)))
|
||
(IF PROMPT? (FUNCALL lispt-prompter NIL))
|
||
NULL))
|
||
|
||
(DEFUN TECO-BATCH NIL
|
||
(LET (($DISPFLAG) (ST) ($ERRORFUN 'TECO-BATCH-ERROR)
|
||
(ERRLIST '((TECO-BATCH-ERROR))))
|
||
(COND ($BATCHKILL (KILL1 $BATCHKILL)
|
||
(COND ((EQ $BATCHKILL T) ($RESET))) (GCTWA)))
|
||
(COND ((NOT (CHECKLABEL $INCHAR)) (SETQ $LINENUM (1+ $LINENUM))))
|
||
(MAKELABEL $INCHAR)
|
||
(DO ((COMMAND-STRING) (TERMINATOR) (COMMAND) (RESULT))
|
||
((EQ 'EOF/# TERMINATOR))
|
||
(SETQ IMAGE-STRING NIL
|
||
COMMAND-STRING (GET-COMMAND-STRING)
|
||
TERMINATOR (CAR COMMAND-STRING)
|
||
$DISPFLAG (EQ '/; TERMINATOR)
|
||
ST (mapcar '(lambda (x) (getcharn x 1)) (CDR COMMAND-STRING)))
|
||
(COND ((EQ 'EOF/# TERMINATOR) (RETURN T)))
|
||
(REPRINT IMAGE-STRING T)
|
||
(SETQ OLDST ST)
|
||
(SETQ COMMAND (COND ($TRANSLMODE ((LAMBDA (^W) (PARSE1)) NIL))
|
||
(T (PARSE1))))
|
||
(COND ((NULL COMMAND) (TERPRI)
|
||
(PRINC '|Syntax error occurred in reading commands from the editor.|)
|
||
(TERPRI) (RETURN NIL))
|
||
($TRANSLMODE (TRANSLATE-MACEXPR (CAR COMMAND)))
|
||
(T (SETQ RESULT (CONTINUE1 (CAR COMMAND)))))
|
||
(COND ((NULL RESULT) (TERPRI)
|
||
(PRINC '|Error occurred while executing commands from the editor.|)
|
||
(TERPRI) (RETURN NIL)))
|
||
(SETQ $% (CAR RESULT)) (MAKELABEL $OUTCHAR)
|
||
(COND ((NOT $NOLABELS) (SET LINELABLE $%)
|
||
(PUTPROP LINELABLE (CONS (CADR $LASTTIME) (CADDR $LASTTIME)) 'TIME)))
|
||
(COND ($DISPFLAG (REMPROP LINELABLE 'NODISP) (DISPLAY*))
|
||
(T (PUTPROP LINELABLE T 'NODISP)))
|
||
(SETQ $LINENUM (1+ $LINENUM)) (MAKELABEL $INCHAR)
|
||
(COND ($DEMOMODE (PRINC (STRIPDOLLAR $CURSOR))
|
||
(COND ((NOT (= (TYI*) 32.))
|
||
(TERPRI) (PRINC '|DEMO TERMINATED|)
|
||
(TERPRI) (SETQ ST NIL)
|
||
(RETURN nil))))))))
|
||
|
||
(DEFUN TECO-BATCH-ERROR NIL
|
||
(PRINC0 '| (Command reading from the Editor aborted)|)
|
||
(TERPRI))
|
||
|
||
(DEFUN GET-COMMAND-STRING NIL
|
||
(LET ((CH-STRING))
|
||
(DO ((CH) (STARTING T (AND STARTING (NULL CH-STRING)))
|
||
(CTRL-LIST (LIST CR LF FF TAB)))
|
||
((MEMQ CH '( EOF/# /; $)))
|
||
(SETQ CH (READCH* 'EOF/#))
|
||
(COND ((EQ '/\ CH)
|
||
(SETQ CH-STRING (CONS (SETQ CH (LET ((UPCASEP))
|
||
(READCH* 'EOF/#)))
|
||
(CONS '/\ CH-STRING))))
|
||
((EQ '/" CH)
|
||
(SETQ CH-STRING (CONS CH CH-STRING)
|
||
CH (DO ((CH) (UPCASEP))
|
||
((MEMQ CH '(/" EOF/#)) CH)
|
||
(SETQ CH (READCH* 'EOF/#)
|
||
CH-STRING (CONS CH CH-STRING)))))
|
||
((MEMQ CH CTRL-LIST)
|
||
(IF STARTING (SETQ IMAGE-STRING (CDR IMAGE-STRING))))
|
||
((AND STARTING (EQ SP CH)))
|
||
((EQ '// CH)
|
||
(SETQ CH (READCH* 'EOF/#))
|
||
(COND ((EQ '* CH) ; GOBBLE COMMENT
|
||
(SETQ STARTING NIL
|
||
CH (DO ((CH)) ((EQ 'EOF/# CH) CH)
|
||
(SETQ CH (READCH* 'EOF/#))
|
||
(IF (AND (EQ '* CH)
|
||
(EQ '//
|
||
(SETQ CH (READCH* 'EOF/#))))
|
||
(RETURN CH)))))
|
||
(T (SETQ CH-STRING (CONS CH (CONS '// CH-STRING))))))
|
||
(T (SETQ CH-STRING (CONS CH CH-STRING)))))
|
||
(IF (MEMQ (CAR CH-STRING) '(/; /$))
|
||
(DO ((CH (TYIPEEK NIL EDITOR-USR-INPUT)
|
||
(TYIPEEK NIL EDITOR-USR-INPUT)))
|
||
((MEMBER CH '(-1 15)))
|
||
(READCH* NIL)))
|
||
CH-STRING))
|
||
|
||
(DEFUN READCH* (X)
|
||
(LET ((N (TYI EDITOR-USR-INPUT 300)))
|
||
(IF (OR (= 300 N) (= 3 N)) X
|
||
(SETQ IMAGE-STRING (CONS (ASCII N) IMAGE-STRING))
|
||
(IF (AND UPCASEP (> N 96.) (< N 123.)) (ASCII (- N 32.))
|
||
(ASCII N)))))
|
||
|
||
(COMMENT READ A RANDOM STRING OF TEXT FROM TECO)
|
||
|
||
(declare (special lispt-text-string))
|
||
(setq lispt-text-string nil)
|
||
|
||
(defun lispt-read-text (job)
|
||
(open-editor job 'input)
|
||
(do ((nchlist nil (cons (tyi editor-usr-input) nchlist)))
|
||
((= -1 (car nchlist))
|
||
(close-editor editor-usr-input)
|
||
(setq lispt-text-string (implode (nreverse (cdr nchlist)))))))
|
||
|
||
|
||
(COMMENT STRING MACSYMA EXPRESSIONS INTO A EDITOR BUFFER)
|
||
|
||
(defun $selectbuffer (buffer) (select-buffer (stripdollar buffer)) '$DONE)
|
||
|
||
(DEFUN $TEDIT FEXPR (X)
|
||
(APPLY '$TSTRING X)
|
||
(CONTINUE-EDITOR T)
|
||
(WAIT-FOR-JOB EDITOR-JOB)
|
||
'$DONE)
|
||
|
||
(DECLARE (*EXPR $LISTP))
|
||
|
||
(DEFUN $TSTRING FEXPR (X)
|
||
(if (not (inf-editor-test)) (make-editor))
|
||
(if ($LISTP (car x)) (select-buffer (stripdollar (cadar x))))
|
||
(if (null editor-usr-output) (select-buffer 'MACSYMA-EDIT))
|
||
(LET ((^W T) (^D NIL) (ERROR)
|
||
(OUTFILES (LIST EDITOR-USR-OUTPUT))
|
||
(^R T))
|
||
(COND ((NULL
|
||
(ERRSET
|
||
(DO ((L X (CDR L)) (L1)) ((NULL L))
|
||
(COND ((MEMQ (CAR L) '($ALL $INPUT))
|
||
(SETQ L (NCONC (GETLABELS* $INCHAR) (CDR L))))
|
||
((EQ (CAR L) '$FUNCTIONS)
|
||
(SETQ L (NCONC (MAPCAR
|
||
(FUNCTION
|
||
(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL)))
|
||
(CDR $FUNCTIONS))
|
||
(MAPCAN
|
||
(FUNCTION
|
||
(LAMBDA (X)
|
||
(COND ((MGET X 'AEXPR)
|
||
(NCONS (CONSFUNDEF X T NIL))))))
|
||
(CDR $ARRAYS))
|
||
(CDR L))))
|
||
((SETQ L1 (LISTARGP (CAR L)))
|
||
(SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L)))))
|
||
(TERPRI) (MAPC 'PRINC (MAKSTRING (STRMEVAL (CAR L))))
|
||
(COND ((OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP))
|
||
(PRINC '$))
|
||
(T (PRINC '/;))))))
|
||
(SETQ ERROR T)))
|
||
(TERPRI)
|
||
(IF ERROR (LET ((ERRSET 'ERRBREAK1))
|
||
(SETQ ^W NIL)
|
||
(ERLIST '(ERROR IN TSTRING ATTEMPT))))
|
||
(SETQ ^R NIL)
|
||
(CLOSE-EDITOR EDITOR-USR-OUTPUT)
|
||
'$DONE))
|
||
|
||
(defun MACSYMA-edit-interrupt (file char) (setq char char)
|
||
(if (not (= 0 (listen file))) (tyi file))
|
||
(if (null (inf-editor-test)) (GZP-editor))
|
||
(if (not editor-usr-output) (select-buffer 'MACSYMA-EDIT))
|
||
(EPRINC (maknam (REVERSE ST)))
|
||
(eforce-output)
|
||
(run-teco-command #,edit-text)
|
||
(reprint st t)
|
||
'$DONE)
|
||
|
||
(if (and (null (status ttyint 5)) (status feature MACSYMA))
|
||
(sstatus ttyint 5 'MACSYMA-EDIT-INTERRUPT))
|
||
|
||
(COMMENT COMMANDS FOR ENTERING EDITORS)
|
||
|
||
; useless functions for calling editors
|
||
|
||
(defun $teco nil (enter-specific-inf-editor 'teco) '$done)
|
||
|
||
(defun teco nil (enter-specific-inf-editor 'teco))
|
||
|
||
(defun $emacs nil (enter-specific-inf-editor 'emacs) '$done)
|
||
|
||
(defun emacs nil (enter-specific-inf-editor 'emacs))
|
||
|
||
(defun lispt nil (enter-specific-inf-editor nil))
|
||
|
||
(declare (macros t))
|
||
(defun (inf-edit macro) (x)
|
||
(setq x (cdr x))
|
||
(cond (x `(lispt-edit ',x))
|
||
(T '(lispt-edit nil))))
|
||
|
||
(defun inf-edit* n (lispt-edit (listify n)))
|
||
|
||
(defun $edit macro (x)
|
||
(setq x (cdr x))
|
||
(cond (x `(progn (lispt-edit ',(map-strip$ x)) '$DONE))
|
||
(t '(progn (lispt-edit nil) '$DONE))))
|
||
|
||
(defun map-strip$ (x) (if (atom x) (stripdollar x) (mapcar 'map-strip$ x)))
|
||
|
||
(defun lispt-edit (x)
|
||
(if (and x (not (atom x)) (null (cdr x))) (setq x (car x)))
|
||
(let ((lispt-jname (if (null x) lispt-jname
|
||
(if (atom x) x
|
||
(if (atom (car x)) (car x)
|
||
(error '| First arg must be atomic.|)))))
|
||
(file (if (atom x) x (cadr x))))
|
||
(enter-specific-inf-editor file)))
|
||
|
||
(defun enter-specific-inf-editor (x)
|
||
(setq tty-return-prompt? nil)
|
||
(let ((lispt-file-forced x))
|
||
(if (not (inf-editor-test)) (make-editor))
|
||
(continue-editor t))
|
||
(wait-for-job editor-job)
|
||
'*)
|
||
|
||
(defun inf-editor-test nil
|
||
(or editor-job (and roving-editor? (find-roving-editor lispt-jname))))
|
||
|
||
(declare (*expr $error))
|
||
|
||
(defun find-roving-editor (jname)
|
||
(let ((job (make-job jname)))
|
||
(cond ((eq 'FOREIGN (car job))
|
||
(if (prog2 nil (not (= 0 (boole 1 #,optddt (*uset *ROPTI))))
|
||
(kill-job))
|
||
(editor-from-ddt jname)
|
||
(princ0 '|Roving editor job is inferior to some other job./
|
||
Create a new one? (Y or N):|)
|
||
(if (not (= 31 (boole 1 37 (tyi))))
|
||
(if (status feature MACSYMA) ($ERROR) (^G)))
|
||
nil))
|
||
((eq 'REOWNED (car job))
|
||
(if tty-verbose (princ0 '|; Roving editor reowned |) (TERPRI))
|
||
(setq editor-jname jname
|
||
editor-job (cadr job))
|
||
(set-job-start-adr editor-job 4000)
|
||
T)
|
||
((car job) (kill-job) nil)
|
||
(T (ERROR '|Can't create editor job (system full?)|)))))
|
||
|
||
(SSTATUS TTYINT
|
||
'/
|
||
'(LAMBDA (CHNL CHAR)
|
||
(DO ()
|
||
((OR (= 0 (LISTEN CHNL))
|
||
(= (TYI CHNL) CHAR))))
|
||
(VALRET '|/..SAFE// 1/î:VP |)
|
||
(NOINTERRUPT () )
|
||
(TERPRI (SETQ CHAR (STATUS TTYCONS CHNL)))
|
||
(PRINC '|Editor jName? | CHAR)
|
||
(AND (ZEROP (FLATC (SETQ CHAR (READLINE CHNL))))
|
||
(SETQ CHAR 'LISPT))
|
||
(UNWIND-PROTECT
|
||
(PROG2 (SETQ CHNL NOUUO)
|
||
(NOUUO ())
|
||
(LISPT-EDIT (LIST CHAR 'EMACS)))
|
||
(SSTATUS TTYINT '/ 'LISPT-EDIT-INTERRUPT)
|
||
(NOUUO CHNL))))
|
||
|
||
(defun lispt-edit-interrupt (file char)
|
||
(terpri)
|
||
(do ()
|
||
((or (= 0 (listen file))
|
||
(= (tyi file) char))))
|
||
(if (not (inf-editor-test)) (make-editor)) ; autostart
|
||
(continue-editor t)
|
||
null)
|
||
|
||
(COMMENT Commands for Passing Through to DDT)
|
||
|
||
; interrupt level routine run from *BREAK-TECO
|
||
|
||
(defun lispt-return-to-ddt (trf)
|
||
(let ((tty-return '(lambda(x) x)))
|
||
(nointerrupt nil))
|
||
(if trf (setq tty-return-list '((return-to-editor))))
|
||
(return-to-ddt))
|
||
|
||
(defun return-to-editor nil
|
||
(if editor-job
|
||
(progn (select-job editor-job)
|
||
(continue-job t)))) ; punt the tty passing message
|
||
|
||
(defun LISPT-^Z nil
|
||
(setq tty-passing-msg lispt-tty-to-ddt-msg)
|
||
(cond ((and roving-editor? editor-job)
|
||
(addl '(roving-editor-tty-return) tty-return-list)
|
||
(editor-to-ddt))))
|
||
|
||
(special-init default-return-to-ddt-list '((LISPT-^Z) (DDT-return)))
|
||
|
||
(defun roving-editor-tty-return nil
|
||
(cond ((null(errset (editor-from-ddt editor-jname) NIL))
|
||
(PRINC0 '|; Warning: Can't get the editor.|)
|
||
(terpri)
|
||
(nointerrupt nil)
|
||
(rplacd tty-return-list nil)
|
||
(if tty-return-prompt? (funcall lispt-prompter nil)))))
|
||
|
||
(defun editor-to-ddt nil
|
||
(if (null editor-job) (error '|No editor job. |))
|
||
(let ((stadr))
|
||
(select-job editor-job) (setq stadr (job-start-adr editor-job))
|
||
(clean-up-editor)
|
||
(if (null (disown-job editor-job)) (error '|Disowning the editor failed |))
|
||
(valret* '|:job | editor-jname '| ..star//jrst | stadr '|/î:job |
|
||
(status jname) '| :vp |))
|
||
(setq editor-job nil)
|
||
'done)
|
||
|
||
(DEFUN EDITOR-FROM-DDT (X)
|
||
(SETQ X (IF (NULL X) 'LISPT X))
|
||
(IF EDITOR-JOB (CLOBBER-EDITOR?))
|
||
(LET ((JOB (MAKE-JOB X)))
|
||
(COND ((EQ 'REOWNED (CAR JOB)) (DISOWN-JOB (CADR JOB)))
|
||
((EQ 'FOREIGN (CAR JOB))
|
||
(IF (NOT (= 0 (BOOLE 1 #,OPTDDT (*USET *ROPTI))))
|
||
(KILL-JOB)
|
||
(ERROR '|Editor belongs to some job other than DDT|))
|
||
(VALRET* '|:JOB | X '| :DISOWN :JOB | (STATUS JNAME)
|
||
'| :VP |))
|
||
(T (IF (CAR JOB) (KILL-JOB)) ; INFERIOR create, or NIL
|
||
(ERROR '|Editor job doesn't exist |))))
|
||
(REOWN-EDITOR X))
|
||
|
||
(DEFUN CLOBBER-EDITOR? NIL
|
||
(LET ((^W NIL)) (PRINC0 '|Clobber the existing editor? (Y or N) |))
|
||
(IF (MEMQ (PROG2 NIL (READCH) (TERPRI)) '(Y /y)) (KILL-EDITOR)
|
||
(ERR)))
|
||
|
||
;; Local Modes:
|
||
;; Mode: LISP
|
||
;; Comment Col: 40
|
||
;; END:
|