;;; -*- Mode:LISP; Package:SIMULATOR; Readtable:CL; Base:10 -*-

;;; This is the stuff which processes the "OPCODE-FIELD-DEFS" file.
;;; Loading "OPCODE-FIELD-DEFS" will modify INSTRUCTION-FIEL-DATABASE
;;; with descriptions for the bit fields of each instruction type.
;;; Once the file is loaded, you can run the function (VERIFY-INSTRUCTION-DATABASE).
;;; This will write out a list of errors as well as a copy of the instruction
;;; byte field database, sorted by instruction type and field bit position into an
;;; editor buffer named "INSTRUCTION-DATABASE".
;;; The errors describe places in the word description for the instruction type
;;; for which a bit is either multiply-defined or undefined.  An absence of errors
;;; is a guarantee that all 64 bits are in exactly one bit field.

;;; The types of instuction are ALU, ALU-16-BIT-IMMEDIATE, ALU-24-BIT-IMMEDIATE, LOAD-32-BIT-IMMEDIATE,
;;; FLOATING-POINT-ALU, FLOATING-POINT-MULTIPLIER, CONDITIONAL-BRANCH, CALLZ, JUMP, CALL and CALL-DISPATCH
(defconst instruction-types
	  '(
	    COMMON
	    ALU
	    ALU-16-BIT-IMMEDIATE
	    ALU-24-BIT-IMMEDIATE
	    LOAD-32-BIT-IMMEDIATE
	    FLOATING-POINT-ALU
	    FLOATING-POINT-MULTIPLIER
	    CONDITIONAL-BRANCH
	    CALLZ
	    JUMP
	    CALL
	    CALL-DISPATCH
	    ))

(defconst instruction-field-database (mapcar 'list instruction-types)
  "an alist, the CARs of each element are the instruction types and the CDRs
are lists of (FIELD-NAME . BYTE-SPEC)")

;;; figure out what this should do later
(defmacro def-inst-fields (instruction-types &rest field-descriptors)
  (do* ((fds field-descriptors (cddr fds))
	(field-name (first fds) (first fds))
	(field-byte (second fds) (second fds))
	(forms nil))
       ((null fds) (cons 'progn forms))
    (dolist (i instruction-types)
      (push `(def-inst-field ',i ',field-name ,field-byte)
	    forms)
      )))

(defun def-inst-field (instruction-type field-name field-byte)
  (let ((inst-fields (assoc instruction-type instruction-field-database))
	)
    (push (cons field-name field-byte) (cdr inst-fields))))

(defun verify-database ()
  (mapcar 'verify-instruction-fields instruction-field-database))

(defun verify-instruction-fields (arg)
  (let* ((instruction-type (first arg))
	 (field-pairs (rest arg))
	 (fps (sort (copy-list field-pairs) '< :key #'(lambda (fp) (byte-position (cdr fp))))))
    ;;; make sure that there are no overlaps and that the fields are contiguous from bits 0 to 63
    (do* ((fpsl fps (cdr fpsl))
	  (this-name (caar fpsl) (caar fpsl))
	  (this-byte (cdar fpsl) (cdar fpsl))
;	  (next-name (caadr fpsl) (caadr fpsl))
;	  (next-byte (cdadr fpsl) (cdadr fpsl))
	  (current-pos 0)
	  )
	 ((null fpsl)
	  (unless (= current-pos 64.)
	    (format t "~&; ~a  ~d(~:*#o~o)  Where's the rest" instruction-type current-pos)))
      (unless (= current-pos (byte-position this-byte))
	(format t "~&; ~a instruction bit ~d(~:*#o~o):  ~a (#o~o #o~o)"
		instruction-type current-pos
		this-name (byte-size this-byte) (byte-position this-byte)))
      (incf current-pos (byte-size this-byte)))
    (cons instruction-type fps)))

(defun verify-instruction-database ()
  (let ((*print-base* 8)
	(*package* (pkg-find-package 'hardware)))
    (with-open-file (*standard-output* "ed-buffer:instruction-database" :direction :output)
      (grind-top-level (prog1 (verify-database) (terpri) (terpri)) ))))

;;; now make something useful
(defconst instruction-abbreviations
	  '(
	    (common                    "")
	    (ALU                       "-alu")
	    (ALU-16-BIT-IMMEDIATE      "-alu-16i")
	    (ALU-24-BIT-IMMEDIATE      "-alu-24i")
	    (LOAD-32-BIT-IMMEDIATE     "-load-32i")
	    (FLOATING-POINT-ALU        "-float")
	    (FLOATING-POINT-MULTIPLIER "-fmult")
	    (CONDITIONAL-BRANCH        "-branch")
	    (CALLZ                     "-callz")
	    (JUMP                      "-jump")
	    (CALL                      "-call")
	    (CALL-DISPATCH             "-call-dispatch")))

(defconst opcode-field-file-name "jb:k.opcodes;opcode-fields.lisp")

(defun dump-opcode-fields ()
  (with-open-file (filestream opcode-field-file-name :direction :output)
    (format filestream ";;; -*- Mode:LISP; Package:HARDWARE; Base:10; Readtable:CL -*-~%")
    (terpri filestream)
    (format filestream ";;; Generated by ~a on ~\\date\\" user-id (get-universal-time))
    (terpri filestream)
    (dolist (inst instruction-field-database)
      (terpri filestream)
      (let ((inst-type (car inst))
	    (fields (sort (copy-list (cdr inst)) '< :key #'(lambda (fp) (byte-position (cdr fp))))))
	(format filestream ";;; ~a group" inst-type)
	(dolist (f fields)
	  (format filestream "~&~a~&"
		  (format nil "~&~((defconstant %%INST~a-~a ~64,10T(byte ~2d. ~2d.))~)"
			  (second (assq inst-type instruction-abbreviations))
			  (car f)
			  (byte-size (cdr f))
			  (byte-position (cdr f)))))))
    (terpri filestream)))