; CONVERTED FOR 2.0, but untested.
; -*-Lisp-*-
;
; Jwahar R. Bammi
; A simple description of hardware objects using xlisp
; Mix and match instances of the objects to create your
; organization.
; Needs:
; - busses and connection and the Design
; Class that will have the connections as instance vars.
; - Print method for each object, that will display
; the instance variables in an human readable form.
; Some day I will complete it.
;
;
;
; utility functions
; function to calculate 2^n
(defun pow2 (n)
(pow2x n 1))
(defun pow2x (n sum)
(cond((equal n 0) sum)
(t (pow2x (- n 1) (* sum 2)))))
; hardware objects
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;The class areg
(setq areg (send Class :new '(value nbits max_val min_val)))
; methods
; initialization method
; when a new instance is called for the user supplies
; the parameter nbits, from which the max_val & min_val are derived
(send areg :answer :isnew '(n)
'((send self :init n)
self))
(send areg :answer :init '(n)
'((setq value ())
(setq nbits n)
(setq max_val (- (pow2 (- n 1)) 1))
(setq min_val (- (- 0 max_val) 1))))
; load areg
(send areg :answer :load '(val)
'((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
(t (setq value val)))))
; see areg
(send areg :answer :see '()
'((cond ((null value) (princ "Register does not contain a value\n"))
(t value))))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The class creg ( a register that can be cleared and incremented)
; subclass of a reg
(setq creg (send Class :new '() '() areg))
; it inherites all the instance vars & methods of a reg
; in addition to them it has the following methods
(send creg :answer :isnew '(n)
'((send self :init n)
self))
(send creg :answer :init '(n)
'((setq value ())
(setq nbits n)
(setq max_val (- (pow2 n) 1))
(setq min_val 0)))
(send creg :answer :clr '()
'((setq value 0)))
(send creg :answer :inc '()
'((cond ((null value) (princ "Register does not contain a value\n"))
(t (setq value (rem (+ value 1) (+ max_val 1)))))))
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Register bank
; contains n areg's n_bits each
(setq reg_bank (send Class :new '(regs n_regs curr_reg)))
;methods
(send reg_bank :answer :isnew '(n n_bits)
'((send self :init n n_bits)
self))
(send reg_bank :answer :init '(n n_bits)
'((setq regs ())
(setq n_regs (- n 1))
(send self :initx n n_bits)))
(send reg_bank :answer :initx '(n n_bits)
'((cond ((equal n 0) t)
(t (list (setq regs (cons (send areg :new n_bits) regs))
(send self :initx (setq n (- n 1)) n_bits))))))
(send reg_bank :answer :load '(reg val)
'((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
(t (setq curr_reg (nth (+ reg 1) regs))
(curr_reg :load val)))))
(send reg_bank :answer :see '(reg)
'((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
(t (setq curr_reg (nth (+ reg 1) regs))
(curr_reg :see)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; The Class alu
;alu - an n bit alu
(setq alu (send Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
; methods
(send alu :answer :isnew '(n)
'((send self :init n)
self))
(send alu :answer :init '(n)
'((setq n_bits n)
(setq maxu_val (- (pow2 n) 1))
(setq maxs_val (- (pow2 (- n 1)) 1))
(setq mins_val (- (- 0 maxs_val) 1))
(setq minu_val 0)
(setq nf 0)
(setq zf 0)
(setq vf 0)
(setq cf 0)))
(send alu :answer :check_arith '(a b)
'((cond ((and (send self :arith_range a) (send self :arith_range b)) t)
(t ()))))
(send alu :answer :check_logic '(a b)
'((cond ((and (send self :logic_range a) (send self :logic_range b)) t)
(t ()))))
(send alu :answer :arith_range '(a)
'((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
((> a maxs_val) (princ (list "Operand out of range "a"\n")))
(t t))))
(send alu :answer :logic_range '(a)
'((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
(t t))))
(send alu :answer :set_flags '(a b r)
'((if (equal 0 r) ((setq zf 1)))
(if (< r 0) ((setq nf 1)))
(if (or (and (and (< a 0) (< 0 b)) (>= r 0))
(and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
(if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
(and (>= r 0) (< b 0))) ((setq cf 1)))))
(send alu :answer :add '(a b &aux result)
'((cond ((null (send self :check_arith a b)) ())
(t (send self :clear_flags)
(setq result (+ a b))
(if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
(if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
(send self :set_flags a b result)
result))))
(send alu :answer :or '(a b &aux result)
'((cond ((null (send self :check_logic a b)) ())
(t (send self :clear_flags)
(setq result (bit-ior a b))
(send self :set_flags a b result)
result))))
(send alu :answer :and '(a b &aux result)
'((cond ((null (send self :check_logic a b)) ())
(t (send self :clear_flags)
(setq result (bit-and a b))
(send self :set_flags a b result)
result))))
(send alu :answer :not '(a &aux result)
'((cond ((null (send self :check_logic a 0)) ())
(t (send self :clear_flags)
(setq result (bit-not a))
(send self :set_flags a 0 result)
result))))
(send alu :answer :subtract '(a b)
'((send self '+ a (- 0 b))))
(send alu :answer :passa '(a)
'(a))
(send alu :answer :zero '()
'(0))
(send alu :answer :com '(a)
'((send self :- 0 a)))
(send alu :answer :status '()
'((princ (list "NF "nf"\n"))
(princ (list "ZF "zf"\n"))
(princ (list "CF "cf"\n"))
(princ (list "VF "vf"\n"))))
(send alu :answer :clear_flags '()
'((setq nf 0)
(setq zf 0)
(setq cf 0)
(setq vf 0)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The class Memory
;
(setq memory (send Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
; methods
(send memory :answer :isnew '(addr_bits data_bits)
'((send self :init addr_bits data_bits)
self))
(send memory :answer :init '(addr_bits data_bits)
'((setq nabits addr_bits)
(setq ndbits data_bits)
(setq maxu_val (- (pow2 data_bits) 1))
(setq max_addr (- (pow2 addr_bits) 1))
(setq maxs_val (- (pow2 (- data_bits 1)) 1))
(setq mins_val (- 0 (pow2 (- data_bits 1))))
(setq undef (+ maxu_val 1))
(setq memry (array :new max_addr undef))))
(send memory :answer :load '(loc val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
(t (memry :load loc val)))))
(send memory :answer :write '(loc val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
(t (memry :load loc val)))))
(send memory :answer :read '(loc &aux val)
'((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
(t (setq val (memry :see loc))
(cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
(t val))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; The class array
(setq array (send Class :new '(arry)))
; methods
(send array :answer :isnew '(n val)
'((send self :init n val)
self))
(send array :answer :init '(n val)
'((cond ((< n 0) t)
(t (setq arry (cons val arry))
(send self :init (- n 1) val)))))
(send array :answer :see '(n)
'((nth (+ n 1) arry)))
(send array :answer :load '(n val &aux left right temp)
'((setq left (send self :left_part n arry temp))
(setq right (send self :right_part n arry))
(setq arry (append left (list val)))
(setq arry (append arry right))
val))
(send array :answer :left_part '(n ary left)
'((cond ((equal n 0) (reverse left))
(t (setq left (cons (car ary) left))
(send self :left_part (- n 1) (cdr ary) left)))))
(send array :answer :right_part '(n ary &aux right)
'((cond ((equal n 0) (cdr ary))
(t (send self :right_part (- n 1) (cdr ary))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
syntax highlighted by Code2HTML, v. 0.9.1