;;; -*- Mode:LISP; Package:MAC; Base:10; Readtable:ZL -*-
;;;
;;;  Bus coupler memory interface.
;;;


;
; Data-type for the expression in data-structure
;
(defconst ISA-NIL      0)
(defconst ISA-T        1)
(defconst ISA-KEYWORD  2)
(defconst ISA-STRING   3)
(defconst ISA-INTEGER  4)
(defconst ISA-TEXT     5)


(defun test-bc-address (adr)
  (if (or (< adr #xFB000000)
	  (> adr #xFB01FFFF))
      (ferror "oups... j'ai faillit geler")))

(defun test-bc-address-and-value (adr value)
  (test-bc-address adr)
  (if (or (not (fixp value))
	  (< value 0))
      (ferror "oup... j'ai faillit geler")))


(defun read-BC-byte (adr)
  (test-bc-address adr)
  (let* ((no-slot (ldb (byte 8 24.)adr))
	 (no-byte (ldb (byte 2 0) adr))
	 (address (logand #xfffffc (ldb (byte 24. 0) adr)))
	 (long-word (%nubus-read no-slot address)))
    (case no-byte
      (0 (ldb (byte 8 0) long-word))
      (1 (ldb (byte 8 8.) long-word))
      (2 (ldb (byte 8 16.) long-word))
      (3 (ldb (byte 8 24.) long-word)))))



(defun write-BC-byte (adr byte)
  (test-bc-address-and-value adr byte)
  (let* ((no-slot (ldb (byte 8 24.)adr))
	 (no-byte (ldb (byte 2 0) adr))
	 (address (logand #xfffffc (ldb (byte 24. 0) adr)))
	 (long-word (%nubus-read no-slot address)))
    (%nubus-write no-slot
		  address
		  (dpb byte (case no-byte
			      (0 (byte 8 0))
			      (1 (byte 8 8.))
			      (2 (byte 8 16.))
			      (3 (byte 8 24.))) long-word))))


(defun read-BC-word (adr)
  (test-bc-address adr)
  (let* ((no-slot (ldb (byte 8 24.)adr))
	 (no-byte (ldb (byte 2 0) adr))
	 (address (logand #xfffffc (ldb (byte 24. 0) adr)))
	 (long-word (%nubus-read no-slot address)))
    (case no-byte
      (0 (logior (ash (ldb (byte 8 0) long-word) 8)  (ldb (byte 8 8.) long-word)))
      (2 (logior (ash (ldb (byte 8 16.) long-word) 8)(ldb (byte 8 24.) long-word))))))



(defun write-BC-word (adr word)
  (test-bc-address-and-value adr word)
  (let* ((no-slot (ldb (byte 8 24.)adr))
	 (no-byte (ldb (byte 2 0) adr))
	 (address (logand #xfffffc (ldb (byte 24. 0) adr)))
	 (long-word (%nubus-read no-slot address)))
    (%nubus-write no-slot
		  address
		  (dpb (logior (ash (ldb (byte 8 0) word) 8) (ldb (byte 8 8) word))
		       (case no-byte
			 (0 (byte 16. 0))
			 (2 (byte 16. 16.))) long-word))))


(defun read-BC-long (adr)
  (test-bc-address adr)
  (if (= 0 (ldb (byte 2 0) adr))
      (lam:swap32 (%nubus-read (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr)))
    (logior (ash (read-BC-word adr)16.) (read-BC-word (+ 2 adr)))))



(defun write-BC-long (adr val)
  (test-bc-address-and-value adr val)
  (if (= 0 (ldb (byte 2 0) adr))
      (%nubus-write (ldb (byte 8 24.) adr) (ldb (byte 24. 0) adr) (lam:swap32 val))
    (write-BC-word (+ 2 adr) (ldb (byte 16. 0) val))
    (write-BC-word adr (ldb (byte 16 16.) val))))


;;;
;;; mac strings...
;;;
(defun read-BC-mac-string (adr)
  (let* ((length (read-BC-byte adr))
	 (string (make-string length)))
    (loop for x from 1 to length
	  do (aset (read-BC-byte (+ x adr)) string (1- x)))
    string))

(defun write-BC-mac-string (adr string length)
  (when (> length 0)
    (write-BC-byte adr length)
    (incf adr)
    (loop for x from 0 to (1- length)
	  do (write-BC-byte (+ x adr) (aref string x)))))


;;;
;;; standard strings...
;;;
(defun read-BC-string2 (adr length)
  (when (> length 0)
    (let ((string (make-string length)))
      (loop for x from 0 to (1- length)
	    do (aset (read-BC-byte (+ x adr)) string x))
      string)))


(defun write-BC-string2 (adr string length)
  (when (> length 0)
    (loop for x from 0 to (1- length)
	  do (write-BC-byte (+ x adr) (aref string x)))))

;;;
;;; standard strings...
;;;
(defun read-BC-in-string (adr string length)
  (when (> length 0)
    (loop for x from 0 to (1- length)
	  do (aset (read-BC-byte (+ x adr)) string x))))


(defun write-BC-from-string (string adr length)
  (when (> length 0)
    (loop for x from 0 to (1- length)
	  do (write-BC-byte (+ x adr) (aref string x)))))



(defun keyword->num (keyword)
  (selectq keyword
    (:DEFAULT           0)			;keywords for options
    (:WILD              1)
    (:UNSPECIFIC        2)
    (:NEWEST            3)
    (:OLDEST            4)
    (:NEW-VERSION       5)
    (:INPUT             6)
    (:OUTPUT            7)
    (:PROBE             8)
    (:PROBE-DIRECTORY   9)
    (:ERROR             10)
    (:SUPERSEDE         11)
    (:OVERWRITE         12)
    (:TRUNCATE          13)
    (:APPEND            14)
    (:RENAME            15)
    (:RENAME-AND-DELETE 16)
    (:CREATE            17)
    (:ABORT             18)
    (:ROOT              19)
    (:LOOKUP            20)
    (t (ferror "MAC: keyword inconnu"))))


(defun num->keyword (num)
  (selectq num
    (0           :DEFAULT)
    (1              :WILD)
    (2        :UNSPECIFIC)
    (3            :NEWEST)
    (4            :OLDEST)
    (5       :new-VERSION)
    (6              :OPEN)
    (6             :INPUT)
    (7            :OUTPUT)
    (8             :PROBE)
    (9    :PROBE-DIRECTORY)
    (10             :ERROR)
    (11         :SUPERSEDE)
    (12         :OVERWRITE)
    (13          :TRUNCATE)
    (14            :APPEND)
    (15            :RENAME)
    (16 :RENAME-AND-DELETE)
    (17            :CREATE)
    (18             :ABORT)
    (19              :ROOT)
    (20            :lookup)
    (t (ferror "MAC: keyword inconnu"))))


;
;   Other types of expression
;
(defun expr->num (expr)
  (cond ((eq t expr)	 (dpb ISA-T (byte 8 24.) 0))
	((null expr)     (dpb ISA-NIL (byte 8 24.) 0))
	((integerp expr) (dpb ISA-INTEGER (byte 8 24.) expr))
	((keywordp expr) (dpb ISA-KEYWORD (byte 8 24.)(keyword->num expr)))
	(t (ferror "Bad expression to translate"))))


(defun num->expr (num &optional (struct 0))
  (select (ldb (byte 8 24.) num)
    (ISA-T t)
    (ISA-NIL nil)
    (ISA-INTEGER (ldb (byte 16 0) num))
    (ISA-KEYWORD (num->keyword (ldb (byte 16 0) num)))
    (ISA-STRING (read-BC-mac-string (+ struct (ldb (byte 24. 0.) num))))
    (t (ferror "Bad expression to translate"))))