;;; -*- Mode:LISP; Package:LAMBDA; Base:8; Readtable:ZL -*-
;;;
;;; (c) Copyright 1984,1985,1986 - Lisp Machine, Inc.
;;;


(DECLARE (SPECIAL LAM-SYMBOL-TABLE LAM-FILE-SYMBOLS-LOADED-FROM LAM-UINST-DESC
		  LAM-SYMBOLS-NAME))

 ;old slow code ..
(DEFUN old-LAM-UCODE-LOADER (MODE FILE-NAME MERGEP &OPTIONAL FILE CRAM-ADR-MAP-LOADED)
  (cond ((AND (NULL CRAM-ADR-MAP-LOADED)
	      (not (memq mode '(compare load-symbols))))
	 (format t "~%Loading straight CRAM-ADR-MAP")
	 (FAST-LOAD-STRAIGHT-CRAM-ADR-MAP)))
  (format t "~%Now processing ULOAD file")
  ;MODE -> NIL IS REGULAR LOAD
  (LET (ITM LOAD-WITHOUT-SYMBOLS-FLAG TEM
	(BASE 8) (IBASE 8) (PACKAGE (PKG-FIND-PACKAGE "LAMBDA")))
    (if (not (eq mode 'load-symbols))
	(LAM-EXECUTE-W IZERO-GOOD-PARITY T))		;assure noop cleared, etc
    ;(SETQ FILE-NAME
    ;	  (FS:MERGE-PATHNAME-DEFAULTS
    ;	    (OR FILE-NAME "SYS: UBIN; UCADR ULOAD >")))
    (COND ((EQ MODE 'LOAD-WITHOUT-SYMBOLS)
	   (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T)
	   (SETQ MODE NIL))
	  ((EQ MODE 'COMPARE) (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T)))
    (WITH-OPEN-STREAM (FILE (OR FILE (OPEN FILE-NAME 'IN)))
      (PROG (CH)
	 L  (SETQ CH (FUNCALL FILE ':TYI))
	    (COND ((MEMQ CH '(#\SPACE #\CR #\LF))
		   (GO L))
		  ((EQ CH #/-)
		   (FUNCALL FILE ':UNTYI CH)
		   (GO COM))
		  ((NOT MODE)
		   (COND ((EQ CH #/I)
			  (WRITE-CRAM-FAST (READ-FIXNUM FILE) (READ-FIXNUM FILE)))
			 ((EQ CH #/D)
			  (LAM-WRITE-A-MEM (READ-FIXNUM FILE) (READ-FIXNUM FILE)))
			 ((EQ CH #/A)
			  (LET ((ADR (READ-FIXNUM FILE)))
			    (IF (< ADR 100)
				(LAM-WRITE-M-MEM ADR (READ-FIXNUM FILE))
			      (LAM-WRITE-A-MEM ADR (READ-FIXNUM FILE)))))
			 ((EQ CH #/M)
			  (WRITE-MID (READ-FIXNUM FILE) (READ-FIXNUM FILE)))
			 (T (FERROR NIL "BAD CHAR IN FILE ~S" CH))))
		  ((EQ MODE 'COMPARE)
		   (LET ((ADR (READ-FIXNUM FILE)))
		     (COND ((EQ CH #/I)
			    (LAM-COMPARE CH
					 ADR
					 (LAM-READ-C-MEM ADR)
					 (READ-FIXNUM FILE)))
			 ((EQ CH #/D)
			  (LAM-COMPARE CH
				       ADR
				       (LAM-READ-A-MEM ADR)
				       (READ-FIXNUM FILE)))
			 ((EQ CH #/A)
			  (LET ((DATA (READ-FIXNUM FILE)))
			    (LAM-COMPARE CH
					 ADR
				       (LAM-READ-A-MEM ADR)
				       DATA)
			    (IF (< ADR 100)
				(LAM-COMPARE CH ADR (LAM-READ-M-MEM ADR) DATA))))
			 ((EQ CH #/M)
			  (LAM-COMPARE CH
				       ADR
				       (READ-MID ADR)
				       (READ-FIXNUM FILE)))
			 (T (FERROR NIL "BAD CHAR IN FILE ~S" CH)))))
		  (T (READ-FIXNUM FILE) (READ-FIXNUM FILE)))
	    (GO L)
	 COM(SETQ ITM (READ-FIXNUM FILE))
	COM1(COND ((= ITM -1) (RETURN T))
		  ((= ITM -2) (GO SYMLOD))
		  ((= ITM -3)
		   (COND ((NOT MODE)		;LOAD MICRO-CODE-SYMBOL AREA
			  (SETQ ITM (LAM-MAIN-MEMORY-LOAD FILE))
			  (GO COM1))
			 ((EQ MODE 'COMPARE)
			  (SETQ ITM (LAM-COMPARE-MAIN-MEMORY-LOAD FILE))
			  (GO COM1))
			 (T NIL)))		;SKIP TO NEXT NEGATIVE CODE
		  ((= ITM -4)
		   (READ FILE))			;FLUSH ASSEMBLER STATE INFO
		  (T (FERROR NIL "BAD UCODE COMMAND ~S" ITM)))
	    (DO () ((< (SETQ ITM (READ-FIXNUM FILE)) 0)))
	    (GO COM1)

	 SYMLOD (COND (LOAD-WITHOUT-SYMBOLS-FLAG (RETURN T)))	;LOADING BOOTSTRAP, DONT
						;AFFECT CURRENT SYMBOLS.
	    (SETQ LAM-FILE-SYMBOLS-LOADED-FROM NIL)	;In case bomb out or something.
	    (COND ((NOT (AND MERGEP (BOUNDP 'LAM-SYMBOLS-NAME)))
		   (LAM-INITIALIZE-SYMBOL-TABLE T LAM-INITIAL-SYMS)))
	 SYML1 (COND ((NUMBERP (SETQ TEM (READ FILE)))
		      (SETQ ITM TEM)
		      (LAM-END-ADDING-SYMBOLS)
		      (SETQ LAM-FILE-SYMBOLS-LOADED-FROM
			    (FUNCALL FILE ':TRUENAME))	;So EQ will work later
		      (GO COM1)))
	    (LAM-ADD-TYPED-SYMBOL TEM (READ FILE) (READ-FIXNUM FILE))
	    (GO SYML1)
	    ))))

;new fast code.  if this bombs and you dont feel like hacking it, use old code above.
(DEFUN LAM-UCODE-LOADER (MODE FILE-NAME MERGEP &OPTIONAL FILE CRAM-ADR-MAP-LOADED)
  (cond ((AND (NULL CRAM-ADR-MAP-LOADED)
	      (not (memq mode '(compare load-symbols))))
	 (format t "~%Loading straight CRAM-ADR-MAP")
	 (FAST-LOAD-STRAIGHT-CRAM-ADR-MAP)))
  (format t "~%Now processing ULOAD file")
  ;MODE -> NIL IS REGULAR LOAD
  (LET (ITM LOAD-WITHOUT-SYMBOLS-FLAG TEM
	(BASE 8) (IBASE 8) (PACKAGE (PKG-FIND-PACKAGE "LAMBDA")))
    (if (not (eq mode 'load-symbols))
	(LAM-EXECUTE-W IZERO-GOOD-PARITY T))		;assure noop cleared, etc
    ;(SETQ FILE-NAME
    ;	  (FS:MERGE-PATHNAME-DEFAULTS
    ;	    (OR FILE-NAME "SYS: UBIN; UCADR ULOAD >")))
    (COND ((EQ MODE 'LOAD-WITHOUT-SYMBOLS)
	   (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T)
	   (SETQ MODE NIL))
	  ((EQ MODE 'COMPARE) (SETQ LOAD-WITHOUT-SYMBOLS-FLAG T)))
    (WITH-OPEN-STREAM (FILE (OR FILE (OPEN FILE-NAME 'IN)))
      (PROG (CH line idx LINE-LENGTH N1 N2)
	 LL (SETQ LINE (FUNCALL FILE ':LINE-IN)
		  IDX 0
		  LINE-LENGTH (ARRAY-ACTIVE-LENGTH LINE))
	 L  (COND ((NOT (< IDX LINE-LENGTH))
		   (GO LL)))
	    (SETQ CH (AREF LINE IDX)
		  IDX (1+ IDX))
	    (COND ((MEMQ CH '(#\SPACE #\CR #\LF))
		   (GO L))
		  ((EQ CH #/-)
		   (SETQ IDX (1- IDX))
		   (GO COM))
		  ((NOT MODE)
		   (COND ((EQ CH #/I)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (WRITE-CRAM-FAST-OPTIMIZED N1 N2))
			 ((EQ CH #/D)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LAM-WRITE-A-MEM N1 N2))
			 ((EQ CH #/A)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LET ((ADR N1))
			    (IF (< ADR 100)
				(LAM-WRITE-M-MEM ADR N2)
			      (LAM-WRITE-A-MEM ADR N2))))
			 ((EQ CH #/M)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (WRITE-MID N1 N2))
			 (T (FERROR NIL "BAD CHAR IN FILE ~S" CH))))
		  ((EQ MODE 'COMPARE)
		   (COND ((EQ CH #/I)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LAM-COMPARE CH
				       N1
				       (LAM-READ-C-MEM N1)
				       N2))
			 ((EQ CH #/D)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LAM-COMPARE CH
				       N1
				       (LAM-READ-A-MEM N1)
				       N2))
			 ((EQ CH #/A)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LET ((ADR N1)
				(DATA N2))
			    (LAM-COMPARE CH
				       ADR
				       (LAM-READ-A-MEM ADR)
				       DATA)
			    (IF (< ADR 100)
				(LAM-COMPARE CH ADR (LAM-READ-M-MEM ADR) DATA))))
			 ((EQ CH #/M)
			  (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
			  (LAM-COMPARE CH
				       N1
				       (READ-MID N1)
				       N2))
			 (T (FERROR NIL "BAD CHAR IN FILE ~S" CH))))
		  (T
		   (MULTIPLE-VALUE (N1 IDX) (READ-FIXNUM-FAST LINE IDX))
		   (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))))
	    (GO LL)
	 COM(MULTIPLE-VALUE (ITM IDX) (READ-FIXNUM-FAST LINE IDX))
	COM1(COND ((= ITM -1) (RETURN T))
		  ((= ITM -2) (GO SYMLOD))
		  ((= ITM -3)
		   (COND ((NOT MODE)		;LOAD MICRO-CODE-SYMBOL AREA
			  (SETQ ITM (LAM-MAIN-MEMORY-LOAD FILE))
			  (GO COM1))
			 ((EQ MODE 'COMPARE)
			  (SETQ ITM (LAM-COMPARE-MAIN-MEMORY-LOAD FILE))
			  (GO COM1))
			 (T NIL)))		;SKIP TO NEXT NEGATIVE CODE
		  ((= ITM -4)
		   (READ FILE))			;FLUSH ASSEMBLER STATE INFO
		  (T (FERROR NIL "BAD UCODE COMMAND ~S" ITM)))
	    (DO () (())
	      (SETQ LINE (FUNCALL FILE ':LINE-IN)
		    IDX 0
		    LINE-LENGTH (ARRAY-ACTIVE-LENGTH LINE))
	      ;can't call read-fixnum-fast if line is blank
	      (COND ((STRING-SEARCH-NOT-SET '(#\SPACE #\TAB) LINE)
		     (MULTIPLE-VALUE (ITM IDX) (READ-FIXNUM-FAST LINE IDX))
		     (COND ((< ITM 0) (RETURN))))))
	    (GO COM1)

	 SYMLOD (COND (LOAD-WITHOUT-SYMBOLS-FLAG (RETURN T)))	;LOADING BOOTSTRAP, DONT
						;AFFECT CURRENT SYMBOLS.
	    (SETQ LAM-FILE-SYMBOLS-LOADED-FROM NIL)	;In case bomb out or something.
	    (COND ((NOT (AND MERGEP (BOUNDP 'LAM-SYMBOLS-NAME)))
		   (LAM-INITIALIZE-SYMBOL-TABLE T LAM-INITIAL-SYMS)))
	 SYML1  (SETQ LINE (FUNCALL FILE ':LINE-IN)
		      IDX 0
		      LINE-LENGTH (ARRAY-ACTIVE-LENGTH LINE))
	    (COND ((ZEROP LINE-LENGTH)
		   (GO SYML1)))
	      (MULTIPLE-VALUE (TEM IDX) (READ-FROM-STRING LINE NIL IDX))
	      (COND ((NUMBERP TEM)
		      (SETQ ITM TEM)
		      (LAM-END-ADDING-SYMBOLS)
		      (SETQ LAM-FILE-SYMBOLS-LOADED-FROM
			    (FUNCALL FILE ':TRUENAME))	;So EQ will work later
		      (GO COM1)))
	      (MULTIPLE-VALUE (N1 IDX) (READ-FROM-STRING LINE NIL IDX))
	      (MULTIPLE-VALUE (N2 IDX) (READ-FIXNUM-FAST LINE IDX))
	      (LAM-ADD-TYPED-SYMBOL TEM N1 N2)
	      (GO SYML1)
	    ))))

(DEFUN LAM-ADD-TYPED-SYMBOL (SYM TYPE VAL)
   (COND ((EQ TYPE 'I-MEM) (SETQ VAL (+ VAL RACMO)))
         ((EQ TYPE 'A-MEM) (SETQ VAL (+ VAL RAAMO)))
         ((EQ TYPE 'M-MEM) (SETQ VAL (+ VAL RAMMO)))
         ((EQ TYPE 'D-MEM) (SETQ VAL (+ VAL RADMO)))
         ((EQ TYPE 'NUMBER))
         (T (PRINT (LIST SYM TYPE VAL))
            (BREAK "BAD-SYMBOL-TYPE")))
   (LAM-ADD-SYMBOL SYM VAL))

;only wins on LISP machine
(DEFUN COMPARE-LMC-FILE (FILE-NAME
			 &optional (memories-to-compare '(A I D MID MAIN-MEM)))
  (if (null file-name)
      (setq file-name (lam-ucode-version-from-machine)))
  (IF (NUMBERP FILE-NAME)
      (let ((pn (fs:parse-pathname (base-filename-for-version file-name))))
	(setq pn (funcall pn ':new-type "LMC"))
	(setq file-name (funcall pn ':new-version file-name))))
  (WITH-OPEN-FILE (STREAM FILE-NAME ':CHARACTERS NIL)
    (PROG (HCODE LCODE HADR LADR HCOUNT LCOUNT HD LD
	   UDSP-NBLKS UDSP-RELBLK FILE MACH)
    L0 (SETQ LCODE (FUNCALL STREAM ':TYI) HCODE (FUNCALL STREAM ':TYI))
       (COND ((OR (NOT (ZEROP HCODE)) (< LCODE 0) (> LCODE 5))
	      (FERROR NIL "BAD CODE HCODE=~O LCODE=~O" HCODE LCODE)))
       (SETQ LADR (FUNCALL STREAM ':TYI) HADR (FUNCALL STREAM ':TYI))
       (SETQ LCOUNT (FUNCALL STREAM ':TYI) HCOUNT (FUNCALL STREAM ':TYI))
       (COND ((OR (NOT (ZEROP HADR))
		  (NOT (ZEROP HCOUNT)))
	      (FERROR NIL "BAD HEADER SA ~O,~O COUNT ~O,~O"
		      HADR LADR HCOUNT LCOUNT)))
       (FORMAT T "~%CODE: ~D, ADR: ~D, COUNT: ~D" LCODE LADR LCOUNT)
       (COND ((ZEROP LCODE)
	      (COND (UDSP-NBLKS
		     (FUNCALL STREAM ':SET-POINTER (* 2 UDSP-RELBLK SI:PAGE-SIZE))
		     (DO ((ADR 1400 (1+ ADR))
			  (FIN (+ 1400 (* UDSP-NBLKS SI:PAGE-SIZE))))
			 ((= ADR FIN))
		       (COND ((NOT (= (SETQ MACH (PHYS-MEM-READ ADR)) 
				      (SETQ FILE
					    (LET ((LOW (FUNCALL STREAM ':TYI)))
					      (DPB (FUNCALL STREAM ':TYI) 2020 LOW)))))
			      (FORMAT T "~%Main mem adr ~S// file ~S machine ~S"
				      ADR FILE MACH))))))
	      (CLOSE STREAM)
	      (RETURN T))
	     ((= LCODE 1)
	      (IF (MEMQ 'I MEMORIES-TO-COMPARE)
		  (GO LI)		;I-MEM
		(GO IGNORE-I)))
	     ((= LCODE 2) (GO LD))		;D-MEM
	     ((= LCODE 3)			;HACK MAIN MEMORY LOAD LATER.
	      (SETQ UDSP-NBLKS LADR)
	      (SETQ UDSP-RELBLK LCOUNT)
	      (SETQ LD (FUNCALL STREAM ':TYI) HD (FUNCALL STREAM ':TYI))	;PHYS MEM ADR
	      (GO L0))
	     ((= LCODE 4) (GO LA))		;A-MEM
	     ((= LCODE 5)
	      (IF (MEMQ 'MID MEMORIES-TO-COMPARE)
		  (GO LMID)		;macro-ir-decode memory
		(GO IGNORE-MID)))
	     (T (FERROR NIL "BAD CODE ~S" LCODE)))
    LD (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	      (GO L0)))
       (LAM-COMPARE-UCODE-WD (+ LADR RADMO)
			     (FUNCALL STREAM ':TYI)
			     (FUNCALL STREAM ':TYI)
			     0
			     0)
       (SETQ LADR (1+ LADR))
       (GO LD)
    LA (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	      (GO L0)))
       (LAM-COMPARE-UCODE-WD (+ LADR RAAMO)
			     (FUNCALL STREAM ':TYI)
			     (FUNCALL STREAM ':TYI)
			     0
			     0)
       (SETQ LADR (1+ LADR))
       (GO LA)
    LI (write-pc ladr)
   LI0 (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	      (GO L0)))
       (LET ((W1 (FUNCALL STREAM ':TYI))
	     (W2 (FUNCALL STREAM ':TYI))
	     (W3 (FUNCALL STREAM ':TYI))
	     (W4 (FUNCALL STREAM ':TYI))
	     (RD0 (READ-LOW-CRAM))
	     (RD1 (READ-HIGH-CRAM)))
	 (COND ((OR (NOT (= W1 (LDB 0020 RD0)))
		    (NOT (= W2 (LDB 2020 RD0)))
		    (NOT (= W3 (LDB 0020 RD1)))
		    (NOT (= W4 (LDB 2020 RD1))))
		(let ((page (read-cram-adr-map (ash ladr -4))))
		  (cond ((= page micro-fault-page))
			((= page (ash ladr -4))
			 (FORMAT T "~%FAST MISCOMPARE")
			 (LAM-COMPARE-UCODE-WD (+ LADR RACMO) W1 W2 W3 W4))
			(t
			 (format t "~%CRAM-ADR-MAP @~o is ~s, should be straight map"
				 (ash ladr -4)
				 page))))
		(write-pc ladr))))	;get back into phase.
       (LAM-EXECUTE-UINST-CLOCK-PLUS-UINST-CLOCK-LOW IZERO-GOOD-PARITY T)
       (SETQ LADR (1+ LADR))
       (GO LI0)
IGNORE-I
       (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	      (GO L0)))
       (FUNCALL STREAM ':TYI)
       (FUNCALL STREAM ':TYI)
       (FUNCALL STREAM ':TYI) 
       (FUNCALL STREAM ':TYI)
       (SETQ LADR (1+ LADR))
       (GO IGNORE-I)
    LMID(COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	       (GO L0)))
       (LAM-COMPARE-UCODE-WD (+ LADR RAMIDO)
			     (FUNCALL STREAM ':TYI)
			     (FUNCALL STREAM ':TYI)
			     0
			     0)
       (SETQ LADR (1+ LADR))
       (GO LMID)
IGNORE-MID
       (COND ((< (SETQ LCOUNT (1- LCOUNT)) 0)
	       (GO L0)))
       (FUNCALL STREAM ':TYI)
       (FUNCALL STREAM ':TYI)
       (SETQ LADR (1+ LADR))
       (GO IGNORE-MID)
       )))

(DEFUN LAM-COMPARE-UCODE-WD (REG-ADR WD1 WD2 WD3 WD4)
  (DECLARE (FIXNUM REG-ADR))
  (PROG (RD1 RD2 RD3 RD4 FILE-WD MACHINE-WD)
	(DECLARE (FIXNUM RD1 RD2 RD3))
	(SETQ MACHINE-WD (LAM-REGISTER-EXAMINE REG-ADR))
	(SETQ RD1 (LOGLDB 0020 MACHINE-WD)
	      RD2 (LOGLDB 2020 MACHINE-WD)
	      RD3 (LOGLDB 4020 MACHINE-WD)
	      RD4 (LOGLDB 6020 MACHINE-WD))
	(COND ((AND (NOT (AND (= WD1 RD1) (= WD2 RD2)
			      (= WD3 RD3) (= WD4 RD4))) ;IF DOESN'T MATCH
		    (NOT (AND (= WD1 0) (= WD2 0)
			      (= WD3 0) (= WD4 0))))	;AND NOT LOADED ZERO
							; WHICH WOULD PROBABLY BE A 
							; VARIABLE WHICH IS OK TO CHANGE
	       (TERPRI)
	       (LAM-PRINT-ADDRESS REG-ADR)
	       (FORMAT T " FILE ")
	       (SETQ FILE-WD (LOGDPB WD4 6020 (LOGDPB WD3 4020 (LOGDPB WD2 2020 WD1))))
	       (PRIN1-THEN-SPACE FILE-WD)
	       (AND (< REG-ADR RACME)
		    (LAM-TYPE-OUT FILE-WD LAM-UINST-DESC T T))
	       (FORMAT T "~%ADR: ")
	       (LAM-PRINT-ADDRESS REG-ADR T)
	       (FORMAT T " MACHINE ")
	       (PRIN1-THEN-SPACE MACHINE-WD)
	       (AND (< REG-ADR RACME)
		    (LAM-TYPE-OUT MACHINE-WD LAM-UINST-DESC T T))
	       (FORMAT T "~%BITS: ")
	       (PRINT-BITS (LOGXOR FILE-WD MACHINE-WD))
	       (PRINT '-----))))
  (COND ((AND (NOT (< REG-ADR RAAMO))		;if loading low A, also check M
	      (< REG-ADR (+ 100 RAAMO)))
	 (LAM-COMPARE-UCODE-WD (+ (- REG-ADR RAAMO) RAMMO) WD1 WD2 WD3 WD4))))

(DEFUN LAM-MAIN-MEMORY-LOAD (FILE)
  (PROG (ADR ITM)
	(DECLARE (FIXNUM ADR ITM))
	(SETQ ADR (READ-FIXNUM FILE))
  L	(COND ((< (SETQ ITM (READ-FIXNUM FILE)) 0) (RETURN ITM)))
	(PHYS-MEM-WRITE ADR ITM)
	(SETQ ADR (1+ ADR))
	(GO L)))

(DEFUN LAM-COMPARE (MEMORY-CODE LOCATION MACHINE FILE)
  (COND ((NOT (= FILE MACHINE))
	 (FORMAT T "~%MISCOMPARE: MEMORY ~C, LOCATION ~S, FILE ~S, MACHINE ~S, BITS "
		 MEMORY-CODE
		 LOCATION
		 FILE
		 MACHINE)
	 (PRINT-BITS (LOGXOR FILE MACHINE)))))

(DEFUN LAM-COMPARE-MAIN-MEMORY-LOAD (FILE)
  (PROG (ADR ITM TEM)
	(DECLARE (FIXNUM ADR ITM TEM))
	(SETQ ADR (READ-FIXNUM FILE))
  L	(COND ((< (SETQ ITM (READ-FIXNUM FILE)) 0) (RETURN ITM)))
  	(COND ((NOT (= ITM (SETQ TEM (PHYS-MEM-READ ADR))))
	       (FORMAT T "~%MAIN MEM ADR ~S, FILE ~S, MACHINE ~S"
		       ADR
		       ITM
		       TEM)))
	(SETQ ADR (1+ ADR))
	(GO L)))

(DEFUN READ-FIXNUM (FILE)		;HOPEFULLY FAST NUMBER-ONLY READER
  (PROG (CH NUM SGN)
	(SETQ NUM 0 SGN 1)
  A	(IF (OR (< (SETQ CH (TYI FILE)) 41)  ;IGNORE LEADING GARBAGE
		(> CH 177))
	    (GO A))
	(COND ((= CH #/-)
	       (SETQ SGN -1))
	      (T (GO C)))
  B	(SETQ CH (TYI FILE))
  C	(COND ((= CH #/_)
	       (RETURN (* SGN (ASH NUM (READ-FIXNUM FILE)))))
	      ((AND (>= CH #/0) (<= CH #/7))
	       (SETQ NUM (+ (ASH NUM 3) (- CH #/0)))
	       (GO B))
	      ((> CH 40)
	       (FERROR nil "NON-OCTAL-NUMBER-CHAR-IN-READ-FIXNUM" CH)))
	(RETURN (* SGN NUM))))

(DEFUN READ-FIXNUM-FAST (LINE IDX)		;HOPEFULLY FAST NUMBER-ONLY READER
  (PROG (CH NUM SGN)
	(SETQ NUM 0)
  A	(SETQ CH (AREF LINE IDX)
	      IDX (1+ IDX))
	(IF (OR (< CH 41)  ;IGNORE LEADING GARBAGE
		(> CH 177))
	    (GO A))
	(COND ((= CH #/-)
	       (SETQ SGN T))
	      (T (GO C)))
  B	(SETQ CH (AREF LINE IDX)
	      IDX (1+ IDX))
  C	(COND ((= CH #/_)
	       (MULTIPLE-VALUE (CH IDX) (READ-FIXNUM-FAST LINE IDX))
	       (RETURN
		 (values
		   (ASH (COND (SGN (MINUS NUM))
				  (T NUM))
			CH)
		   IDX)))
	      ((AND (>= CH #/0) (<= CH #/7))
	       (SETQ NUM (+ (ASH NUM 3) (- CH #/0)))
	       (GO B))
	      ((> CH 40)
	       (FERROR nil "non-octal CHAR-IN-READ-FIXNUM" ch)))
	(RETURN (values (COND (SGN (MINUS NUM)) (T NUM))
			IDX))))


;; Copied from LAD: RELEASE-3.LAMBDA-DIAG; LAM.LISP#91 on 2-Oct-86 17:53:24
(ADD-INITIALIZATION "Assure LAM Symbols Loaded"
		    '(ASSURE-LAM-SYMBOLS-LOADED (not si:*in-cold-load-p*))
		    '(:BEFORE-COLD :NOW))
(net:move-initialization si:before-cold-initialization-list "Deconfigure Network System" "Assure LAM Symbols Loaded")

(ADD-INITIALIZATION "Assure LAM Symbols Loaded"
		    '(ASSURE-LAM-SYMBOLS-LOADED (not si:*in-cold-load-p*))
		    '(:head-of-list :gc-system-release))

(defun maybe-remove-extra-lam-symbol-tables ()
  (when lam-file-symbols-loaded-from
    (let ((extras (cl:remove lam-file-symbols-loaded-from lam-symbol-tables-loaded :key #'car)))
      (when extras
	(when (format:y-or-n-p-with-timeout 1800. t
		"Current LAM symbols are for version ~D, but extra versions also loaded: ~{~D~^, ~}~%~
      Remove extras? "
		(send lam-file-symbols-loaded-from :version)
		(mapcar #'(lambda (elt)
			    (send (car elt) :version))
			extras))
	  (setq lam-symbol-tables-loaded (cl:remove-if #'(lambda (elt)
							   (member elt extras)) lam-symbol-tables-loaded)))))))

(add-initialization "Maybe Remove Extra LAM Symbols"
		    '(maybe-remove-extra-lam-symbol-tables)
		    '(:gc-system-release))