mirror of
https://github.com/PDP-10/its.git
synced 2026-02-16 21:01:16 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
295 lines
11 KiB
Plaintext
295 lines
11 KiB
Plaintext
(eval-when (eval compile)
|
||
(or (get 'when 'macro) (load '((lisp)umlmac)))
|
||
(or (get 'bitmac 'version) (load '((RLB) BITMAC)))
|
||
)
|
||
|
||
(declare (array* (notype faslist-opcodes 1 faslist-acs 1 faslist-bits 1))
|
||
(*lexpr faslreadopen)
|
||
(*lexpr faslist faslist-loop)
|
||
(special faslread-type faslist-bits-size faslist/. linel))
|
||
|
||
(setq faslist-bits-size #o36000) ;big enough for 15 blocks!
|
||
|
||
(prog1 'loadup
|
||
(or (fboundp 'sort) (load (get 'sort 'autoload)))
|
||
(or (fboundp 'sprinter) (load (get 'sprinter 'autoload)))
|
||
(or (fboundp 'format) (load (get 'format 'autoload)))
|
||
(or (fboundp 'faslreadopen) (get 'faslread 'version)
|
||
(load '|RLB%;FASLRE FASL|))
|
||
(lapfivify 0))
|
||
|
||
(defun dump (filespec)
|
||
(sstatus flush (status feature its)) ; Use (SSTATUS FLUSH T) on ITS
|
||
(sstatus toplevel '(faslist-loop))
|
||
(princ '|GC'ing...| tyo)
|
||
(gc) ; Garbage collect
|
||
(princ '|Dumping...| tyo)
|
||
(suspend '|/î/
|
||
| filespec) ; Suspend
|
||
(defaultf `((dsk ,(status udir)) ,(status userid) fasl))
|
||
(endpagefn tyo #'faslist--More--fun)
|
||
(setq gc-overflow #'gc-overflow-foo)
|
||
(faslist-loop (do ((l '(0 #^@ #^C #^M #^_) (cdr l))
|
||
(jcl (status jcl) (delete (ascii (car l)) jcl)))
|
||
((null l) jcl))))
|
||
|
||
(defun faslist-loop (&optional (jcl () jcl?))
|
||
(do ((jcl jcl
|
||
(progn (terpri)
|
||
(princ '|FASList: | tyo)
|
||
(explodec (readline tyi '||)))))
|
||
(nil)
|
||
(cond (JCL
|
||
(let ((filename ()) options)
|
||
(do ((l jcl (cdr l)))
|
||
((or (eq (car l) '/) ;Alt?
|
||
(null l))
|
||
(setq filename (maknam (nreverse filename)))
|
||
(setq options (cons '/(
|
||
(nreverse (cons '/)
|
||
(nreverse (cdr l)))))))
|
||
(push (car l) filename))
|
||
(if (errset (setq options (readlist options)) nil)
|
||
(progn (defaultf filename)
|
||
(if (probef filename)
|
||
(errset (*catch 'flush--More--
|
||
(faslist filename
|
||
(or options 'all)))
|
||
t)
|
||
(format tyo '|/~
|
||
;File not found: /"~a/"|
|
||
(namestring (mergef filename defaultf)))))
|
||
(format tyo '|
|
||
;Syntax error. Use format /"filename{esc}flag1 flag2.../"/
|
||
;Possible flags are ABS, CALL, REL, SPEC, QATOM, QLIST, GLBL,/
|
||
; GETDDT, ARRAY, UNUSED, ATOMTB, ENTRY, LOC, PUTDDT, EVAL, and EOF/
|
||
|)
|
||
))))
|
||
(if (and jcl? jcl) (quit))
|
||
(setq jcl? nil)))
|
||
|
||
(defun faslist--More--fun (tty-file-obj)
|
||
(declare (special catching--More--))
|
||
(if (not (and (boundp 'catching--More--) catching--More--))
|
||
(+internal-tty-endpagefn tty-file-obj)
|
||
(let ((tyic (status ttycons tty-file-obj)))
|
||
(nointerrupt ())
|
||
(format tyo '|--More--|)
|
||
(if (equal (tyipeek -1 tyic) #\space)
|
||
(progn (tyi tyic) (terpri tyo))
|
||
(*throw 'catching--More-- tty-file-obj)))))
|
||
|
||
(defun gc-overflow-foo (space)
|
||
(let* ((mumble (get (cons () (alloc 'T)) space))
|
||
((a b c) mumble)
|
||
(morelist '(() list 1024.))
|
||
(more (get morelist space)))
|
||
(and more (alloc `(space (,a ,(+ b more) ,c))))
|
||
'T))
|
||
|
||
(defun faslist (&OPTIONAL (file () filep) (options 'all))
|
||
(if (not filep) '(ABS REL SPEC CALL QATOM QLIST GLBL GETDDT
|
||
ARRAY UNUSED ATOMTB ENTRY LOC PUTDDT EVAL EOF)
|
||
(let (f faslread-type (base 8.))
|
||
(*catch 'catching--More--
|
||
(let ((catching--More-- 'T))
|
||
(declare (special catching--More--))
|
||
(cursorpos 'C tyo)
|
||
(unwind-protect (progn (setq f (faslreadopen file options))
|
||
(faslist1 f))
|
||
(faslreadclose f))))
|
||
'T)))
|
||
|
||
(defun faslist1 (f)
|
||
(fillarray 'faslist-bits '(0))
|
||
(do ((r (faslread f) (faslread f)) (prev-r) (word 0) (faslist/. 0)
|
||
(linel (cdr (status ttysize))))
|
||
((eq faslread-type 'eof)
|
||
(when prev-r (faslist-sprint prev-r linel))
|
||
() )
|
||
(setq word (faslreadnum f))
|
||
(cond ((and prev-r (not (atom prev-r)) (eq faslread-type 'glbl))
|
||
(let (/@ ((op ac e i rest) prev-r))
|
||
(when (eq e '/@) (setq /@ '(/@) e i i rest))
|
||
(unless ac (setq ac '0))
|
||
(faslist-sprint
|
||
`(,op ,ac ,@/@ ,(cond ((and e (zerop e) (eq r 'R70))
|
||
'(% 0 0 '()))
|
||
((or (null e) (zerop e)) r)
|
||
((and (eq r 'R70) (symbolp e))
|
||
(get e 'faslist-r70))
|
||
(`(+ ,r ,e)))
|
||
,@(and i (ncons i)))
|
||
linel)
|
||
(setq prev-r () faslread-type 'foo)))
|
||
(prev-r (faslist-sprint prev-r linel) (setq prev-r ())))
|
||
(caseq faslread-type
|
||
(abs (setq prev-r (faslist-insn word (rh-bits word) 'T)
|
||
faslist/. (1+ faslist/.)))
|
||
(foo ())
|
||
(T
|
||
(faslist-sprint
|
||
(caseq faslread-type
|
||
; (abs (setq faslist/. (1+ faslist/.))
|
||
; (faslist-insn word (rh-bits word) 'T))
|
||
(rel (let* ((w (rh-bits word)))
|
||
(faslist-setbit w)
|
||
(setq faslist/. (1+ faslist/.))
|
||
(faslist-insn word (faslist-gentag w) 'T)))
|
||
(call (unless (atom r) (setq r (car (last r))))
|
||
(setq faslist/. (1+ faslist/.))
|
||
(faslist-insn word (list 'function r) ()))
|
||
((spec qatom array)
|
||
(unless (atom r) (setq r (car (last r))))
|
||
(setq faslist/. (1+ faslist/.))
|
||
(faslist-insn word (list (get faslread-type 'lapop) r)
|
||
'T))
|
||
(qlist (setq faslist/. (1+ faslist/.))
|
||
(faslist-insn word `',r 'T))
|
||
(entry (cons 'entry r))
|
||
(eval r)
|
||
(loc (list faslread-type
|
||
(setq faslist/. (faslreadnum f))
|
||
r))
|
||
(T (list faslread-type (faslreadnum f) r)))
|
||
linel)))))
|
||
|
||
|
||
(defun faslist-insn (word rh acp)
|
||
(let* ((op* (faslist-opcodes (bit-range word |4.9-4.1|)))
|
||
(op (cond ((atom op*) op*) ((car op*)))))
|
||
`(,op
|
||
,(let ((ac (bit-range word |3.9-3.6|)))
|
||
(cond (acp (faslist-acs ac)) (ac)))
|
||
,@(and (bitp word #o20_22) (list '/@))
|
||
,@(cond ((not (eq (typep rh) 'fixnum)) (list rh))
|
||
((and (= rh 0) (= 0 (bit-range word |3.4-3.1|))) ())
|
||
((and (< rh #o20) (atom op*))
|
||
(ncons (faslist-acs rh)))
|
||
((and (not (atom op*)) (cdr op*))
|
||
(ncons (fsc (rplac-lh 0 rh) #o1_22)))
|
||
((< rh #o700000) (list rh))
|
||
((list (rplac-lh rh #o777777))))
|
||
,@(and (not (= 0 (setq word (bit-range word |3.4-3.1|))))
|
||
(list (faslist-acs word))))))
|
||
|
||
(defun faslist-setbit (n)
|
||
(declare (fixnum n bitpos wordpos))
|
||
(let ((bitpos (bit-and #.(1- 32.) n))
|
||
(wordpos (lsh n #.(- (haulong 32.)))))
|
||
(and (< n faslist-bits-size)
|
||
(store (faslist-bits wordpos)
|
||
(bit-or (lsh 1 bitpos) (faslist-bits wordpos)))
|
||
'T)))
|
||
|
||
(defun faslist-testbit (n)
|
||
(declare (fixnum n bitpos wordpos))
|
||
(let ((bitpos (bit-and #.(1- 32.) n))
|
||
(wordpos (lsh n #.(- (haulong 32.)))))
|
||
(and (< n faslist-bits-size)
|
||
(not (zerop (bit-and (lsh 1 bitpos) (faslist-bits wordpos)))))))
|
||
|
||
|
||
(defun faslist-sprint (x linel)
|
||
(terpri)
|
||
(princ (cond ((not (> faslist/. 0)) '| |)
|
||
((faslist-testbit (1- faslist/.))
|
||
(faslist-gentag (1- faslist/.)))
|
||
((1- faslist/.))))
|
||
(sprint1 x (- linel 8) 0))
|
||
|
||
|
||
(defun faslist-gentag (n) (format () '|G~4,48o| n))
|
||
|
||
(mapc #'(lambda (item op) (putprop item op 'lapop))
|
||
'(spec qatom array qlist)
|
||
'(special quote array quote))
|
||
|
||
(array faslist-bits fixnum (// faslist-bits-size 32.))
|
||
|
||
(array faslist-acs T #o20)
|
||
#%(let ((acs '(0 A B C AR1 AR2A T TT D R F FREEAC P FLP FXP SP)))
|
||
(fillarray 'faslist-acs acs)
|
||
(dolist (ac acs i)
|
||
(or (equal ac 0)
|
||
(putprop ac `(% 0 0 ,i ,i) 'faslist-r70))))
|
||
|
||
(array faslist-opcodes T #o1000)
|
||
(prog1 'faslist-opcodes
|
||
(fillarray 'faslist-opcodes
|
||
'(0 LERR ACALL AJCALL LER3 %UDF PP STRT ;000
|
||
SERINT TP IOJRST STRT7 CALL JCALL CALLF JCALLF ;010
|
||
NCALL NJCALL NCALLF NJCALF
|
||
|024_33| |025_33| |026_33| |027_33| ;020
|
||
|030_33| |031_33| |032_33| |033_33|
|
||
|034_33| |035_33| |036_33| |037_33| ;030
|
||
*IOT *OPEN *OPER *CALL *USET *BREAK *STATU *ACCES ;040
|
||
|050_33| |051_33| |052_33| |053_33|
|
||
|054_33| |055_33| |056_33| |057_33| ;050
|
||
|060_33| |061_33| |062_33| |063_33|
|
||
|064_33| |065_33| |066_33| |067_33| ;060
|
||
|070_33| |071_33| |072_33| |073_33|
|
||
|074_33| |075_33| |076_33| |077_33| ;070
|
||
|100_33| |101_33| |102_33| |103_33|
|
||
|104_33| ADJSP |106_33| |107_33| ;100
|
||
DFAD DFSB DFMP DFDV DADD DSUB DMUL DDIV ;110
|
||
DMOVE DMOVN FIX EXTEND DMOVEM DMOVNM FIXR FLTR ;120
|
||
UFA DFN (FSC) IBP ILDB LDB IDPB DPB ;130
|
||
FAD FADL FADM FADB FADR (FADRI s) FADRM FADRB ;140
|
||
FSB FSBL FSBM FSBB FSBR (FSBRI s) FSBRM FSBRB ;150
|
||
FMP FMPL FMPM FMPB FMPR (FMPRI s) FMPRM FMPRB ;160
|
||
FDV FDVL FDVM FDVB FDVR (FDVRI s) FDVRM FDVRB ;170
|
||
MOVE (MOVEI) MOVEM MOVES MOVS (MOVSI) MOVSM MOVSS ;200
|
||
MOVN (MOVNI) MOVNM MOVNS MOVM (MOVMI) MOVMM MOVMS ;210
|
||
IMUL (IMULI) IMULM IMULB MUL (MULI) MULM MULB ;220
|
||
IDIV (IDIVI) IDIVM IDIVB DIV (DIVI) DIVM DIVB ;230
|
||
(ASH)(ROT)(LSH)(JFFO)(ASHC)(ROTC)(LSHC)(CIRC) ;240
|
||
EXCH BLT AOBJP AOBJN JRST JFCL XCT |257_33| ;250
|
||
PUSHJ PUSH POP POPJ JSR JSP JSA JRA ;260
|
||
ADD (ADDI) ADDM ADDB SUB (SUBI) SUBM SUBB ;270
|
||
(CAI)(CAIL)(CAIE)(CAILE)(CAIA)(CAIGE)(CAIN)(CAIG) ;300
|
||
CAM CAML CAME CAMLE CAMA CAMGE CAMN CAMG ;310
|
||
JUMP JUMPL JUMPE JUMPLE JUMPA JUMPGE JUMPN JUMPG ;320
|
||
SKIP SKIPL SKIPE SKIPLE SKIPA SKIPGE SKIPN SKIPG ;330
|
||
AOJ AOJL AOJE AOJLE AOJA AOJGE AOJN AOJG ;340
|
||
AOS AOSL AOSE AOSLE AOSA AOSGE AOSN AOSG ;350
|
||
SOJ SOJL SOJE SOJLE SOJA SOJGE SOJN SOJG ;360
|
||
SOS SOSL SOSE SOSLE SOSA SOSGE SOSN SOSG ;370
|
||
SETZ (SETZI) SETZM SETZB AND (ANDI) ANDM ANDB ;400
|
||
ANDCA(ANDCAI)ANDCAM ANDCAB SETM(SETMI)SETMM SETMB ;410
|
||
ANDCM(ANDCMI)ANDCMM ANDCMB SETA(SETAI)SETAM SETAB ;420
|
||
XOR (XORI) XORM XORB IOR (IORI) IORM IORB ;430
|
||
ANDCB (ANDCBI) ANDCBM ANDCBB EQV (EQVI) EQVM EQVB ;440
|
||
SETCA(SETCAI)SETCAM SETCAB ORCA(ORCAI)ORCAM ORCAB ;450
|
||
SETCM(SETCMI)SETCMM SETCMB ORCM(ORCMI)ORCMM ORCMB ;460
|
||
ORCB (ORCBI) ORCBM ORCBB SETO (SETOI) SETOM SETOB ;470
|
||
HLL (HLLI) HLLM HLLS HRL (HRLI) HRLM HRLS ;500
|
||
HLLZ (HLLZI) HLLZM HLLZS HRLZ (HRLZI) HRLZM HRLZS ;510
|
||
HLLO (HLLOI) HLLOM HLLOS HRLO (HRLOI) HRLOM HRLOS ;520
|
||
HLLE (HLLEI) HLLEM HLLES HRLE (HRLEI) HRLEM HRLES ;530
|
||
HRR (HRRI) HRRM HRRS HLR (HLRI) HLRM HLRS ;540
|
||
HRRZ (HRRZI) HRRZM HRRZS HLRZ (HLRZI) HLRZM HLRZS ;550
|
||
HRRO (HRROI) HRROM HRROS HLRO (HLROI) HLROM HLROS ;560
|
||
HRRE (HRREI) HRREM HRRES HLRE (HLREI) HLREM HLRES ;570
|
||
(TRN)(TLN)(TRNE)(TLNE)(TRNA)(TLNA)(TRNN)(TLNN) ;600
|
||
TDN TSN TDNE TSNE TDNA TSNA TDNN TSNN ;610
|
||
(TRZ)(TLZ)(TRZE)(TLZE)(TRZA)(TLZA)(TRZN)(TLZN) ;620
|
||
TDZ TSZ TDZE TSZE TDZA TSZA TDZN TSZN ;630
|
||
(TRC)(TLC)(TRCE)(TLCE)(TRCA)(TLCA)(TRCN)(TLCN) ;640
|
||
TDC TSC TDCE TSCE TDCA TSCA TDCN TSCN ;650
|
||
(TRO)(TLO)(TROE)(TLOE)(TROA)(TLOA)(TRON)(TLON) ;660
|
||
TDO TSO TDOE TSOE TDOA TSOA TDON TSON ;670
|
||
nil))
|
||
;Fill in 700 thru 777
|
||
(do ((8s 0 (+ 8s #o10)) (ch8s #/0 (1+ ch8s)))
|
||
((> 8s #o70))
|
||
(do ((1s 0 (1+ 1s)) (ch1s #/0 (1+ ch1s)) (n (+ 8s #o700) (1+ n)))
|
||
((> 1s 7))
|
||
(store (faslist-opcodes n)
|
||
(implode `(/7 ,ch8s ,ch1s /_ /3 /3))))))
|
||
|
||
;; Local Modes:
|
||
;; Mode:LISP
|
||
;; Comment Column:40
|
||
;; Atom Word Mode:1
|
||
;; END:
|