mirror of
https://github.com/PDP-10/its.git
synced 2026-01-26 12:12:12 +00:00
Builds all LISP; * FASL files that are on autoload properties when
the lisp interpreter is first booted. Redumps lisp compiler with updated FASL files built from source.
This commit is contained in:
Eric Swenson
254
src/comlap/ledit.21
Executable file
254
src/comlap/ledit.21
Executable file
@@ -0,0 +1,254 @@
|
||||
|
||||
(comment LISP-TECO EDITOR INTERFACE) ; -*-LISP-*-
|
||||
|
||||
|
||||
(declare (special ledit-jname ;atomic name of emacs job
|
||||
ledit-loadfile ;namestring of binary file for editor
|
||||
ledit-library ;namestring of teco macro library
|
||||
ledit-tags ;namestring of tags file
|
||||
ledit-tags-find-file ;0 or 1 controls setting of qreg in
|
||||
; teco whether to use Find File
|
||||
ledit-deletef ;switch, if T delete file from teco
|
||||
; after reading
|
||||
ledit-pre-teco-func ;called with list of arguments given
|
||||
; to ledit
|
||||
ledit-post-teco-func ;called with namestring of file
|
||||
; returned from teco
|
||||
ledit-pre-eval-func ;called with form to be eval'ed,
|
||||
; returns form to be eval'ed instead
|
||||
ledit-completed-func ;called after reading in is complete
|
||||
ledit-eof ;gensym once to save time
|
||||
ledit-jcl ;pre-exploded strings to save time
|
||||
ledit-valret ;
|
||||
ledit-proceed ;
|
||||
ledit-jname-altj ;
|
||||
ledit-lisp-jname ;
|
||||
ledit-find-tag ;
|
||||
ledit-find-file ;
|
||||
ledit-lisp-mode ;
|
||||
defun ;system variable
|
||||
tty-return)) ;system variable
|
||||
|
||||
|
||||
|
||||
;; autoload properties for FLOAD stuff that used to be part of LEDIT
|
||||
|
||||
(defprop fload ((liblsp) fload fasl) autoload)
|
||||
(defprop cload ((liblsp) fload fasl) autoload)
|
||||
(defprop ledit-olderp ((liblsp) fload fasl) autoload))
|
||||
(defprop ledit-agelist ((liblsp) fload fasl) autoload))
|
||||
|
||||
;; default values for global variables
|
||||
|
||||
(mapc
|
||||
'(lambda (x y) (or (boundp x) (set x y)))
|
||||
'(ledit-jname ledit-loadfile ledit-library ledit-tags ledit-tags-find-file
|
||||
ledit-deletef ledit-pre-teco-func ledit-post-teco-func ledit-pre-eval-func
|
||||
ledit-completed-func)
|
||||
'(LEDIT |SYS2;TS EMACS| |EMACS;LEDIT| () 1
|
||||
() () () () ())
|
||||
)
|
||||
|
||||
(mapc '(lambda (x y) (set x (exploden y)))
|
||||
'(ledit-jcl ledit-find-tag
|
||||
ledit-find-file ledit-lisp-jname ledit-lisp-mode )
|
||||
'(|:JCL | |WMM& LEDIT FIND TAG| |WMMFIND FILE|
|
||||
|W:ILEDIT LISP JNAME| |WF~MODELISP"N1MMLISP MODEW'|)
|
||||
)
|
||||
|
||||
(setq ledit-eof (gensym) ledit-jname-altj () ledit-valret () )
|
||||
(setq ledit-proceed (exploden '|
|
||||
/
|
||||
..UPI0// /
|
||||
:IF E Q&<%PIBRK+%PIVAL>/
|
||||
(:ddtsym tygtyp///
|
||||
:if n q&10000/
|
||||
(: Teco Improperly Exited, Use ^Z (NOT CALL!)/
|
||||
)/
|
||||
:else/
|
||||
(: Teco Improperly Exited, Use ^X^C (NOT ^Z !)/
|
||||
)/
|
||||
:SLEEP 30./
|
||||
P/
|
||||
:INPOP/
|
||||
)/
|
||||
2// /
|
||||
Q+8//-1 /
|
||||
.-1G|))
|
||||
|
||||
(defun LEDIT fexpr (spec)
|
||||
;; if given one arg, is tag to be searched for (using FIND FILE) if more
|
||||
;; than one arg, taken as file name to find (may be newio or oldio form)
|
||||
(let ((newjob (cond ((not (job-exists-p (status uname) ledit-jname))
|
||||
(setq ledit-jname-altj nil)
|
||||
(setq ledit-valret nil)
|
||||
(mapcan 'exploden (list '/
|
||||
'|L| ledit-loadfile '/
|
||||
'|G|)))))
|
||||
(firstcall)
|
||||
(atomvalret))
|
||||
|
||||
(and ledit-pre-teco-func (funcall ledit-pre-teco-func spec))
|
||||
|
||||
(or ledit-jname-altj ;memoize for fast calls later
|
||||
(setq ledit-jname-altj (mapcan 'exploden (list '/
|
||||
ledit-jname '|J|))
|
||||
firstcall t))
|
||||
|
||||
(cond ((and ledit-valret (null spec)) ;go to teco in common case
|
||||
(valret ledit-valret))
|
||||
|
||||
('t
|
||||
(setq
|
||||
atomvalret
|
||||
(nconc
|
||||
(list 23.) ;ctl-W
|
||||
(append ledit-jcl () ) ;set own jcl line to ()
|
||||
(append ledit-jname-altj () ) ;$J to ledit job
|
||||
(append ledit-jcl () ) ;set jcl line for teco
|
||||
(and newjob ;for new job only
|
||||
(mapcan 'exploden
|
||||
(list '|F~EDITOR TYPELEDIT/"NMMLOAD LIBRARY|
|
||||
ledit-library '|'|)))
|
||||
(and firstcall ;for first call only
|
||||
(append ledit-lisp-mode () ))
|
||||
(and firstcall ledit-tags ;for first call only
|
||||
(mapcan 'exploden
|
||||
(list ledit-tags-find-file
|
||||
'|MMVISIT TAG TABLE| ledit-tags '/)))
|
||||
|
||||
(nconc (append ledit-lisp-jname () ) ;tell teco
|
||||
(exploden (status jname)) ;lisp's jname
|
||||
(list 27.)) ; altmode
|
||||
(cond ((= (length spec) 1) ;tag
|
||||
(nconc (append ledit-find-tag () )
|
||||
(exploden (car spec))
|
||||
(list 27.)))
|
||||
((> (length spec) 1) ;file name
|
||||
(nconc (append ledit-find-file () )
|
||||
(exploden (namestring
|
||||
(mergef spec defaultf)))
|
||||
(list 27.)
|
||||
(append ledit-lisp-mode () ))))
|
||||
(or newjob ledit-proceed))) ;start new job
|
||||
; or proceed old one
|
||||
(setq atomvalret (maknam atomvalret))
|
||||
(and (not firstcall) (not newjob) (null spec)
|
||||
(setq ledit-valret
|
||||
atomvalret)) ;memoize common simple case
|
||||
(valret atomvalret))) ;go to teco
|
||||
'*))
|
||||
|
||||
(defun LEDIT-TTY-RETURN (unused)
|
||||
;; this function called by tty-return interrupt to read code back
|
||||
;; from Teco
|
||||
;; check JCL to see if it starts with LEDIT-JNAME
|
||||
;; if so, rest of JCL is filename to be read in
|
||||
;; note: need to strip off trailing <cr> on jcl
|
||||
(declare (fixnum i))
|
||||
(let ((jcl (status jcl)))
|
||||
(cond ((and jcl
|
||||
(setq jcl
|
||||
(errset
|
||||
(readlist (nreverse (cdr (nreverse jcl)))) nil))
|
||||
(not (atom (setq jcl (car jcl))))
|
||||
(eq (car jcl) ledit-jname))
|
||||
|
||||
(valret '|:JCL/
|
||||
P|) ;clear jcl
|
||||
(cursorpos 'c)
|
||||
(nointerrupt nil)
|
||||
|
||||
(and ledit-post-teco-func
|
||||
(funcall ledit-post-teco-func (cadr jcl)))
|
||||
|
||||
(cond ((cadr jcl) ;if non-null then read in file
|
||||
;; read in zapped forms
|
||||
(let ((file (open (cadr jcl) 'in))
|
||||
(defun nil)) ;disable expr-hash
|
||||
(princ '|;Reading from |)(prin1 ledit-jname)
|
||||
;; Read-Eval-Print loop
|
||||
(do ((form (cond (read (funcall read file ledit-eof))
|
||||
(t (read file ledit-eof)))
|
||||
(cond (read (funcall read file ledit-eof))
|
||||
(t (read file ledit-eof)))))
|
||||
((eq form ledit-eof) (close file)
|
||||
(and ledit-deletef
|
||||
(deletef file)))
|
||||
(and ledit-pre-eval-func
|
||||
(setq form (funcall ledit-pre-eval-func form)))
|
||||
;; check if uuolinks might need to be snapped
|
||||
(let ((p (memq (car (getl (cadr form)
|
||||
'(expr subr fexpr
|
||||
fsubr lsubr)))
|
||||
'(subr fsubr lsubr))))
|
||||
(print (eval form))
|
||||
(cond ((and p
|
||||
(memq (car (getl (cadr form)
|
||||
'(expr subr fexpr
|
||||
fsubr lsubr)))
|
||||
'(expr fexpr)))
|
||||
(sstatus uuolinks)
|
||||
(princ '| ; sstatus uuolinks|))))))))
|
||||
|
||||
(and ledit-completed-func (funcall ledit-completed-func))
|
||||
(terpri)
|
||||
(princ '|;Edit Completed|)
|
||||
(terpri)))))
|
||||
|
||||
|
||||
(defun LEDIT-TTYINT (fileobj char)
|
||||
;; intended to be put on control character, e.g.
|
||||
;; (sstatus ttyint 5 'ledit-ttyint)
|
||||
(nointerrupt nil)
|
||||
(and (= (tyipeek nil fileobj) char)
|
||||
(tyi fileobj)) ;gobble up control char
|
||||
(apply 'ledit
|
||||
(cond ((= (boole 1 127. ;note masking for 7 bit
|
||||
(tyipeek nil fileobj)) 32.)
|
||||
(tyi fileobj) ;gobble space
|
||||
;; if space typed then just (ledit)
|
||||
nil)
|
||||
(t (let ((s (cond (read (funcall read fileobj))
|
||||
(t (read fileobj)))))
|
||||
(cond ((atom s)
|
||||
(tyi fileobj)
|
||||
(list s)) ;atom is taken as tag
|
||||
(t s))))))) ;list is filename
|
||||
|
||||
;;Lap courtesy of GLS.
|
||||
|
||||
(declare (setq ibase 8.))
|
||||
|
||||
(LAP JOB-EXISTS-P SUBR)
|
||||
(ARGS JOB-EXISTS-P (NIL . 2)) ;ARGS ARE UNAME AND JNAME, AS SYMBOLS
|
||||
(PUSH P B)
|
||||
(SKIPN 0 A) ;NULL UNAME => DEFAULT TO OWN UNAME
|
||||
(TDZA TT TT) ;ZERO UNAME TELLS ITS TO DEFAULT THIS WAY
|
||||
(PUSHJ P SIXMAK) ;CONVERT UNAME TO SIXBIT
|
||||
(PUSH FXP TT)
|
||||
(POP P A)
|
||||
(PUSHJ P SIXMAK) ;CONVERT JNAME TO SIXBIT
|
||||
(POP FXP T) ;UNAME IN T, JNAME IN TT
|
||||
(MOVEI A '())
|
||||
(*CALL 0 JEP43) ;SEE IF JOB EXISTS
|
||||
(POPJ P) ;NO - RETURN NIL
|
||||
(*CLOSE 0) ;YES - CLOSE THE CHANNEL
|
||||
(MOVEI A 'T) ; AND RETURN T
|
||||
(POPJ P)
|
||||
JEP43 (SETZ)
|
||||
(SIXBIT OPEN)
|
||||
(0 0 16 5000) ;CONTROL BITS: IMAGE BLOCK INPUT/INSIST
|
||||
; JOB EXISTS
|
||||
(0 0 0 1000) ;CHANNEL # - 0 IS SAFE IN BOTH OLDIO AND NEWIO
|
||||
(0 0 (% SIXBIT USR)) ;DEVICE NAME (USR)
|
||||
(0 0 T) ;UNAME
|
||||
(0 0 TT 400000) ;JNAME
|
||||
()
|
||||
|
||||
|
||||
|
||||
|
||||
;set control-E unless already defined
|
||||
(or (status ttyint 5) (sstatus ttyint 5 'ledit-ttyint))
|
||||
(or tty-return (setq tty-return 'ledit-tty-return))
|
||||
Reference in New Issue
Block a user