(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: