;;; -*- Mode:LISP; Package:SDU; Base:10; Readtable:ZL -*-


;;; Copyright LISP Machine, Inc. 1986
;;;   See filename "Copyright.Text" for		
;;; licensing and release information.


; bobp
; read and print sdu config file
;
; requires unix-fs.lisp and c-funcs.lisp
;
; (print-config-file)
;    prints most useful info from config file.
; (print-config-file t)
;    prints everything.
;
; (get-list-of-boards)
;    returns a list of the per-slot structures for all nubus slots.
;    use the per-slot defstruct to access them.
;
; (all-disabled-memory-boards)
;    returns a list of the disabled memory boards
;       each element of list is a list of (slot-number board-type)
;    see board-types for the board types.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; per-slot structure in "resource map" section of config file
; see /usr/86include/sys/lmi-config.h

; sections of the file
(defvar config-image)
(defvar sys-conf-image)

;;(defvar slot-array-image (make-array 32))

; board names
; use (nth (ps-board-type ps) board-types)
(defconst board-types '(unknown none LMI-LAMBDA mc68000 sdu vcmem half-meg
				two-meg medium-color buscoupler ti-eight-meg
				lmi-four-meg lmi-sixteen-meg quad-video
				nubus-disk lmi-eight-meg LMI-LAMBDA-avp lmi-twelve-meg))

(assign-values board-types)
(mapc #'(lambda (x) (putprop x t 'special)) board-types)

(defprop half-meg 512. memory-size)
(defprop two-meg 2048. memory-size)
(defprop ti-eight-meg 8192. memory-size)
(defprop lmi-four-meg 4096. memory-size)
(defprop lmi-sixteen-meg 16380. memory-size)
(defprop lmi-eight-meg 8192. memory-size)
(defprop lmi-twelve-meg 12288. memory-size)

; (mapcar '(lambda (x) (format t "~&~(~s~) ~a" x (get x 'memory-size))) board-type-strings)

