mirror of
https://github.com/PDP-10/its.git
synced 2026-02-09 01:40:58 +00:00
608 lines
18 KiB
Common Lisp
608 lines
18 KiB
Common Lisp
;;; -*-LISP-*-
|
||
; NEWIO LISP DDT
|
||
;
|
||
; This file contains functions to manipulate I.T.S. jobs from LISP using
|
||
; the primitives defined in NEWIO LISP. A package for interacting with TECO
|
||
; is available as (LIBLSP;LISPT FASL, "LISP INFERIOR TECO")
|
||
|
||
(COMMENT DECLARATIONS AND SPECIALS)
|
||
|
||
(DECLARE (SPECIAL NULL *BREAK16-FUNCTION *VALUE *BREAK CURRENT-JOB DDT-READTABLE
|
||
J*STADR J*CRUFT SEND-*VALUE-TO-DDT? JOB-STACK
|
||
JOB-INTERRUPT-LIST JOB-RING JOB-INFORM CRLF LISP-CURSORPOS
|
||
WAITING-FOR-JOB-INT THE-JOB-INPUT-CHANNEL %OPCMD %OPLSP
|
||
TTY-PASSING-MSG TTY-RETURN-LIST DEFAULT-TTY-RETURN-LIST
|
||
TTY-RETURN-MSG TTY-RETURN-PROMPT? TTY-RETURN-PROMPTER
|
||
RETURN-TO-DDT-LIST DEFAULT-RETURN-TO-DDT-LIST TTY-YANKED-FLAG
|
||
JOB-HAD-TTY? TTY-YANKED? TTY-VERBOSE JOB-MSG-FILE TTYRETFUN)
|
||
(FIXNUM I N (CALC-EFF-ADR FIXNUM))
|
||
(*EXPR P JOB-USET-WRITE JOB-USET-READ EXAMINE-JOB DEPOSIT-JOB
|
||
KILL-JOB VALUE-STRING *ATTY *DTTY SELECT-JOB)
|
||
(*LEXPR G START :JCL SET-JCL CREATE-JOB print-console-msg))
|
||
|
||
(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)))
|
||
(defun prinj macro (x) `(princ ,(cadr x) 'job-msg-file))
|
||
(defun terprj macro (x) '(terpri job-msg-file)))
|
||
|
||
(if (not (getl 'create-job '(lsubr autoload)))
|
||
(defprop create-job (humble fasl dsk liblsp) autoload))
|
||
|
||
(special-init send-*value-to-ddt? t)
|
||
|
||
; SET UP DEFAULT HANDLERS FOR PARTICULAR INTERRUPTS
|
||
|
||
(SETQ *VALUE '*VALUE-HANDLER *BREAK '*BREAK-HANDLER ^ZTYPED '^Z-INTERRUPT
|
||
PIDCL 'DEFERRED-CALL LISP-CURSORPOS NIL WAITING-FOR-JOB-INT NIL
|
||
NULL (ASCII 0) JOB-STACK NIL
|
||
J*STADR (GETDDTSYM 'J/.STADR)
|
||
J*CRUFT (GETDDTSYM 'J/.CRUFT)
|
||
%OPCMD 1_40
|
||
%OPLSP 100_18.
|
||
TTY-PASSING-MSG NIL
|
||
JOB-HAD-TTY? NIL
|
||
TTY-YANKED? T
|
||
TTY-VERBOSE T
|
||
JOB-MSG-FILE (OPEN '|TTY:| '(OUT TTY ASCII)))
|
||
|
||
(SPECIAL-INIT *BREAK16-FUNCTION NIL)
|
||
|
||
(SPECIAL-INIT TTY-RETURN-MSG (COND ((STATUS FEATUR MACSYMA)
|
||
'|(Console connected with MACSYMA)|)
|
||
(T '|(Console connected with LISP)|)))
|
||
|
||
(SETQ LNULL '(NIL) JOB-RING NIL ;(RPLACD LNULL LNULL)
|
||
CRLF '|/
|
||
|)
|
||
|
||
|
||
(COMMENT JOB INTERRUPT HANDLER)
|
||
|
||
; This is the ordinary function for handling job related interrupts.
|
||
; When a job is created, this is specified as the interrupt handler,
|
||
; e.g. (CREATE-JOB JOB-INTERRUPT-HANDLER <JNAME> <UNAME> NIL)
|
||
; The basic dispatch mechanism is that the PIRQC word for the job
|
||
; causing the interrupt is decoded into a list of symbolic interrupt
|
||
; names. An arbitrator decides which of the interrupts should get
|
||
; handled in which order. The handling mechanism is by applying
|
||
; the value of the interrupt symbol (if non-nil) to the UUO word.
|
||
; The most useful one's are .VAULE and .BREAK.
|
||
|
||
(DEFUN JOB-INTERRUPT-HANDLER (JOB)
|
||
(SETQ JOB-HAD-TTY? (NULL (STATUS TTY))) ; IF LISP DIDN'T, JOB DID
|
||
(*DTTY)
|
||
(PUSH-SELECT-JOB JOB)
|
||
(DO ((UUO (*USET *RSV40))
|
||
(INTERRUPT-LIST (ARBITRATE-INTERRUPTS
|
||
(PIRQC-DECODE (*USET *RPIRQ) (*USET *RMASK)))
|
||
(CDR INTERRUPT-LIST))
|
||
(INTBIT) (INTSYM))
|
||
((NULL INTERRUPT-LIST))
|
||
(SETQ INTBIT (LSH 1 (CDAR INTERRUPT-LIST))
|
||
INTSYM (CAAR INTERRUPT-LIST))
|
||
(*USET *SAPIR INTBIT)
|
||
(COND ((BOUNDP INTSYM) (FUNCALL (SYMEVAL INTSYM) UUO))
|
||
(T (RANDOM-CLASS1-INTERRUPT INTSYM)))
|
||
(POP-SELECT-JOB))
|
||
(IF (AND (STATUS TTY) WAITING-FOR-JOB-INT) ; not very general...
|
||
(SETQ WAITING-FOR-JOB-INT NIL))
|
||
NULL)
|
||
|
||
; Arbitrator could do something useful someday
|
||
|
||
(DEFUN ARBITRATE-INTERRUPTS (INT-LIST) INT-LIST)
|
||
|
||
(COMMENT PIRQC DECODE)
|
||
|
||
; Interrupt word decoder. Decodes into a list of symbols whose value
|
||
; is a routine to run.
|
||
|
||
(DEFUN PIRQC-DECODE (PIRQC MASK)
|
||
(DECLARE (FIXNUM PIRQC))
|
||
(PROG (L)
|
||
(RETURN
|
||
(COND ((PLUSP PIRQC) ; FIRST WORD INTERRUPTS
|
||
(DO ((PIRQC PIRQC (LSH PIRQC -1))
|
||
(MASK (BOOLE 6 -1 MASK) (LSH MASK -1))
|
||
(DECOD JOB-INTERRUPT-LIST (CDR DECOD))
|
||
(I 0 (1+ I)))
|
||
((ZEROP PIRQC) L)
|
||
(DECLARE (FIXNUM I))
|
||
(COND ((PLUSP (BOOLE 1 1 PIRQC MASK))
|
||
(SETQ L (CONS (CONS (CAR DECOD) I) L))))))
|
||
(T ;2ND WORD INTS
|
||
(DO ((PIRQC PIRQC (LSH PIRQC -1))
|
||
(I 0 (1+ I)))
|
||
((> I 17))
|
||
(IF (PLUSP (BOOLE 1 1 PIRQC))
|
||
(SETQ L (CONS
|
||
(CONS (IMPLODE
|
||
(NCONC (EXPLODEN 'IOCH) (EXPLODEN (1- I))))
|
||
I)
|
||
L))))
|
||
(DO ((PIRQC (BOOLE 1 377777 (LSH PIRQC -18.)) (LSH PIRQC -1))
|
||
(I 0 (1+ I)))
|
||
((> I 7) L)
|
||
(IF (PLUSP (BOOLE 1 1 PIRQC))
|
||
(SETQ L (CONS
|
||
(CONS (IMPLODE
|
||
(NCONC (EXPLODEN 'INF) (NCONS (+ 60 I))))
|
||
(+ 18. I))
|
||
L)))))))))
|
||
|
||
|
||
(COMMENT RANDOM INTERRUPTS (UN-HANDLED))
|
||
|
||
; If we don't want to bother figuring out what to do, just punt informatively
|
||
|
||
(DEFUN RANDOM-CLASS1-INTERRUPT (INT)
|
||
(PRINJ '|INFERIOR CLASS 1 INTERRUPT - |)
|
||
(PRINJ INT)
|
||
(TERPRJ)
|
||
null)
|
||
|
||
; If ^Z typed ...
|
||
|
||
(DEFUN ^Z-INTERRUPT (DUMMY) (DECLARE (FIXNUM DUMMY))
|
||
(SETQ DUMMY DUMMY)
|
||
(DO NIL ((ZEROP (LISTEN T))) (TYI))) ; GOBBLE TYPE-AHEAD
|
||
|
||
|
||
(DEFUN DEFERRED-CALL (DUMMY) (SETQ DUMMY DUMMY))
|
||
|
||
(DEFUN CALC-EFF-ADR (ADR)
|
||
(DECLARE (FIXNUM ADR))
|
||
((LAMBDA (@ X Y) (DECLARE (FIXNUM @ X Y))
|
||
(OR (ZEROP X)
|
||
(SETQ Y (BOOLE 1 777777
|
||
(+ Y (EXAMINE-JOB X)))))
|
||
(COND ((ZEROP @) Y)
|
||
(T (CALC-EFF-ADR (EXAMINE-JOB Y)))))
|
||
(BOOLE 1 ADR 20_22)
|
||
(BOOLE 1 17 (LSH ADR -22))
|
||
(BOOLE 1 777777 ADR))); .VALUE Handler.
|
||
|
||
(COMMENT *VALUE HANDLER)
|
||
|
||
(DEFUN *VALUE-HANDLER (UUO)
|
||
(COND ((ZEROP (BOOLE 1 777777 UUO)) (*VALUE0))
|
||
(T (*VALUE-STRING (GET-STRING (BOOLE 1 777777 UUO))))))
|
||
|
||
; A simple return with no information. (SHOULD TELL WHICH JOB!!)
|
||
|
||
(DEFUN *VALUE0 NIL (PRINC0 '|.VALUE 0.| job-msg-file) (TERPRI job-msg-file) NULL)
|
||
|
||
; A return with a request for action in the form of a string. (SHOULD BE IMPROVED)
|
||
|
||
(DEFUN *VALUE-STRING (VST)
|
||
(COND ((EQUAL VST '|:PROCED |) (CONTINUE-JOB NIL))
|
||
((EQUAL VST '|:KILL |) (PRINJ '|:KILL |) (KILL-JOB))
|
||
((= 33 (GETCHARN VST 1)) (EVAL (READLIST (CDR (EXPLODEN VST)))))
|
||
(SEND-*VALUE-TO-DDT?
|
||
(COND ((NOT (EQ T SEND-*VALUE-TO-DDT?))
|
||
(PRINJ '|Inferior .VALUE = "|) (PRINJ VST)
|
||
(PRINJ '| "|) (TERPRJ) (PRINJ '|Feed commands to DDT?: |)
|
||
(COND ((NOT (MEMQ (let ((READTABLE
|
||
(ARRAY NIL READTABLE)))
|
||
(SETSYNTAX 15 500500 15)
|
||
(READ))
|
||
'(Y YES T)))
|
||
(SETQ VST NIL)))))
|
||
(COND (VST (setq tty-return-prompt? nil)
|
||
(nointerrupt nil)
|
||
(let ((tty-return)) (VALRET VST))))
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
(T (PRINC0 '|; Inferior .VALUE ignored.|) (TERPRI)
|
||
(CONTINUE-JOB JOB-HAD-TTY?))))
|
||
|
||
|
||
; Get a string from the memory of the current job as an exploded list
|
||
|
||
(DEFUN GET-STRING (LOC) (MAKNAM (VALUE-STRING LOC))) ; REWRITE USING EXAMINE-JOB
|
||
|
||
(DEFUN VALUE-STRING (ADR)
|
||
((LAMBDA (FILE)
|
||
(FILEPOS FILE (* ADR 5))
|
||
(DO ((C (TYI FILE) (TYI FILE))
|
||
(L NIL (CONS C L)))
|
||
((ZEROP C) (CLOSE FILE) (NREVERSE L))
|
||
(DECLARE (FIXNUM C))))
|
||
(OPEN CURRENT-JOB '(IN BLOCK ASCII))))
|
||
|
||
(COMMENT JOB CONTROL FUNCTIONS)
|
||
|
||
; Deposit JCL in the job.
|
||
(DEFUN PUT-JCL (LOC JCL)
|
||
(IF (AND JCL (NOT (ATOM JCL))) (SETQ JCL (MAKNAM (MAPCAN 'EXPLODEC JCL))))
|
||
(IF JCL
|
||
(DO ((I LOC (1+ I)) (L (PNGET JCL 7) (CDR L)))
|
||
((NULL L) (DEPOSIT-JOB I 0))
|
||
(DEPOSIT-JOB I (CAR L)))))
|
||
|
||
(DEFUN SET-JCL N
|
||
(IF (NULL CURRENT-JOB) (ERROR '|No job - :JCL |))
|
||
(*USET *SOPTI (BOOLE 7 %opcmd (*USET *ROPTI)))
|
||
(PROGB ((JCRUFT (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT))))
|
||
(COND ((NULL JCRUFT)
|
||
(SETQ JCRUFT (LIST NIL))
|
||
(STORE (ARRAYCALL FIXNUM CURRENT-JOB J*CRUFT)
|
||
(MAKNUM JCRUFT))))
|
||
(PUTPROP JCRUFT (LISTIFY N) 'JCL))
|
||
T)
|
||
|
||
(DEFUN START-JOB (LOC ATTYP)
|
||
(DECLARE (FIXNUM LOC))
|
||
(IF (NULL CURRENT-JOB) (ERROR '|No job - START-JOB|))
|
||
(IF (NOT (ZEROP LOC)) (STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)
|
||
(+ 254_33 (BOOLE 1 777777 LOC))))
|
||
(SETQ LOC (JOB-START-ADR CURRENT-JOB))
|
||
(IF (ZEROP LOC) (ERROR '|No start address? |))
|
||
(*USET *SUPC LOC)
|
||
(CONTINUE-JOB ATTYP))
|
||
|
||
(DEFUN JOB-START-ADR (JOB)
|
||
(IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB))
|
||
(BOOLE 1 777777 (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)))
|
||
|
||
(DEFUN SET-JOB-START-ADR (JOB ADDR)
|
||
(STORE (ARRAYCALL FIXNUM JOB J*STADR) (BOOLE 1 777777 ADDR)))
|
||
|
||
(DEFUN CONTINUE-JOB (ATTYP)
|
||
(IF (NULL CURRENT-JOB) (ERROR '|No job - CONTINUE-JOB |))
|
||
(IF ATTYP
|
||
(PROGN (COND (TTY-PASSING-MSG
|
||
(print-console-msg TTY-PASSING-MSG)
|
||
(CURSORPOS 'E)))
|
||
(SETQ LISP-CURSORPOS (CURSORPOS)
|
||
TTY-PASSING-MSG NIL
|
||
TTY-YANKED? NIL)))
|
||
(*USET *SPIRQ 0)
|
||
(IF (= 0 (BOOLE 1 777777 (*USET *RUPC)))
|
||
(*USET *SUPC (JOB-START-ADR CURRENT-JOB)))
|
||
(nointerrupt 'T)
|
||
(*USET *SUSTP 0)
|
||
(SLEEP .001)
|
||
(cond (attyp (%tbnot-off) (*atty)))
|
||
(NOINTERRUPT NIL)
|
||
NULL)
|
||
|
||
(DEFUN WAIT-FOR-JOB (JOB) ; WAITS UNTIL JOB HAS STOPPED
|
||
(NOINTERRUPT NIL)
|
||
(DO ((CURRENT-JOB JOB))
|
||
((NOT (ZEROP (*USET *RUSTP))))
|
||
(WAIT-FOR-JOB-INT JOB))
|
||
(*DTTY) T)
|
||
|
||
(DEFUN MAKE-JOB (JNAME)
|
||
(let ((^W T))
|
||
(CREATE-JOB 'JOB-INTERRUPT-HANDLER 'CHANNEL-INT-HANDLER
|
||
JNAME (STATUS UNAME))))
|
||
|
||
(DEFUN DISOWN-JOB (JOB)
|
||
(IF (NOT (EQ CURRENT-JOB JOB)) (SELECT-JOB JOB))
|
||
(IF (AND WAITING-FOR-JOB-INT (EQ JOB WAITING-FOR-JOB-INT))
|
||
(SETQ WAITING-FOR-JOB-INT NIL))
|
||
(*USET *SPIRQ 0)
|
||
(*USET *SOPTI (BOOLE 2 %OPLSP (*USET *ROPTI)))
|
||
(PROG2 NIL (NULL (SYSCALL 0 'DISOWN THE-JOB-INPUT-CHANNEL))
|
||
(KILL-JOB))) ; flush the job
|
||
|
||
|
||
; generally useful DDT commands
|
||
|
||
(DEFUN :CONTIN NIL (CONTINUE-JOB T) NULL)
|
||
|
||
(DEFUN P NIL (TERPRI) (:CONTIN))
|
||
|
||
(DEFUN :START N (START-JOB (COND ((ZEROP N) 0) (T (ARG 1))) T) NULL)
|
||
|
||
(DEFUN G N (TERPRI) (APPLY '/:START (LISTIFY N)))
|
||
|
||
(DEFUN :DISOWN NIL (DISOWN-JOB CURRENT-JOB))
|
||
|
||
(COMMENT
|
||
; DDT LIKE COMMANDS
|
||
|
||
(ARRAY DDT-READTABLE READTABLE)
|
||
(SETQ DDT-READTABLE (GET 'DDT-READTABLE 'ARRAY))
|
||
(let ((READTABLE DDT-READTABLE))
|
||
(SETSYNTAX '/ 'MACRO 'DDT-ALTMODE-MACRO)
|
||
(SETSYNTAX '/: 'MACRO 'DDT-COLON-MACRO)
|
||
(SETSYNTAX 15 601540 15)
|
||
(SSTATUS TTYREAD NIL))
|
||
|
||
|
||
(DEFUN DDT () (DO ((READTABLE DDT-READTABLE)) (NIL) (PRINT (EVAL (READ)))))
|
||
|
||
(DEFUN DDT-ALTMODE-MACRO (X) X) ; USE PRE SCAN??
|
||
(DEFUN DDT-COLON-MACRO (X) X)
|
||
|
||
(DEFUN :JCL N (APPLY 'SET-JCL (LISTIFY N)))
|
||
|
||
(DEFUN :PROCEED NIL (CONTINUE-JOB NIL) '*)
|
||
|
||
(DEFUN ^P NIL (TERPRI) (:PROCEED))
|
||
|
||
(DEFUN :GZP NIL (START-JOB 0 T) '*)
|
||
|
||
(DEFUN J N
|
||
(COND ((= 0 N)
|
||
(COND (JOB-RING (SETQ JOB-RING (CDR JOB-RING))
|
||
(SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING))))
|
||
(T (COND ((MEMQ (ARG 1) JOB-RING)
|
||
(DO NIL ((EQ (ARG 1) (CAR JOB-RING)))
|
||
(SETQ JOB-RING (CDR JOB-RING)))
|
||
(SELECT-JOB (CAR JOB-RING)) (CAR JOB-RING))
|
||
(T (SET (ARG 1)
|
||
(CADR (CREATE-JOB 'JOB-INTERRUPT-HANDLER
|
||
'JOB-CHANNEL-HANDLER
|
||
(ARG 1)
|
||
(STATUS USERID))))
|
||
(SETQ JOB-RING
|
||
(CDR (RPLACD JOB-RING
|
||
(CONS CURRENT-JOB (CDR JOB-RING))))))))))
|
||
|
||
(DEFUN J FEXPR (X) (SET (CAR X) (CAR JOB-RING)))
|
||
|
||
) ; END OF COMMENTED OUT CODE
|
||
|
||
(DEFUN *BREAK-HANDLER (UUO)
|
||
(DECLARE (FIXNUM AC EFF UUO))
|
||
(PROG (AC EFF)
|
||
(SETQ AC (BOOLE 1 17 (LSH UUO -23.)) EFF (BOOLE 1 777777 UUO))
|
||
(COND ((= AC 16) (*BREAK16-HANDLER EFF))
|
||
((= AC 12) (*BREAK12-HANDLER EFF))
|
||
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
|
||
(PRINJ '|>>.BREAK |) (PRINJ AC) (PRINJ '/,) (PRINJ EFF) (TERPRJ)))))
|
||
|
||
(DEFUN *BREAK16-HANDLER (EFF)
|
||
(COND ((PLUSP (BOOLE 1 100000 EFF))
|
||
(COND (*BREAK16-FUNCTION (APPLY *BREAK16-FUNCTION (LIST EFF)))))
|
||
((PLUSP (BOOLE 1 40000 EFF))
|
||
(PRINJ '|:KILL |) (KILL-JOB) CRLF)
|
||
((PLUSP (BOOLE 1 24000 EFF)) (KILL-JOB) CRLF)
|
||
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
|
||
(PRINJ '|>>.BREAK 16,|) (PRINJ EFF) (TERPRJ) CRLF)))
|
||
|
||
|
||
(DEFUN *BREAK12-HANDLER (EFF)
|
||
(LET ((TTY-RETURN '(LAMBDA (X) NIL)))
|
||
(NOINTERRUPT NIL) ; let tty-return lose
|
||
(DO ((CEFF (EXAMINE-JOB EFF)) (TYPE 0)) NIL (DECLARE (FIXNUM CEFF TYPE))
|
||
(COND ((= 6 (LSH CEFF -41))
|
||
(DO ((I (1+ (BOOLE 6 777777 (LSH CEFF -22))) (1- I))
|
||
(LOC (BOOLE 1 777777 CEFF) (1+ LOC)))
|
||
((ZEROP I))
|
||
(*BREAK12-HANDLER (EXAMINE-JOB LOC))))
|
||
((MINUSP CEFF)
|
||
(SETQ TYPE (LSH (BOOLE 6 -4_41 CEFF) -22)
|
||
CEFF (BOOLE 1 777777 CEFF))
|
||
(COND ((= TYPE 1)
|
||
(STORE (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)
|
||
(+ 254_33 (BOOLE 1 777777 (EXAMINE-JOB CEFF))))
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
((= TYPE 3) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS
|
||
((= TYPE 4) (CONTINUE-JOB JOB-HAD-TTY?)) ;SYMBOLS
|
||
((= TYPE 5)
|
||
(PUTPROP (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB
|
||
J*CRUFT))
|
||
NIL
|
||
'JCL) ; CLEAR JCL
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
((= TYPE 6) (CONTINUE-JOB JOB-HAD-TTY?)) ; SET DFILE
|
||
((= TYPE 7) (CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOL HACKING
|
||
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
|
||
(PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) CRLF)))
|
||
(T (SETQ TYPE (LSH CEFF -22)
|
||
CEFF (BOOLE 1 777777 CEFF))
|
||
(COND ((= TYPE 1)
|
||
(DEPOSIT-JOB CEFF (ARRAYCALL FIXNUM CURRENT-JOB J*STADR)))
|
||
((= TYPE 2) (CONTINUE-JOB JOB-HAD-TTY?))
|
||
((= TYPE 3)
|
||
(DEPOSIT-JOB CEFF 0)
|
||
(CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS
|
||
((= TYPE 4)
|
||
(DEPOSIT-JOB CEFF 0)
|
||
(CONTINUE-JOB JOB-HAD-TTY?)) ; SYMBOLS
|
||
((= TYPE 5)
|
||
(PUT-JCL CEFF
|
||
(GET (MUNKAM (ARRAYCALL FIXNUM CURRENT-JOB
|
||
J*CRUFT))
|
||
'JCL))
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
((= TYPE 6) (CONTINUE-JOB T))
|
||
((= TYPE 7)
|
||
(DEPOSIT-JOB CEFF 0)
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
((= TYPE 10)
|
||
(DEPOSIT-JOB (1+ CEFF) (EXAMINE-JOB CEFF))
|
||
(DEPOSIT-JOB CEFF 0)
|
||
(CONTINUE-JOB JOB-HAD-TTY?))
|
||
(T (PRINJ '|ILOPR. |) (PRINJ (BOOLE 1 777777 (*USET *RUPC)))
|
||
(PRINJ '|>>.BREAK 12,|) (PRINJ EFF) (TERPRJ) (SLEEP 60)
|
||
(CONTINUE-JOB JOB-HAD-TTY?))))))))
|
||
|
||
(COMMENT TTY Return Functions)
|
||
|
||
(special-init default-tty-return-list '((default-tty-return ttyretarg)))
|
||
|
||
(setq tty-return 'tty-return-handler
|
||
tty-return-list default-tty-return-list
|
||
tty-yanked-flag T)
|
||
|
||
(defun tty-return-handler (ttyretarg) (declare (special ttyretarg))
|
||
(let ((tty-yanked-flag tty-yanked?))
|
||
(setq tty-yanked? T)
|
||
(mapc 'eval tty-return-list)
|
||
(setq tty-return-list default-tty-return-list)))
|
||
|
||
(defun default-tty-return (x)
|
||
(cond ((and (or (status feature MACSYMA) (= 0 (listen tyi)))
|
||
(null tty-yanked-flag))
|
||
(cursorpos 'C job-msg-file)
|
||
(funcall (if (status feature MACSYMA) 'print-console-msg 'princt)
|
||
(if tty-return-msg tty-return-msg
|
||
(if (status feature MACSYMA) '|(MACSYMA)|
|
||
'|(LISP)|))
|
||
job-msg-file)))
|
||
(force-output job-msg-file)
|
||
(if tty-return-prompt? (funcall tty-return-prompter x))
|
||
(setq tty-return-prompt? t)
|
||
T)
|
||
|
||
(defun princt n
|
||
(progb ((args (listify n)))
|
||
(apply 'princ args)
|
||
(apply 'terpri (cdr args))))
|
||
|
||
(defun clear-tty-return nil
|
||
(let ((tty-return '(lambda(x) x))) (declare (special tty-return))
|
||
(nointerrupt nil))
|
||
(setq tty-return-prompt? T
|
||
tty-return-list default-tty-return-list))
|
||
|
||
(special-init tty-return-prompt? t)
|
||
|
||
(special-init tty-return-prompter
|
||
(cond ((status feature MACSYMA) 'ttyretfun)
|
||
(t 'lisp-prompt)))
|
||
|
||
(defun lisp-prompt (x) (if (eq 'IN x) (progn (princ0 '*) (terpri))))
|
||
|
||
(special-init default-return-to-ddt-list '((ddt-return)))
|
||
|
||
(setq return-to-ddt-list default-return-to-ddt-list)
|
||
|
||
(defun return-to-ddt nil
|
||
(mapc 'eval return-to-ddt-list)
|
||
(setq return-to-ddt-list default-return-to-ddt-list))
|
||
|
||
(defun ddt-return nil
|
||
(CURSORPOS 'A)
|
||
(funcall (if (status feature MACSYMA) 'print-console-msg 'PRINCT)
|
||
(if tty-passing-msg tty-passing-msg '|(DDT)|))
|
||
(cursorpos 'E)
|
||
(setq tty-passing-msg nil tty-yanked? NIL)
|
||
(ddt-exit))
|
||
|
||
(defun ^Z-char-interrupt (file ch) (setq ch ch)
|
||
(if (not (= 0 (listen file))) (tyi file))
|
||
(return-to-ddt))
|
||
|
||
(sstatus ttyint 32 '^Z-char-interrupt)
|
||
(sstatus ttyint 25 '^Z-char-interrupt)
|
||
|
||
(defun print-console-msg nargs
|
||
(let ((msg (arg 1))
|
||
(job-msg-file (cond ((< nargs 2) job-msg-file)
|
||
(T (arg 2)))))
|
||
(cond ((and tty-verbose (memq 'CURSORPOS (status filemode job-msg-file))
|
||
(STATUS FEATURE MACSYMA))
|
||
(if (not (= 0 (cdr (cursorpos)))) (terpri job-msg-file))
|
||
(CURSORPOS 'L)
|
||
(CURSORPOS 'H (1- (// (- (LINEL JOB-MSG-FILE) (flatc msg)) 2)))))
|
||
(cond (tty-verbose
|
||
(princ msg job-msg-file)
|
||
(terpri)))
|
||
T))
|
||
|
||
(DEFUN PUSH-SELECT-JOB (JOB)
|
||
(SETQ JOB-STACK (CONS CURRENT-JOB JOB-STACK))
|
||
(SELECT-JOB JOB))
|
||
|
||
(DEFUN POP-SELECT-JOB NIL
|
||
(DO NIL
|
||
((NULL JOB-STACK))
|
||
(IF (JOBP (CAR JOB-STACK)) ; FILTER DEAD JOBS
|
||
(RETURN (SELECT-JOB (CAR JOB-STACK))))
|
||
(IF (EQ (CAR JOB-STACK) WAITING-FOR-JOB-INT)
|
||
(SETQ WAITING-FOR-JOB-INT NIL))
|
||
(SETQ JOB-STACK (CDR JOB-STACK))))
|
||
|
||
|
||
; LIST OF PARTICULAR INTERRUPT HANDLERS
|
||
|
||
(SETQ JOB-INTERRUPT-LIST
|
||
'(TYPEIN
|
||
^ZTYPED
|
||
BADPI
|
||
AROV
|
||
340DPY
|
||
ILOPR
|
||
SYSDED
|
||
*VALUE
|
||
IOC
|
||
ILUAD
|
||
*BREAK
|
||
1PROC
|
||
SLOWCLOCK
|
||
MPV
|
||
MAR
|
||
LTPEN
|
||
PDLOV
|
||
CLI
|
||
RESTR
|
||
SYSDBG
|
||
ARMTP1
|
||
ARMTP2
|
||
ARMTP3
|
||
SYSUUO
|
||
PURINS
|
||
PURPG
|
||
ARFOV
|
||
PARERR
|
||
PITTY
|
||
PIATY ; JOB GOT TTY BACK
|
||
PIDCL ; DELAYED CALL
|
||
<4/.5>
|
||
<4/.6>
|
||
RUNTIM
|
||
REALTM
|
||
))
|
||
|
||
(Comment Functions to interface with ITS)
|
||
|
||
(OR (GETDDTSYM T)
|
||
((LAMBDA (TTY-RETURN) (VALRET '|/î:SL /î:VP |)) NIL))
|
||
|
||
(lap %TBNOT-OFF subr)
|
||
(movei t tt)
|
||
(hrli t 2) ; .RTTY
|
||
(*suset 0 t) ; read it
|
||
(tlz tt 4000) ; clear %tbout
|
||
(tlo t 400000) ; make into .STTY
|
||
(*suset 0 t) ; set it
|
||
(movei 1 't) ; return T
|
||
(popj p)
|
||
()
|
||
|
||
;; takes a job object and waits for an interrupt on that job
|
||
(lap wait-for-job-int subr)
|
||
(args wait-for-job-int (nil . 1))
|
||
(movem a (special waiting-for-job-int))
|
||
(movei a (special waiting-for-job-int))
|
||
(skipe 0 0 a)
|
||
(*hang 0)
|
||
(movei A 'T)
|
||
(popj p)
|
||
()
|
||
|
||
(lap jobp subr) ; is it a valid job object (and open)
|
||
(args jobp (nil . 1))
|
||
(move t 1 (a))
|
||
(movei a nil)
|
||
(tlnn t 'tts/.cl)
|
||
(movei a 'truth)
|
||
(popj p)
|
||
()
|
||
|
||
(lap ddt-exit subr)
|
||
(*break 16 300000) ; return with a kerchink
|
||
(movei A 'truth)
|
||
(popj p)
|
||
()
|