mirror of
https://github.com/PDP-10/its.git
synced 2026-02-16 21:01:16 +00:00
Added files to support building and running Macsyma.
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.
This commit is contained in:
Eric Swenson
66
src/rlb/bitmac.17
Normal file
66
src/rlb/bitmac.17
Normal file
@@ -0,0 +1,66 @@
|
||||
;;;-*-Lisp-*-
|
||||
|
||||
(declare (load '((alan) lspenv init)))
|
||||
|
||||
;;;Bitwise macros (BIT-xxx X Y)
|
||||
|
||||
;X and Y
|
||||
(defun (bit-and macro) (form) `(boole 1 . ,(cdr form)))
|
||||
|
||||
;X or Y
|
||||
(defun (bit-or macro) (form) `(boole 7 . ,(cdr form)))
|
||||
|
||||
;X and (not Y)
|
||||
(defun (bit-clear macro) (form) `(boole 4 . ,(cdr form)))
|
||||
|
||||
;Right 18. bits of 36. bit word
|
||||
(defun (rh-bits macro) (form) `(boole 1 #o777777 ,(cadr form)))
|
||||
|
||||
;Left 18. bits of 36. bit word
|
||||
(defun (lh-bits macro) (form) `(boole 1 #o777777 (lsh ,(cadr form) -18.)))
|
||||
|
||||
;T if bits are there
|
||||
(defun (bitp macro) (form) `(not (= 0 (boole 1 . ,(cdr form)))))
|
||||
(defun (bit-test macro) (form) `(not (= 0 (boole 1 .,(cdr form)))))
|
||||
|
||||
;T if bit not there
|
||||
(defun (nbitp macro) (form) `(= 0 (boole 1 .,(cdr form))))
|
||||
|
||||
;(bit-range x |4.8-3.1|)
|
||||
;Really should be a load byte. Returns bit range, using ITS bit naming
|
||||
(defun (bit-range macro) (form)
|
||||
(prog (spec d1 d2 d3 d4)
|
||||
(setq spec (caddr form)
|
||||
d1 (- (getcharn spec 1) #/0)
|
||||
d2 (- (getcharn spec 3) #/0)
|
||||
d3 (- (getcharn spec 5) #/0)
|
||||
d4 (- (getcharn spec 7) #/0))
|
||||
(cond ((not (and (= (flatc spec) 7)
|
||||
(eq (getchar spec 2) '/.)
|
||||
(eq (getchar spec 4) '/-)
|
||||
(eq (getchar spec 6) '/.)
|
||||
(>= d1 1) (<= d1 4)
|
||||
(>= d2 1) (<= d2 9.)
|
||||
(>= d3 1) (<= d3 4)
|
||||
(>= d4 1) (<= d4 9.)))
|
||||
(error "-- bad bit range." spec 'wrng-type-arg))
|
||||
(t (setq d1 (+ (* 9. (1- d1)) d2 -1) ; bit # start
|
||||
d2 (+ (* 9. (1- d3)) d4 -1)) ; bit # end
|
||||
(unless (> d1 d2)
|
||||
(setq d1 (prog1 d2 (setq d2 d1))))
|
||||
(setq d3 (- d1 d2 -1)) ; length of mask
|
||||
(let ((shifted (if (zerop d2)
|
||||
(cadr form)
|
||||
`(rot ,(cadr form) ,(- d2)))))
|
||||
(if (= d3 36.)
|
||||
(return shifted)
|
||||
(return `(boole 1 ,(1- (rot 1 d3))
|
||||
,shifted))))))))
|
||||
|
||||
;(rplac-lh word new-lh)
|
||||
(defmacro rplac-lh (word new)
|
||||
`(bit-or (bit-and ,word #o777777) (lsh ,new 18.)))
|
||||
|
||||
;(rplac-rh word new-rh)
|
||||
(defmacro rplac-rh (word new)
|
||||
`(bit-or (bit-clear ,word #o777777) ,new))
|
||||
367
src/rlb/fasdmp.124
Executable file
367
src/rlb/fasdmp.124
Executable file
@@ -0,0 +1,367 @@
|
||||
|
||||
(DECLARE (SPECIAL LFASDHASH ATOMINDEX DSK)
|
||||
(FIXNUM LFASDHASH ATOMINDEX (EQHASH) (ATOMINDEX))
|
||||
(ARRAY* (NOTYPE FASDHASH1 1 FASDHASH2 1))
|
||||
(EVAL (READ)))
|
||||
(SETQ IBASE 8. BASE 8. *NOPOINT NIL)
|
||||
|
||||
(PROG2 NIL 'FASDUMP-SETUP
|
||||
(SETQ LFASDHASH 377)
|
||||
(ARRAY FASDHASH1 T (1+ LFASDHASH))
|
||||
(ARRAY FASDHASH2 T (1+ LFASDHASH)))
|
||||
|
||||
|
||||
(DEFUN FASDUMP (TARGETFILE NONEQFORMS EQFORMS FASDUMPALIST)
|
||||
(PROG (F)
|
||||
(SETQ TARGETFILE (MERGEF TARGETFILE '(* FASL)))
|
||||
(SETQ F (OPEN (MERGEF '(|.FASD.| OUTPUT) TARGETFILE)
|
||||
'(OUT FIXNUM DSK BLOCK)))
|
||||
(*FASDUMP F NONEQFORMS EQFORMS FASDUMPALIST)
|
||||
(SETQ TARGETFILE (TRUENAME (RENAMEF F TARGETFILE)))
|
||||
(CLOSE F)
|
||||
(RETURN TARGETFILE)))
|
||||
|
||||
(DEFUN *FASDUMP (DSK NONEQFORMS EQFORMS FASDUMPALIST)
|
||||
(PROG (ATOMINDEX)
|
||||
(DECLARE (FIXNUM I))
|
||||
(FILLARRAY 'FASDHASH1 '(NIL))
|
||||
(FILLARRAY 'FASDHASH2 '(NIL))
|
||||
(COND (EQFORMS
|
||||
(DO ALIST FASDUMPALIST (CDR ALIST) (NULL ALIST)
|
||||
(SINTERN1 (CAAR ALIST) 'PUT) ;CAUSE THE ALIST FORMS
|
||||
(SINTERN2 (CAAR ALIST) 'PUT) ; TO BE KNOWN
|
||||
(INTERNATOMS (CDAR ALIST))) ;AND THE ATOMS, TOO.
|
||||
(MAPC (FUNCTION COLLECTEQFORMS) EQFORMS)))
|
||||
(MAPC (FUNCTION INTERNATOMS) NONEQFORMS)
|
||||
(DO I 0 (1+ I) (> I LFASDHASH)
|
||||
(RPLACA-LIST-WITH-NIL (FASDHASH1 I) (FASDHASH2 I)))
|
||||
(OUT DSK (CAR (PNGET '*FASL* 6)))
|
||||
(OUT DSK 0) ;LISP VERSION NO., IMMATERIAL
|
||||
(INITBUFFERBIN)
|
||||
(SETQ ATOMINDEX 0)
|
||||
(ZAPATOMS) ;GROVEL OVER THE "OBARRAYS" TO ZAP ATOMS
|
||||
(COND (EQFORMS
|
||||
(MAPC (FUNCTION ZAPALIST) FASDUMPALIST);ALIST FORMS
|
||||
(DO I 0 (1+ I) (> I LFASDHASH) ;ZAP THE DUP FORMS
|
||||
(MAPC (FUNCTION ZAPEQFORM) (FASDHASH2 I)))
|
||||
(MAPC (FUNCTION ZAPFORM) EQFORMS)));AND THE FORMS
|
||||
(MAPC (FUNCTION ZAPFORM) NONEQFORMS)
|
||||
(BUFFERBIN 17 NIL) ;FINALLY CLOSE UP THE FASL OUTPUT FILE
|
||||
(FILLARRAY 'FASDHASH1 '(NIL))
|
||||
(FILLARRAY 'FASDHASH2 '(NIL))
|
||||
(RETURN DSK)))
|
||||
|
||||
(DEFUN INTERNATOMS (FORM)
|
||||
(DO ((FORM FORM (CDR FORM)))
|
||||
((ATOM FORM)
|
||||
(COND (FORM (SINTERN1 FORM 'PUT)
|
||||
(SINTERN2 FORM 'PUT))))
|
||||
(INTERNATOMS (CAR FORM))))
|
||||
|
||||
(DEFUN COLLECTEQFORMS (FORM)
|
||||
(DO ((FORM FORM (CDR FORM)))
|
||||
((ATOM FORM) ;ALWAYS "INTERN" ATOMS, BUT NEVER NIL
|
||||
(COND (FORM (SINTERN1 FORM 'PUT)
|
||||
(SINTERN2 FORM 'PUT))))
|
||||
(COND ((SINTERN1 FORM 'PUT) ;MIGHT AS WELL STOP, WE'VE
|
||||
(SINTERN2 FORM 'PUT) ;BEEN HERE BEFORE.
|
||||
(RETURN T)))
|
||||
(COLLECTEQFORMS (CAR FORM))))
|
||||
|
||||
|
||||
(DEFUN SINTERN MACRO (FORM)
|
||||
((LAMBDA (NUFORM)
|
||||
(RPLACA FORM (CAR NUFORM))
|
||||
(RPLACD FORM (CDR NUFORM))
|
||||
FORM)
|
||||
(SUBLIS
|
||||
(LIST (CONS 'ARY (CADR FORM)))
|
||||
'(LET ((EQH (EQHASH OBJ)) TEM)
|
||||
(SETQ TEM (ARY EQH))
|
||||
(COND ((EQ FLAG '?) (AND (MEMQ OBJ TEM) T))
|
||||
((EQ FLAG 'PUT)
|
||||
(COND ((MEMQ OBJ TEM) T)
|
||||
(T (STORE (ARY EQH) (CONS OBJ TEM))
|
||||
NIL)))
|
||||
((EQ FLAG 'REM)
|
||||
(STORE (ARY EQH) (DELQ OBJ TEM 1))))))))
|
||||
|
||||
(DEFUN SINTERN1 (OBJ FLAG) (SINTERN FASDHASH1))
|
||||
(DEFUN SINTERN2 (OBJ FLAG) (SINTERN FASDHASH2))
|
||||
|
||||
(DEFUN ZAPATOMS NIL ; OUTPUT ALL THE ATOMS (INCL NOS.)
|
||||
(DECLARE (FIXNUM I))
|
||||
(DO I 0 (1+ I) (> I LFASDHASH) ;GROVEL BUCKET TO BUCKET
|
||||
(DO ((FORMS (FASDHASH2 I) (CDR FORMS)) ;OVER EACH BUCKET
|
||||
(PLACES (FASDHASH1 I) (CDR PLACES)))
|
||||
((NULL FORMS))
|
||||
(COND ((AND (ATOM (CAR FORMS)) (NULL (CAR PLACES)))
|
||||
(RPLACA PLACES (SETQ ATOMINDEX (1+ ATOMINDEX)))
|
||||
(BUFFERBIN 12 (CAR FORMS)))))))
|
||||
|
||||
;ZAP OUT AN ATOMTABLE ENTRY FOR THE EVAL MUNGEABLE WHICH IS THE
|
||||
;CDR OF EACH ALIST MEMBER. ENTRY 16 TO BUFFERBIN HAS BEEN
|
||||
;HACKED TO CAUSE RESULT OF MUNGING TO BE ENTERED INTO ATOMTB,
|
||||
;RATHER THAN THROWN AWAY. (I.E. CALL WITH CODE 36).
|
||||
(DEFUN ZAPALIST (ALIST-MEMBER)
|
||||
(LET ((EQH (EQHASH (CAR ALIST-MEMBER))))
|
||||
(DO ((FORMS (FASDHASH2 EQH) (CDR FORMS))
|
||||
(PLACES (FASDHASH1 EQH) (CDR PLACES)))
|
||||
((EQ (CAR ALIST-MEMBER) (CAR FORMS))
|
||||
(RPLACA PLACES (SETQ ATOMINDEX (1+ ATOMINDEX)))
|
||||
(BUFFERBIN 36 (CDR ALIST-MEMBER))))))
|
||||
|
||||
(DEFUN EQHASH (X) (/\ (MAKNUM X) LFASDHASH))
|
||||
|
||||
;RETURNS RPLACA-ABLE SUBLIST WITH :
|
||||
;(CAR <VAL>) = INDEX OF ATOMTABLE ENTRY IF ONE IS THERE
|
||||
;ELSE (CAR <VAL>) = NIL IF ENTRY IS THERE BUT ITS INDEX IS STILL
|
||||
; UNKNOWN
|
||||
;ELSE <VAL> = NIL (=> NO ENTRY)
|
||||
|
||||
(DEFUN ATOMINDEX1 (FORM)
|
||||
(COND ((NULL FORM) '(0))
|
||||
(T (LET ((EQH (EQHASH FORM)))
|
||||
(DO ((FORMS (FASDHASH2 EQH) (CDR FORMS))
|
||||
(PLACES (FASDHASH1 EQH) (CDR PLACES)))
|
||||
((NULL FORMS) NIL)
|
||||
(COND ((EQ FORM (CAR FORMS))
|
||||
(RETURN PLACES))))))))
|
||||
|
||||
(DEFUN ATOMINDEX (FORM)
|
||||
(COND ((NULL FORM) 0)
|
||||
(T (LET ((ATX (ATOMINDEX1 FORM)))
|
||||
(COND ((OR (NULL ATX) (NULL (CAR ATX)))
|
||||
(ERROR '|No atomindex found| FORM 'WRNG-TYPE-ARG))
|
||||
(T (CAR ATX)))))))
|
||||
|
||||
(DEFUN ZAPEQFORM (FORM)
|
||||
(PROG (ATX)
|
||||
;DON'T HAVE TO ZAP IF ATOM OR IF ALREADY ZAPPED
|
||||
(COND ((OR (ATOM FORM)
|
||||
(AND (SETQ ATX (ATOMINDEX1 FORM))
|
||||
(CAR ATX))))
|
||||
((NULL ATX) ;NOT AN "EQ FORM"
|
||||
(ZAPEQFORM (CAR FORM))
|
||||
(ZAPEQFORM (CDR FORM)))
|
||||
(T
|
||||
(ZAPEQFORM (CAR FORM))
|
||||
(ZAPEQFORM (CDR FORM))
|
||||
(RPLACA ATX (SETQ ATOMINDEX (1+ ATOMINDEX)))
|
||||
;;It's OK to inc ATOMINDEX before BUFFERBIN because
|
||||
;;ATOMINDEX is inc'ed only by ZAPATOMS, ZAPALIST, and ZAPEQFORM
|
||||
;;all of which have run by the time we get here.
|
||||
(BUFFERBIN 25 FORM)))))
|
||||
|
||||
;ZAP FOR EVAL, THROW AWAY. NOTE THAT LISTOUT AND ATOMINDEX
|
||||
;(CALLED BY BUFFERBIN) HAVE BEEN HACKED CONSIDERABLY.
|
||||
(DEFUN ZAPFORM (FORM) (BUFFERBIN 16 FORM))
|
||||
|
||||
(DEFUN RPLACA-LIST-WITH-NIL (A B)
|
||||
(COND (A (COND (B (DO ((A (RPLACA A NIL) (RPLACA (CDR A) NIL))
|
||||
(B (CDR B) (CDR B)))
|
||||
((NULL B) (AND A (RPLACD A NIL)))))
|
||||
(T (RPLACA A NIL) (RPLACD A NIL))))))
|
||||
|
||||
(DECLARE (SPECIAL BINCT)
|
||||
(FIXNUM (UNBYTES FIXNUM) (ATOMINDEX) (ARGSPROPEVAL)
|
||||
TYPN BINCT)
|
||||
(ARRAY* (FIXNUM BINTYPARRAY 1)
|
||||
(NOTYPE BINFORMARRAY 1 BINDISPATCHARRAY 1))
|
||||
(SETQ INTERPRETED NIL)
|
||||
(READ))
|
||||
(SETQ INTERPRETED T)
|
||||
|
||||
(DEFUN CONDINTERPRETED MACRO (FORM)
|
||||
((LAMBDA (NUFORM) (RPLACA FORM (CAR NUFORM))
|
||||
(RPLACD FORM (CDR NUFORM))
|
||||
FORM)
|
||||
(COND (INTERPRETED (COND ((= 1 (LENGTH (CADR FORM)))
|
||||
(CAADR FORM))
|
||||
(T (CONS 'PROGN (CADR FORM)))))
|
||||
(T (COND ((= 1 (LENGTH (CADDR FORM)))
|
||||
(CAADDR FORM))
|
||||
(T (CONS 'PROGN (CADDR FORM))))))))
|
||||
|
||||
(DEFUN CALL MACRO (FORM)
|
||||
(LET ((TYPLIST '(T NIL FIXNUM FLONUM)) NUFORM)
|
||||
(SETQ NUFORM
|
||||
(COND (INTERPRETED
|
||||
(CONS 'FUNCALL
|
||||
(COND ((MEMQ (CADR FORM) TYPLIST)
|
||||
(CDDR FORM))
|
||||
(T (CDR FORM)))))
|
||||
(T (CONS 'SUBRCALL
|
||||
(COND ((MEMQ (CADR FORM) TYPLIST)
|
||||
(CDR FORM))
|
||||
(T (CONS NIL (CDR FORM))))))))
|
||||
(RPLACA FORM (CAR NUFORM))
|
||||
(RPLACD FORM (CDR NUFORM))
|
||||
FORM))
|
||||
|
||||
(DEFUN INITBUFFERBIN NIL
|
||||
(DECLARE (FIXNUM I))
|
||||
(SETQ BINCT 0)
|
||||
(ARRAY BINTYPARRAY FIXNUM 9.)
|
||||
(ARRAY BINFORMARRAY T 9.)
|
||||
(CONDINTERPRETED ((ARRAY BINDISPATCHARRAY T 20))
|
||||
((ARRAY BINDISPATCHARRAY NIL 20)))
|
||||
(DO ((I 0 (1+ I)) (L '(OUT2 OUT2 OUT2 OUT2
|
||||
OUT2 BUFQTL OUT2 BUFGET
|
||||
OUT2 BUFFERBINBARF BUFATX BUFENT
|
||||
BUFFERBINBARF BUFPUT BUFMNG BUFEND)
|
||||
(CDR L)))
|
||||
((NULL L))
|
||||
(CONDINTERPRETED ((STORE (BINDISPATCHARRAY I) (CAR L)))
|
||||
((STORE (BINDISPATCHARRAY I)
|
||||
(GET (CAR L) 'SUBR))))))
|
||||
|
||||
|
||||
(DEFUN BUFFERBIN (BINTYP BINFORM)
|
||||
(DECLARE (FIXNUM BINTYP))
|
||||
(STORE (BINTYPARRAY BINCT) BINTYP)
|
||||
(STORE (BINFORMARRAY BINCT) BINFORM)
|
||||
(SETQ BINTYP (BOOLE 1 17 BINTYP))
|
||||
(COND ((= BINTYP 17)
|
||||
(OUT DSK (UNBYTES BINCT))
|
||||
(DO I 0 (1+ I) (> I BINCT)
|
||||
(CALL (BINDISPATCHARRAY
|
||||
(BOOLE 1 17 (BINTYPARRAY I)))
|
||||
(BINTYPARRAY I)
|
||||
(BINFORMARRAY I))))
|
||||
((> (SETQ BINCT (1+ BINCT)) 8.)
|
||||
(OUT DSK (UNBYTES 8.))
|
||||
(DO I 0 (1+ I) (> I 8.)
|
||||
(CALL (BINDISPATCHARRAY
|
||||
(BOOLE 1 17 (BINTYPARRAY I)))
|
||||
(BINTYPARRAY I)
|
||||
(BINFORMARRAY I)))
|
||||
(SETQ BINCT 0))))
|
||||
|
||||
|
||||
;;; GOBBLES 4-BIT BYTES FROM CT ELEMENTS OF BINTYPARRAY
|
||||
;;; AND COMBINES THEM INTO ONE FIXNUM
|
||||
(DEFUN UNBYTES (CT)
|
||||
(DECLARE (FIXNUM CT I N))
|
||||
(DO ((I 1 (1+ I)) (N (BOOLE 1 17 (BINTYPARRAY 0))))
|
||||
((< CT I) (LSH N (- 32. (* 4 CT))))
|
||||
(SETQ N (BOOLE 7 (LSH N 4)
|
||||
(BOOLE 1 17 (BINTYPARRAY I))))))
|
||||
|
||||
(DEFUN OUT2 (AS DUMMY) (OUT DSK AS))
|
||||
|
||||
;;; QUOTED LIST
|
||||
;;; TYPE 5: (<FIXNUM> . <LIST>)
|
||||
;;; TERMINATE LIST WITH -1,,<FIXNUM>
|
||||
;;; TYPE 25: TERMINATE LIST WITH -2,,0 [ENTER INTO ATOM TABLE]
|
||||
|
||||
(DEFUN BUFQTL (TYPN FORM)
|
||||
(COND ((ZEROP (BOOLE 1 20 TYPN))
|
||||
(LISTOUT (CDR FORM) NIL)
|
||||
(OUT DSK (BOOLE 7 -1_18. (LSH (CAR FORM) -18.)))
|
||||
(OUT DSK (SXHASH (CDR FORM))))
|
||||
(T (LISTOUT FORM 1)
|
||||
(OUT DSK -2_18.)
|
||||
(OUT DSK (SXHASH FORM)))))
|
||||
|
||||
;;; GETDDTSYM, TYPE 7 (<FIXNUM> . <NIL OR FIXNUM>)
|
||||
|
||||
(DEFUN BUFGET (TYPN FORM)
|
||||
(OUT DSK(CAR FORM))
|
||||
(AND (CDR FORM) (OUT DSK (CDR FORM))))
|
||||
|
||||
;;; ATOMINDEX INFO, TYPE 12 <ATOM>
|
||||
|
||||
(DEFUN BUFATX (TYPN FORM)
|
||||
(LET ((TYPE (TYPEP FORM)))
|
||||
(COND ((EQ TYPE 'SYMBOL)
|
||||
(SETQ FORM (PNGET FORM 7))
|
||||
(OUT DSK(LENGTH FORM))
|
||||
(MAPC (FUNCTION (LAMBDA (X) (OUT DSK X))) FORM))
|
||||
((EQ TYPE 'FIXNUM) (OUT DSK 1_33.) (OUT DSK FORM))
|
||||
((EQ TYPE 'FLONUM) (OUT DSK 2_33.) (OUT DSK (ROT FORM 0)))
|
||||
((EQ TYPE 'BIGNUM)
|
||||
(OUT DSK (BOOLE 7 3_33.
|
||||
(COND ((MINUSP FORM) 7_18.) (T 0))
|
||||
(LENGTH (CDR FORM))))
|
||||
(BUFBNCDR (CDR FORM)))
|
||||
(T (BUFATX
|
||||
TYPN (ERROR '|Ill-formed expression - BUFATX|
|
||||
FORM 'WRNG-TYPE-ARG))))))
|
||||
|
||||
;;; RECURSIVELY ITERATES ON CDR OF A BIGNUM TO OUTPUT COMPONENTS
|
||||
;;; IN REVERSE ORDER
|
||||
(DEFUN BUFBNCDR (N)
|
||||
(AND (CDR N) (BUFBNCDR (CDR N)))
|
||||
(OUT DSK (CAR N)))
|
||||
|
||||
;;; ENTRY INFO, TYPE 13
|
||||
;;; (((<ATOM> . <ATOM>) . <FIXNUM>) . <ARGS>)
|
||||
;;; WHERE <ARGS> IS NIL OR (<NIL OR FIXNUM> . <FIXNUM>)
|
||||
(DEFUN BUFENT (TYPN FORM)
|
||||
(OUT DSK(BOOLE 7 (LSH (ATOMINDEX (CAAAR FORM)) 18.)
|
||||
(ATOMINDEX (CDAAR FORM))))
|
||||
(OUT DSK
|
||||
(COND ((NULL (CDR FORM)) 0)
|
||||
(T (BOOLE 7 (LSH (ARGSPROPEVAL (CADR FORM)) 27.)
|
||||
(LSH (ARGSPROPEVAL (CDDR FORM)) 18.))))))
|
||||
|
||||
(DEFUN ARGSPROPEVAL (X)
|
||||
(COND ((NULL X) 0) ((< X 777) (1- X)) (T 777)))
|
||||
|
||||
;;; PUTDDTSYM, TYPE 15 <ATOM>
|
||||
|
||||
(DEFUN BUFPUT (TYPN FORM) (OUT DSK (SQOZ/| (NCONS FORM))))
|
||||
|
||||
;;; EVAL MUNGEABLE <LIST>
|
||||
;;; TYPE 16, TERMINATE WITH -1,,0 [THROW AWAY VALUE]
|
||||
;;; TYPE 36, TERMINATE WITH -2,,0 [ENTER VALUE IN ATOMTABLE]
|
||||
|
||||
(DEFUN BUFMNG (TYPN FORM)
|
||||
(COND ((ZEROP (BOOLE 1 20 TYPN))
|
||||
(LISTOUT FORM T) (OUT DSK -1_18.))
|
||||
(T (LISTOUT FORM NIL) (OUT DSK -2_18.))))
|
||||
|
||||
|
||||
;;; END OF BINARY, TYPE 17, FORM IS IGNORED
|
||||
(DEFUN BUFEND (TYPN FORM) (OUT DSK (CAR (PNGET '*FASL* 6))))
|
||||
|
||||
|
||||
;;; LISTOUT OUTPUTS AN S-EXPRESSION AS A SEQUENCE OF LIST-SPECS.
|
||||
;;; LISTOUT IS USED BY BUFFERBIN FOR VARIOUS TYPES.
|
||||
;;; EACH LIST-SPEC MAY BE AS FOLLOWS:
|
||||
;;; 0,,N THE ATOM WHOSE ATOMINDEX IS N
|
||||
;;; 100000,,N LISTIFY THE LAST N ITEMS, TO CREATE A NEW ITEM
|
||||
;;; 200000,,N MAKE A DOTTED LIST OUT OF THE LAST N+1 ITEMS
|
||||
;;; A SEQUENCE OF LIST-SPECS IS TERMINATED BY A WORD WHOSE LEFT
|
||||
;;; HALF IS -1. (LISTOUT DOES NOT GENERATE THIS WORD, BUFFERBIN
|
||||
;;; DOES.)
|
||||
;;; FLAG TELLS LISTOUT WHETHER OR NOT TO TRY TO PRESERVE
|
||||
;;; EQ-NESS, I.E. WHETHER OR NOT TO TERMINATE LIST DO WITH CHECK
|
||||
;;; FOR ATOM OR FOR ATOMINDEX.
|
||||
(DEFUN LISTOUT (X FLAG)
|
||||
(DECLARE (FIXNUM I N))
|
||||
(LET ((TYPE (TYPEP X)))
|
||||
(COND ((EQ TYPE 'RANDOM)
|
||||
(SETQ X (ERROR '|Randomness in LISTOUT| X 'WRNG-TYPE-ARG))
|
||||
(LISTOUT X FLAG))
|
||||
((NOT (EQ TYPE 'LIST)) (OUT DSK (ATOMINDEX X)))
|
||||
((DO ((I 0 (1+ I)) (Y X (CDR Y)) (FL))
|
||||
((COND ((NULL Y) (OUT DSK (BOOLE 7 1_41 I)))
|
||||
((ATOM Y)
|
||||
(OUT DSK (ATOMINDEX Y))
|
||||
(OUT DSK (BOOLE 7 2_41 I)))
|
||||
((AND (EQ FLAG T) (SETQ FL (ATOMINDEX1 Y)))
|
||||
(COND ((NULL (CAR FL))
|
||||
(SETQ FL (NCONS
|
||||
(ERROR '|No atomindex|
|
||||
Y 'WRNG-TYPE-ARG)))))
|
||||
(OUT DSK (CAR FL))
|
||||
(OUT DSK (BOOLE 7 2_41 I)))
|
||||
(FLAG (SETQ FLAG T) NIL)))
|
||||
(LISTOUT (CAR Y) FLAG))))))
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode:LISP
|
||||
;; Comment Column:40
|
||||
;; END:
|
||||
465
src/rlb/faslre.116
Executable file
465
src/rlb/faslre.116
Executable file
@@ -0,0 +1,465 @@
|
||||
;;; F A S L R E A D
|
||||
(herald FASLREAD)
|
||||
|
||||
(eval-when (eval compile) (tyipeek 12.)) ; Gobble thru end of page
|
||||
|
||||
The main functions are:
|
||||
|
||||
(FASLREADOPEN <file-spec-or-file> <optional-list-of-options>) ;lsubr
|
||||
opens the file, initializes, processes the options (read on),
|
||||
and returns a FAS-OBJ for use by FASLREAD and FASLREADCLOSE.
|
||||
(FASLREADCLOSE <fas-obj>) ;subr
|
||||
closes the file and flushes all associated arrays.
|
||||
(FASLREAD <fas-obj>) ;subr
|
||||
reads an item of interest and returns it, setting the
|
||||
special variable FASLREAD-TYPE to the type, and perhaps consing the
|
||||
type onto the front of the item, depending on the option list given to
|
||||
FASLREADOPEN.
|
||||
(FASLREADNUM <fas-obj>) ;NCALLable subr
|
||||
returns the stored fixnum, when one is stored (...read on).
|
||||
(FASLREADNUM2 <fas-obj>) ;NCALLable subr
|
||||
returns a second stored fixnum, when one is stored.
|
||||
(FASLREADSQUID <fas-obj>) ;SUBR
|
||||
returns the squid marker.
|
||||
|
||||
When the option list argument is omitted, (COMPAT EVAL ENTRY CALL) is implied.
|
||||
|
||||
The option list, when present, should be a list of symbols representing
|
||||
which kinds of fasl items should be returned (Selectors), and the form in
|
||||
which they are returned. Only items specified to be of interest are
|
||||
returned; others are skipped over to avoid undue consing.
|
||||
|
||||
Options of Form:
|
||||
ALL All loadable cruft in the file is to be returned - implies all
|
||||
Options of Interest.
|
||||
MIN Minimal info is returned, to save consing. The effect is described
|
||||
below.
|
||||
COMPAT The returned item has the type code consed on its front. The type
|
||||
code is set as EXT when it would ordinarily be CALL.
|
||||
|
||||
Options of Interest (Selectors):
|
||||
When the description refers to "fixnum stored", the fixnum is recoverable
|
||||
by calling (FASLREADNUM <fas-obj>). FASLREAD-TYPE is set to EOF at end
|
||||
of file.
|
||||
|
||||
ABS Returns (). Fixnum stored is absolute word to be loaded.
|
||||
REL Returns (). Fixnum stored is relocatable word to be loaded
|
||||
SPEC Returns the symbol whose special value cell is referred to. Fixnum
|
||||
stored is the word loaded, with rh cleared.
|
||||
CALL When MIN, returns the symbol being called, otherwise returns a list
|
||||
(opcode-symbol ac-field symbol) e.g. (CALL 2 CONS). Fixnum stored
|
||||
is the loaded word with the rh cleared. When COMPAT, FASLREAD-TYPE
|
||||
is set to EXT.
|
||||
QATOM Returns the atom being referred to. Fixnum stored is the loaded word
|
||||
with the rh cleared.
|
||||
QLIST Returns the sexp being referred to. Fixnum stored is the loaded word
|
||||
with the rh cleared. Second fixnum stored is the number of structure
|
||||
words in the fasl file.
|
||||
GLBL Tries to returns a symbol. If the value was to be negated, a list of
|
||||
/- and the symbol is returned. Fixnum stored is the internal word.
|
||||
GETDDT Returns -1 for lh relocation, else the symbol. Fixnum stored is the
|
||||
assembly time value of the symbol, if any. Second fixnum stored is
|
||||
3-entire word, 2-ac field, 1-rh only, 0-swap halves, with
|
||||
the sign bit set if the getddtsym value should be negated.
|
||||
ARRAY Returns the symbol whose array prop is referred to. Fixnum stored is
|
||||
the loaded word with rh cleared.
|
||||
ENTRY When MIN, returns the symbol, else returns a list
|
||||
(subr-name subr-type args-prop) e.g. (FOO SUBR ( () . 3)).
|
||||
Fixnum stored is the (relocatable) entry point.
|
||||
LOC Returns (). Fixnum stored is the relocatable loc location.
|
||||
PUTDDT Returns the symbol being defined. Fixnum stored is the squoze from the
|
||||
file. Second fixnum stored is a defining value, if any.
|
||||
EVAL Returns the form to be evaled.
|
||||
|
||||
------------------------------------------------------------------
|
||||
|
||||
IMPLEMENTATION --
|
||||
|
||||
A FAS-OBJ is a Lisp T-type array with 25. entries:
|
||||
(0) is byte-obj, a Lisp FIXNUM array with 10. entries: 0-8. store the
|
||||
relocation bytes, 9. and 10. store the "stored fixnums".
|
||||
(1) is index indicating current (next) relocation type byte
|
||||
(2) is Newio file object
|
||||
(3) is the atom table, a Lisp T-type array
|
||||
(4) is the maximum subscript for the atom table (1- size)
|
||||
(5) is the greatest used subscript in the atom table.
|
||||
(6) and (7) store MIN and COMPAT flags.
|
||||
(8.) thru (23.) store option flags for ABS,REL,SPEC,CALL,QATOM,QLIST,GLBL,
|
||||
GETDDT,ARRAY,UNUSED,ATOMTB,ENTRY,LOC,PUTDDT,EVAL,EOF respectively.
|
||||
(24.) is the squid marker.
|
||||
|
||||
For a discussion of FASL format, relocation bytes, and atom table,
|
||||
see .INFO.;FASL FORMAT .
|
||||
|
||||
(declare (*lexpr faslreadopen faslist faslread-error)
|
||||
(fixnum (faslreadnum) (faslreadnum2))
|
||||
(special faslread-type faslread-glbl -squid-)
|
||||
(fixnum byte word i (inc-atomtb-index) (returns-minus-1))
|
||||
(array* (notype faslread-types 1)))
|
||||
|
||||
(eval-when (eval compile)
|
||||
(or (get 'umlmac 'version) (load '((lisp)umlmac)))
|
||||
(or (get 'bitmac 'version) (load '((rlb)bitmac)))
|
||||
)
|
||||
(eval-when (compile)
|
||||
(setq defmacro-for-compiling ()
|
||||
defmacro-displace-call ()
|
||||
macro-expansion-use ()))
|
||||
|
||||
(eval-when (compile) (macro dbg (foo) foo ()))
|
||||
(eval-when (eval) (macro dbg (foo) `(and debug (progn ,@(cdr foo)))))
|
||||
|
||||
;;;Abbreviations referring to FAS-OBJ array
|
||||
;;Warning! The expansions hereof use FAS-OBJ with a FREE REFERENCE!!
|
||||
#.`(progn 'compile
|
||||
,@(do ((l '(=byte-obj =byte-index =file-obj =atomtable =atomtb-size
|
||||
=atomtb-index =min =compat =abs =rel =spec =call =qatom
|
||||
=qlist =glbl =getddt =array =unused =atomtb =entry =loc
|
||||
=putddt =eval =eof =squid)
|
||||
(cdr l))
|
||||
(i 0 (1+ i))
|
||||
(ml))
|
||||
((null l)
|
||||
(cons `(defmacro fas-obj-size () ',(1+ i))
|
||||
(nreverse ml)))
|
||||
(push `(defmacro ,(car l) () '(arraycall T FAS-OBJ ,i)) ml)))
|
||||
|
||||
;;;Abbreviations for referring to byte-obj and atomtb
|
||||
(defmacro =byte (form) `(arraycall fixnum byte-obj ,form))
|
||||
(defmacro =atom (form) `(arraycall T atomtb ,form))
|
||||
(defmacro =atom\hack (form)
|
||||
(let ((g (gensym)))
|
||||
`(let ((,g ,form))
|
||||
(atom\hack (arraycall T atomtb ,g) ,g))))
|
||||
|
||||
;;;Abbreviation for common return from DO loop in FASLREAD fcn
|
||||
(defmacro breturn (form)
|
||||
`(progn (store (=byte-index) byte-index)
|
||||
(store (=byte 9.) fixnum)
|
||||
(store (=byte 10.) fixnum2)
|
||||
(return ,form)))
|
||||
|
||||
;;Cruft to get eval'ed when loaded
|
||||
(let ((l '(abs rel spec call qatom qlist glbl getddt
|
||||
array unused atomtb entry loc putddt eval eof)))
|
||||
(array faslread-types T (length l))
|
||||
(fillarray 'faslread-types l)
|
||||
'faslread-types)
|
||||
|
||||
(setq-if-unbound faslread-glbl () ) ;This holds the globalsym names
|
||||
(setq-if-unbound faslread-forget-atom\hack ())
|
||||
|
||||
;;; Given a file spec (or a file), and a list of options, this opens the file
|
||||
;;; and returns a FAS-OBJect which can then be passed to FASLREAD.
|
||||
|
||||
(defun faslreadopen nargs
|
||||
(prog (file-obj fas-obj file options alloptions) ;keep prog for return below
|
||||
(setq file (arg 1)
|
||||
options (cond ((= nargs 2) (arg 2)) ('(compat entry eval call)))
|
||||
alloptions '(abs rel spec call qatom qlist glbl getddt
|
||||
array unused atomtb entry loc putddt eval eof))
|
||||
(when (atom options) (setq options (ncons options)))
|
||||
(when (memq 'all options)
|
||||
(setq options (nconc (delete 'all options) alloptions)))
|
||||
(setq file (mergef file '(* fasl)))
|
||||
(setq file-obj (open file '(dsk block fixnum in)))
|
||||
(cond ((*fasl*check (in file-obj)))
|
||||
('T (close file-obj) (return () )))
|
||||
(eoffn file-obj 'returns-minus-1)
|
||||
(in file-obj) ;gobble the lisp version #, immaterial
|
||||
(setq fas-obj (*array () 'T (fas-obj-size)))
|
||||
(store (=byte-index) 10.) ;init byte ptr to out of bounds
|
||||
(store (=byte-obj) (*array () 'fixnum 11.))
|
||||
(store (=file-obj) file-obj) ;The file object
|
||||
(store (=atomtable) (*array () 'T 64.)) ;The atom table
|
||||
(store (=atomtb-size) 63.) ;(1- size of atom table)
|
||||
(store (=atomtb-index) 0) ;last used index in atom table
|
||||
(store (arraycall T (=atomtable) 0) () ) ;(atomtb 0)==()
|
||||
(store (=squid) (copysymbol '-SQUID- ()))
|
||||
(do ((options options) (l `(min compat .,alloptions)))
|
||||
((null options))
|
||||
(do ((l l (cdr l)) (i 6 (1+ i)))
|
||||
((null l)
|
||||
(setq options (cons (error '|Unknown option - FASLREADOPEN|
|
||||
(car options) 'wrng-type-arg)
|
||||
(cdr options))))
|
||||
(when (eq (car options) (car l))
|
||||
(store (arraycall T fas-obj i) 'T)
|
||||
(setq options (cdr options))
|
||||
(return 'T))))
|
||||
(return fas-obj)))
|
||||
(args 'faslreadopen '(1 . 2))
|
||||
|
||||
;;;Closes the file associated with FAS-OBJ, and flushes the arrays.
|
||||
(defun faslreadclose (fas-obj)
|
||||
(and (=file-obj) (close (=file-obj)))
|
||||
(*rearray (=atomtable))
|
||||
(*rearray (=byte-obj))
|
||||
(*rearray fas-obj)
|
||||
'T)
|
||||
|
||||
(defun faslreadnum (fas-obj) (arraycall fixnum (=byte-obj) 9.))
|
||||
(defun faslreadnum2 (fas-obj) (arraycall fixnum (=byte-obj) 10.))
|
||||
(defun faslreadsquid (fas-obj) (=squid))
|
||||
|
||||
;;;FASLREAD an object and return it, setting FASLREAD-TYPE to the type.
|
||||
|
||||
(defun faslread (fas-obj)
|
||||
((lambda (ans) (cond ((=compat) (cons faslread-type ans)) (ans)))
|
||||
(do ((file-obj (=file-obj)) (atomtb (=atomtable)) (byte-index (=byte-index))
|
||||
(byte-obj (=byte-obj)) (word 0) (obj) (fixnum 0) (fixnum2 0)
|
||||
(-squid- (=squid)))
|
||||
((null file-obj) (setq faslread-type 'eof) () )
|
||||
(cond ((> (setq byte-index (1+ byte-index)) 8.)
|
||||
(setq byte-index 0)
|
||||
;;Get a word full of 9. four-bit bytes, split out the bytes,
|
||||
;;and store into BYTE-OBJ
|
||||
(do ((word (rot (in file-obj) 4) (rot word 4)) (i 0 (1+ i)))
|
||||
((> i 8.))
|
||||
(store (=byte i) (bit-and word #o17)))))
|
||||
(setq faslread-type (faslread-types (=byte byte-index)))
|
||||
(caseq faslread-type
|
||||
(abs (setq fixnum (in file-obj)) (when (=abs) (breturn () )))
|
||||
(rel (setq fixnum (in file-obj)) (when (=rel) (breturn () )))
|
||||
(spec (setq word (in file-obj) fixnum (deposit-byte word 0 18. 0))
|
||||
(when (=spec) (breturn (=atom\hack (rh-bits word)))))
|
||||
(call (setq word (in file-obj) fixnum (deposit-byte word 0 18. 0))
|
||||
(when (=compat) (setq faslread-type 'ext))
|
||||
(when (=call)
|
||||
(cond ((=min) (breturn (=atom\hack (rh-bits word))))
|
||||
('T
|
||||
(setq obj (caseq (bit-range word |4.9-4.1|)
|
||||
(2 'acall) (3 'ajcall)
|
||||
(#o14 'call) (#o15 'jcall)
|
||||
(#o16 'callf) (#o17 'jcallf)
|
||||
(#o20 'ncall) (#o21 'njcall)
|
||||
(#o22 'ncallf) (#o23 'njcalf)
|
||||
(T (bit-range word |4.9-4.1|))))
|
||||
(breturn
|
||||
(list obj ; opcode
|
||||
(bit-range word |3.9-3.6|) ; ac field
|
||||
(=atom\hack (rh-bits word))))))))
|
||||
(qatom (setq word (in file-obj) fixnum (deposit-byte word 0 18. 0))
|
||||
(when (=qatom) (breturn (=atom\hack (rh-bits word)))))
|
||||
(qlist (setq obj (faslread-list file-obj atomtb))
|
||||
(in file-obj) ;Gobble the sxhash word
|
||||
(setq fixnum2 (car obj) obj (cdr obj))
|
||||
(cond ((= (lh-bits (car obj)) (rh-bits -2))
|
||||
(store (=atom (inc-atomtb-index fas-obj))
|
||||
(cdr obj)))
|
||||
((=qlist) (setq fixnum (lsh (rh-bits (car obj)) 18.))
|
||||
(breturn (cdr obj)))))
|
||||
(glbl (setq obj (=glbl) word (in file-obj))
|
||||
(when obj ;perhaps to keep complr bug happy?
|
||||
(setq obj (cond ((= (rh-bits word) #o777777) 'R70)
|
||||
((lapfivify (rh-bits word))))
|
||||
fixnum word)
|
||||
(breturn (cond ((< word 0) `(/- ,obj)) (obj)))))
|
||||
(getddt
|
||||
(cond ((= (setq word (in file-obj)) -1)
|
||||
(when (=getddt) (breturn -1)))
|
||||
('T (when (bitp word 1_34.) (setq fixnum2 (in file-obj)))
|
||||
(when (=getddt)
|
||||
(setq obj (cond ((= (rh-bits word) #o777777) '0)
|
||||
((unsquoze word)))
|
||||
fixnum (bit-range word |4.7-4.6|))
|
||||
(when (minusp word)
|
||||
(setq fixnum (bit-or #o1_43 fixnum)))
|
||||
(breturn obj)))))
|
||||
(array (setq word (in file-obj) fixnum (deposit-byte word 0 18. 0))
|
||||
(when (=array) (breturn (=atom\hack (rh-bits word)))))
|
||||
(unused (faslread-error faslread-type))
|
||||
(atomtb (faslread-atom file-obj atomtb fas-obj))
|
||||
(entry
|
||||
(setq word (in file-obj) fixnum (in file-obj))
|
||||
(when (=entry)
|
||||
(setq obj (=atom\hack (lh-bits word)))
|
||||
(cond ((=min)
|
||||
(setq fixnum (rh-bits fixnum))
|
||||
(breturn obj))
|
||||
('T (setq obj (list obj (=atom\hack (rh-bits word))
|
||||
(cons (faslread-args1
|
||||
(bit-range fixnum |4.9-4.1|))
|
||||
(faslread-args1
|
||||
(bit-range fixnum |3.9-3.1|))))
|
||||
fixnum (rh-bits fixnum))
|
||||
(breturn obj)))))
|
||||
(loc (setq fixnum (in file-obj)) (when (=loc) (breturn () )))
|
||||
(putddt (setq fixnum2 (in file-obj) fixnum 0)
|
||||
(when (minusp fixnum2) (setq fixnum (in file-obj)))
|
||||
(when (=putddt) (breturn (unsquoze fixnum2))))
|
||||
(eval (setq obj (cdr (faslread-list file-obj atomtb)) fixnum 0)
|
||||
(cond ((= (lh-bits (car obj)) (rh-bits -2))
|
||||
(store (=atom (inc-atomtb-index fas-obj))
|
||||
(faslread-eval (cdr obj))))
|
||||
((=eval) (breturn (cdr obj)))))
|
||||
(eof ;End of binary
|
||||
(setq fixnum 0)
|
||||
(cond ((not (*fasl*check (setq word (in file-obj))))
|
||||
(faslread-error faslread-type word)))
|
||||
;;Check if another section in the file?
|
||||
(cond ((not (*fasl*check (in file-obj)))
|
||||
(close file-obj)
|
||||
(setq file-obj (store (=file-obj) () ))
|
||||
(breturn () ))
|
||||
('T (in file-obj) ;Gobble the Lisp version no.
|
||||
(store (=byte-index) 10.))))
|
||||
('T (error '|Missed data type - FASLREAD|
|
||||
faslread-type 'wrng-type-arg))))))
|
||||
|
||||
;;;Read a list (reloc code 5 or 16) and return it. The last word (-1,,n or
|
||||
;;; -2,,n) is consed on the front of the list before return.
|
||||
|
||||
(defun faslread-list (file-obj atomtb)
|
||||
(do ((word (in file-obj) (in file-obj)) (stack) (i 1 (1+ i)))
|
||||
( () )
|
||||
(declare (fixnum i))
|
||||
(caseq (bit-range word |4.9-4.7|)
|
||||
(0 (setq stack (cons (=atom\hack (rh-bits word))
|
||||
stack)))
|
||||
(1 (setq stack (pop-list stack (rh-bits word) () )))
|
||||
(2 (setq stack (pop-list (cdr stack) (rh-bits word) (car stack))))
|
||||
(3 (rplaca stack (faslread-eval (car stack))))
|
||||
(4 (setq stack (pop-list stack (rh-bits word) () ))
|
||||
(rplaca stack (makhunk (car stack))))
|
||||
(7 (unless (= (length stack) 1)
|
||||
(faslread-error 'faslread-list-stack stack))
|
||||
(return (cons i (cons word (car stack)))))
|
||||
(T (faslread-error 'faslread-list word)))
|
||||
))
|
||||
|
||||
(defun faslread-eval (form)
|
||||
(hunk -squid-
|
||||
(if (or (atom form) (not (memq (car form) '(pnput string-pnput))))
|
||||
form
|
||||
(let (((fn a1 a2) form))
|
||||
(if (and (not (atom a1))
|
||||
(eq (car a1) 'quote)
|
||||
(null (cddr a1))
|
||||
(do ((l (cadr a1) (cdr l)))
|
||||
((null l) 'T)
|
||||
(or (eq (typep (car l)) 'fixnum) (return ()))))
|
||||
`(,fn -> ,(pnput (cadr a1) ()) ,a2)
|
||||
form)))))
|
||||
|
||||
(defun faslread-list-debug (which word stack)
|
||||
(format tyo '|~&;~6a item=~d w=~d (length stack)=~d stack:~% ~s|
|
||||
which (bit-range word |4.9-4.7|) (rh-bits word) (length stack)
|
||||
stack))
|
||||
|
||||
;;;Pop N items off STACK, consing them, as popped, onto LAST. Push (i.e.,
|
||||
;;;cons) the result back onto STACK and return it.
|
||||
;;;This actually works with a hairy RPLACD due to JPG.
|
||||
|
||||
(defun pop-list (stacka ia last)
|
||||
(do ((stack stacka) (i ia (1- i)) (l last) (s) (il (length stacka)))
|
||||
((= 0 i) (cons l stack))
|
||||
(when (null stack) (error '|POP-LIST ran out of stack| (cons ia il)))
|
||||
(setq stack (cdr (setq s stack)) l (rplacd s l))))
|
||||
|
||||
;;;Read a type 12 item (atomtable info) and store in the atom table.
|
||||
(defun faslread-atom (file-obj atomtb fas-obj)
|
||||
(let ((word (in file-obj)) obj)
|
||||
(caseq (bit-range word |4.8-4.7|)
|
||||
(0 ;symbol
|
||||
(setq obj (do ((i (rh-bits word) (1- i)) (l))
|
||||
((zerop i) (pnput (nreverse l) 7))
|
||||
(setq l (cons (in file-obj) l)))))
|
||||
(1 (setq obj (in file-obj))) ; fixnum
|
||||
(2 ;flonum -- fake fixnum into flonum
|
||||
(setq obj (fsc (in file-obj) 1_18.)))
|
||||
(3 ;bignum
|
||||
(setq obj (do ((i (rh-bits word) (1- i)) (l))
|
||||
((zerop i) (bncons l))
|
||||
(setq l (cons (in file-obj) l))))
|
||||
(unless (zerop (bit-range word |3.3-3.1|))
|
||||
(setq obj (minus obj)))))
|
||||
(store (=atom (inc-atomtb-index fas-obj)) obj)
|
||||
'T))
|
||||
|
||||
|
||||
;;;Increment atom table index in FAS-OBJ
|
||||
(defun inc-atomtb-index (fas-obj)
|
||||
(let ((index (=atomtb-index)) (size (=atomtb-size)))
|
||||
(setq index (1+ index))
|
||||
;;If no more room in ATOMTB, double its size
|
||||
(when (>= (store (=atomtb-index) index) size)
|
||||
(setq size (* 2 (1+ size)))
|
||||
(*rearray (=atomtable) 'T (store (=atomtb-size) (1- size))))
|
||||
index))
|
||||
|
||||
(defun atom\hack (obj num &aux (base 10.) (*nopoint t))
|
||||
(if (or (atom obj) faslink-forget-atom\hack)
|
||||
obj
|
||||
(hunk '-ATOM- num obj)))
|
||||
|
||||
;;;Generate error message
|
||||
(defun faslread-error nargs
|
||||
(error '|FASLREAD file not in FASL format| (listify nargs) 'fail-act))
|
||||
|
||||
;;;Turn part of a word read from FASL file into part of an ARGS property.
|
||||
;;;See type 13, Entry Info
|
||||
|
||||
(defun faslread-args1 (word) (caseq word (0 () ) (#o777 word) (T (1- word))))
|
||||
|
||||
;;;Verify that a word read is *FASL* or *FASL+ in sixbit
|
||||
(defun *fasl*check (x) (= (bit-or 1 x) #.(car (pnget '*fasl+ 6))))
|
||||
|
||||
;;;Turn a fixnum representing squoze into a symbol.
|
||||
;;;Squoze characters are: 0=null, 1-12=0-9, 13-44=A-Z, 45=., 46=$, 47=%
|
||||
|
||||
(defun unsquoze (n)
|
||||
(do ((l) (n (deposit-byte n (- 36. 4) 4 0) (// n #o50)) (c 0))
|
||||
((= n 0) (implode l))
|
||||
(declare (fixnum n c))
|
||||
(cond ((= 0 (setq c (\ n #o50))) (unless (null l) (push '\ l)))
|
||||
((<= 1 c #o12) (push (+ c #.(1- #/0)) l))
|
||||
((<= #o13 c #o44) (push (+ c #.(- #/A #o13)) l))
|
||||
((= c #o45) (push '/* l))
|
||||
((= c #o46) (push '/$ l))
|
||||
((= c #o47) (push '/% l)))))
|
||||
|
||||
;Turn a GLOBALSYM index into a symbol.
|
||||
|
||||
;The number of globalsyms is LLSYMS. There are 3 tables of interest here:
|
||||
;LAPFIV has LLSYMS words of squoze symbol names, sorted in order of the squoze.
|
||||
;LSYMS has LLSYMS words of symbol values stored in historical order which
|
||||
;is different from that of LAPFIV.
|
||||
;LAP5P has LLSYMS 9-bit bytes such that LSYMS [LAP5P [j]] has the symbol value
|
||||
;for LAPFIV [j]. References to LSYMS appear in the FASL files, so for
|
||||
;efficiency this function LAPFIVIFY must do the inverse sort to LAP5P in order
|
||||
;to convert the LSYMS index into an unsquozed symbol.
|
||||
|
||||
(defun lapfivify (n)
|
||||
(when (null faslread-glbl) ;If we haven't set up the table, do so.
|
||||
(let ((llsyms (cond ((getddtsym 'llsyms))
|
||||
('T (valret '| :VP |) (getddtsym 'llsyms))))
|
||||
(lap5p (getddtsym 'lap5p)) (lapfiv (getddtsym 'lapfiv)))
|
||||
(do ((llsyms llsyms) (lap5p lap5p) (lapfiv lapfiv)
|
||||
(i 0 (1+ i)) (j 36.) (word 0) (byte 0) (l))
|
||||
((>= i llsyms)
|
||||
(setq faslread-glbl (*array () t llsyms))
|
||||
(do ((i 0 (1+ i)) (l (sortcar l '<) (cdr l)))
|
||||
((null l))
|
||||
(store (arraycall T faslread-glbl i) (cdar l))))
|
||||
(declare (fixnum llsyms lap5p lapfiv i j word)) ;Lousy place
|
||||
(when (> j 27.) (setq word (examine lap5p)
|
||||
lap5p (1+ lap5p) j 0))
|
||||
(setq byte (bit-and (rot word (setq j (+ j 9.))) #o777))
|
||||
(setq l (xcons l (cons byte (unsquoze (examine (+ lapfiv i)))))))))
|
||||
(arraycall T faslread-glbl n))
|
||||
|
||||
(lap bncons subr) ;make a positive bignum given its fixnum
|
||||
(jrst 0 bncons) ;components, most significant word first.
|
||||
(entry returns-minus-1 subr) ;used as eoffn for the fasl file
|
||||
(push p (% 0 0 fix1))
|
||||
(movni tt 1)
|
||||
(popj p)
|
||||
()
|
||||
|
||||
|
||||
;; Local Modes:
|
||||
;; Mode:LISP
|
||||
;; Comment Column:40
|
||||
;; Atom Word Mode:1
|
||||
;; END:
|
||||
294
src/rlb/faslro.71
Executable file
294
src/rlb/faslro.71
Executable file
@@ -0,0 +1,294 @@
|
||||
(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 '|MC: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
|
||||
294
src/rlb/faslro.72
Normal file
294
src/rlb/faslro.72
Normal file
@@ -0,0 +1,294 @@
|
||||
(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
|
||||
Reference in New Issue
Block a user