(defvar console-types '("serial-port-A" "vcmem" "quad" "sharetty" "serial-port-B"))

(defun mem-board-p (slot)
  "size in pages if memory board, nil if not"
  (get (nth (ps-board-type slot) board-types) 'memory-size))

(defun console-type-string (type)
  (nth type console-types))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar verbose-p nil)

(defun print-config-file (&optional verbose-p)
  "read and print contents of sdu config file"
  (get-config-file)
  (set-up-config-arrays)
  (print-from-list cf-header-qs config-image)
  (print-slot-info))

(defun get-list-of-boards ()
  "return a list of per-slot structures for all slots"
  (get-config-file)
  (set-up-config-arrays)
  (let ((return-list nil))
    (dotimes (i 32)
      (push (aref slot-array-image (- 31 i)) return-list))
    return-list))

; top level function for memory diagnostic

(defun all-disabled-mem-boards ()
  "return list of lists of car slot-number, cdr board-type symbol, for disabled memory boards"
  (set-up-config-arrays)
  (do ((i 0 (1+ i))
       (return-list nil))
      ((= i 32)
       return-list)
    (let ((slot (aref slot-array-image i)))
      (if (and (= 1 (ps-disabled slot))
	       (mem-board-p slot))
	  (push (cons (ps-slot-number slot) (nth (ps-board-type slot) board-types))
		return-list)))))

;;;;;;;;;;;;;;;;

; accessors for config file header

;; 32-bit words
(defconst cf-header-qs
	  '(cf-header-version
	     cf-header-bootable-p
	     cf-header-whole-shared-area-addr
	     cf-header-whole-shared-area-size
	     cf-header-sys-config-addr
	     cf-header-sys-config-size
	     cf-header-slot-array-file-offset
	     cf-header-slot-array-per-slot-size
	     cf-header-sys-config-file-offset
	     cf-header-slot-map-file-offset
	     cf-header-slot-map-size))
(assign-values cf-header-qs)

(defprop cf-header-whole-shared-area-addr 16. :radix)
(defprop cf-header-whole-shared-area-size 16. :radix)
(defprop cf-header-sys-config-addr 16. :radix)
(defprop cf-header-sys-config-size 16. :radix)

(defprop cf-header-version t :verbose)
(defprop cf-header-bootable-p t :verbose)
(defprop cf-header-slot-array-file-offset t :verbose)
(defprop cf-header-slot-array-per-slot-size t :verbose)
(defprop cf-header-sys-config-file-offset t :verbose)
(defprop cf-header-slot-map-file-offset t :verbose)
(defprop cf-header-slot-map-size t :verbose)

;;;;;;;;;;;;;;;;

(defun print-from-list (words ar)
  (let ((len (loop for l in words
		   maximize (length (symbol-name l)))))
    (dolist (l words)
      (when (or verbose-p (not (get l :verbose)))
	(let ((radix (or (get l :radix) 10.)))
	  (format t "~&~Va ~a" (+ 2 len) l (fancy-print-in-base (reff l ar) radix))))
      )))

;; maybe try printing multiple times if b is a list of radices.
(defun fancy-print-in-base (v b)
  (selectq b
    (16.
     (format nil "#x~x" v))
    (10.
     (format nil "~d." v))
    (8
     (format nil "~a~o" (if (> v 7) "0" "") v))
    (t
     (format nil "~Vr (~d)" b v b))
    ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar config-file-array nil)

(defun get-config-file ()
  (let ((file (open-unix-file "//sdu//lambda//shr-config.1")))
    (if (null config-file-array)
	(setq config-file-array (make-array (unix-file-size file) :type :art-8b)))
    (rw-file :read file config-file-array (unix-file-size file)))
  config-file-array)

(defun set-up-config-arrays ()
  (setq config-image (get-config-file))
  (setq sys-conf-image (make-array (ch-sys-config-size config-image)
			 :type :art-8b
			 :displaced-to config-image
			 :displaced-index-offset (ch-sys-config-file-offset config-image))))

(defun print-slot-info ()
  (dotimes (i 32)
    (let* ((offs (reff 'cf-header-slot-array-file-offset config-image))
	   (size (reff 'cf-header-slot-array-per-slot-size config-image))
	   (ar (make-array size
			   :type :art-8b
			   :displaced-to config-image
			   :displaced-index-offset (+ offs (* i size)))))
      (when (or verbose-p
		(not (= 1 (reff 'cf-slot-board-type ar))))
	(print-from-list cf-slot-qs ar)
	(format t "~2&"))
      )))

(defconst cf-slot-qs
	  '(cf-slot-board-type
	     cf-slot-disabled
	     cf-slot-slot-number
	     cf-slot-mem-size
	     cf-slot-options
	     cf-slot-major-version
	     cf-slot-minor-version))

(defprop cf-slot-board-type 0 :offset)
(defprop cf-slot-board-type 2 :size)
(defprop cf-slot-disabled 2 :offset)
(defprop cf-slot-disabled 2 :size)
(defprop cf-slot-slot-number 4 :offset)
(defprop cf-slot-slot-number 2 :size)
(defprop cf-slot-mem-size 12 :offset)
(defprop cf-slot-options 16 :offset)
(defprop cf-slot-major-version 24 :offset)
(defprop cf-slot-major-version 2 :size)
(defprop cf-slot-minor-version 28 :offset)
(defprop cf-slot-minor-version 2 :size)


(defun yes-no-string (n)
   (if (zerop n)
      "no"
    "yes"))

(defun print-one-info-slot (slot)
  (format t "~& ")
  (format t "~&~15a ~d" "slot number" (ps-slot-number slot))
  (format t "~&~15a ~(~s~)" "board type" (nth (ps-board-type slot) board-types))
  (if (not (= 0 (ps-disabled slot)))
      (format t "~&~15a" "disabled"))
  (if (or verbose-p
	  (and (not (= 0 (ps-mem-size-if-processor slot)))
	       (not (= #xffffffff (ps-mem-size-if-processor slot)))))
      (format t "~&~15a ~x" "memory size" (ps-mem-size-if-processor slot)))
  (if verbose-p
      (format t "~&~15a ~d" "option offset" (ps-options slot)))
  (if verbose-p
      (format t "~&~15a ~d" "option size" (ps-options-size slot)))
  (if (not (= 0 (ps-major-version slot)))
      (format t "~&~15a ~d.~d" "board version"
	      (ps-major-version slot)
	      (ps-minor-version slot)))
  (cond ((not (= 0 (ps-options slot)))
	 (if verbose-p
	     (format t "~&  ~(~s~) option structure:"
		     (nth (ps-board-type slot) board-types)))
	 (select (ps-board-type slot)
	   (mc68000
	    (print-68000-options slot))
	   (LMI-LAMBDA
	    (print-lambda-options slot))
	   (vcmem
	    (print-vcmem-options slot))
	   (quad-video
	    (print-quad-options slot))
	   (sdu
	    (print-sdu-options slot))
	   (t
	    (if (not (= 0 (ps-mem-size-if-processor slot)))
		(print-memory-options slot)
	      (format t "~&~a has an option structure!"
		      (nth (ps-board-type slot) board-types)))))))
  )

(defun option-image (per-slot)
  (make-array (ps-options-size per-slot)
	      :type :art-8b
	      :displaced-to config-image
	      :displaced-index-offset (ps-options per-slot)))

(defun print-68000-options (slot)
  (let* ((x (option-image slot))
	(skip-devmap (+ 8 (get-n-bytes x 4 4) (get-n-bytes x 8 4))))
    (format t "~&    ~15a~a" "screen" (vcm-slot-string (get-n-bytes x 0 4)))
    (if verbose-p
	(format t "~&    ~15a~d" "devmap size" (get-n-bytes x 4 4)))
    (if verbose-p
	(format t "~&    ~15a~d" "n sharettys" (get-n-bytes x (+ 0 skip-devmap) 2)))
    (format t "~&    ~15a~a" "console type" (console-type-string
					      (get-n-bytes x (+ 2 skip-devmap) 2)))))

(defun print-lambda-options (slot)
  (let ((x (option-image slot)))
    (format t "~&    ~15a~d-~d" "speed" (get-n-bytes x 0 2) (get-n-bytes x 4 2))
    (format t "~&    ~15a~a" "screen" (vcm-slot-string (get-n-bytes x 8 4)))
    (format t "~&    ~15a0~o" "switches" (get-n-bytes x 12 4))
    (format t "~&    ~15a~a" "t-ram name" (ascii-string (c-str-copy x 20)))
    (format t "~&    ~15a~a" "micro-load" (ascii-string (c-str-copy x 80)))
    (format t "~&    ~15a~a" "load band" (ascii-string (c-str-copy x 86)))
    (format t "~&    ~15a~a" "page" (ascii-string (c-str-copy x 92)))
    (format t "~&    ~15a~a" "file" (ascii-string (c-str-copy x 98)))
    (if verbose-p
	(format t "~&    ~15a0~o" "base map reg" (get-n-bytes x 104 4)))
    (if (or verbose-p
	    (not (= 0 (get-n-bytes x 108 4))))
	(format t "~&    ~15a0~o" "parity enables" (get-n-bytes x 108 4)))
    (if verbose-p
	(format t "~&    ~15a0~o" "map size" (get-n-bytes x 112 2)))
    (if (or verbose-p
	    (not (= 32 (get-n-bytes x 114 2))))
	(format t "~&    ~15a~d." "scan line size" (get-n-bytes x 114 2)))
    ))

(defun vcs-slot-number (vcm-slot)
  (ldb (byte 8 0) vcm-slot))

(defun vcs-screen-number (vcm-slot)
  (ldb (byte 8 16) vcm-slot))

(defun vcs-present-p (vcm-slot)
  (= 0 (ldb (byte 8 16) vcm-slot)))

(defun vcm-slot-string (vcm-slot)
  (with-output-to-string (*standard-output*)
    (cond ((vcs-present-p vcm-slot)
	   (let ((board-type (ps-board-type (aref slot-array-image (vcs-slot-number vcm-slot)))))
	     (if (= board-type quad-video)
		 (format t "screen ~d of quad-video" (vcs-screen-number vcm-slot))
	       (format t "vcmem"))
	     (format t " in slot ~d" (vcs-slot-number vcm-slot))))
	  (t
	   (format t "none assigned")))))

(defun vcm-location (slot index)
  (let ((x (option-image slot)))
    (ascii-string (c-str-copy x (+ 4 (* 84. index))))))

(defun print-vcmem-options (slot)
  (format t "~&    ~15a~a" "location" (vcm-location slot 0)))

(defun print-quad-options (slot)
  (dotimes (i 4)
    (format t "~&    ~15a~a" "location" (vcm-location slot i))))

(defun print-sdu-options (slot)
  (let ((x (option-image slot)))
    (format t "~&    ~20a~a" "nubus code size" (get-n-bytes x 0 4))
    (format t "~&    ~20a~a" "user-def area size" (get-n-bytes x 4 4))
    (format t "~&    ~20a~a" "user-def map pages" (get-n-bytes x 8 4))))

(defun bad-mem-addr (opt index)
  (get-n-bytes opt (+ 12. (* 8 index)) 4))

(defun bad-mem-size (opt index)
  (get-n-bytes opt (+ 16. (* 8 index)) 4))

(defun print-memory-options (slot)
  (let ((x (option-image slot)))
    (format t "~&    ~20a~a" "bad-list size" (get-n-bytes x 0 2))
    (format t "~&    ~20a~a" "n bad sections" (get-n-bytes x 2 2))
    (dotimes (i (get-n-bytes x 2 2))
      (format t "~&     addr=~16r size=~d" (bad-mem-addr x i) (bad-mem-size x i)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun rand ()
  (ash (random (ash 2 32)) (- (random 32))))

;;;;;;;;;;;;;;;;

(defun reff (sym ar &optional new)
  (let* ((size (or (get sym :size) 4))
	 (mult (or (get sym :mult) 4))
	 (offset (or (get sym :offset) (* (symeval sym) mult))))
    ;;(format t "~&~s" ar)
    ;;(format t "~&size=~d mult=~d offset=~d" size mult offset)
    (cond
      (new
       (set-bytes ar offset size new))
      (t
       (get-bytes ar offset size)))
    ))

(defsetf reff reff)

(defun get-bytes (ar offs size)
  (loop for i from 0 below size
	for b from 0 by 8
	sum (ash (aref ar (+ i offs)) b)))

(defun set-bytes (ar offs size new)
  (loop for i from 0 below size
	for b from 0 by 8
	do (setf (aref ar (+ i offs)) (ldb (byte 8 b) new)))
  new)