Added sources and build instructions for Lisp library packages

required by Macsyma. Resolves #706.

src/rlb%/fasdmp.124

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