xlisponly/lsp/hdwr.lsp

   1 ; CONVERTED FOR 2.0, but untested.
   2 ; -*-Lisp-*-
   3 ;
   4 ; Jwahar R. Bammi
   5 ; A simple description of hardware objects using xlisp
   6 ; Mix and match instances of the objects to create your
   7 ; organization.
   8 ; Needs:
   9 ; - busses and connection and the Design
  10 ;   Class that will have the connections as instance vars.
  11 ; - Print method for each object, that will display
  12 ;   the instance variables in an human readable form.
  13 ; Some day I will complete it.
  14 ;
  15 ;
  16 ;
  17 ; utility functions
  18
  19
  20 ; function to calculate 2^n
  21
  22 (defun pow2 (n)
  23         (pow2x n 1))
  24
  25
  26 (defun pow2x (n sum)
  27        (cond((equal n 0) sum)
  28             (t (pow2x (- n 1) (* sum 2)))))
  29
  30
  31 ; hardware objects
  32
  33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34 ;The class areg
  35
  36 (setq areg (send Class :new '(value nbits max_val min_val)))
  37
  38 ; methods
  39
  40 ; initialization method
  41 ; when a new instance is called for the user supplies
  42 ; the parameter nbits, from which the max_val & min_val are derived
  43
  44 (send areg :answer :isnew '(n)
  45           '((send self :init n)
  46                 self))
  47
  48 (send areg :answer :init '(n)
  49           '((setq value ())
  50             (setq nbits n)
  51             (setq max_val (- (pow2 (- n 1)) 1))
  52             (setq min_val (- (- 0 max_val) 1))))
  53
  54 ; load areg
  55
  56 (send areg :answer :load '(val)
  57     '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
  58             ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
  59             (t (setq value val)))))
  60
  61 ; see areg
  62
  63 (send areg :answer :see '()
  64       '((cond ((null value) (princ "Register does not contain a value\n"))
  65               (t value))))
  66 ;
  67 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  68
  69 ; The class creg ( a register that can be cleared and incremented)
  70 ; subclass of a reg
  71
  72 (setq creg (send Class :new '() '() areg))
  73
  74 ; it inherites all the instance vars & methods of a reg
  75 ; in addition to them it has the following methods
  76
  77 (send creg :answer :isnew '(n)
  78       '((send self :init n)
  79         self))
  80
  81 (send creg :answer :init '(n)
  82       '((setq value ())
  83         (setq nbits n)
  84         (setq max_val (- (pow2 n) 1))
  85         (setq min_val 0)))
  86
  87 (send creg :answer :clr '()
  88       '((setq value 0)))
  89
  90 (send creg :answer :inc '()
  91       '((cond ((null value) (princ "Register does not contain a value\n"))
  92               (t (setq value (rem (+ value 1) (+ max_val 1)))))))
  93
  94 ;
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;
  97 ; Register bank
  98 ; contains n areg's n_bits each
  99
 100 (setq reg_bank (send Class :new '(regs n_regs curr_reg)))
 101
 102 ;methods
 103
 104 (send reg_bank :answer :isnew '(n n_bits)
 105           '((send self :init n n_bits)
 106             self))
 107
 108 (send reg_bank :answer :init '(n n_bits)
 109           '((setq regs ())
 110             (setq n_regs (- n 1))
 111             (send self :initx n n_bits)))
 112
 113 (send reg_bank :answer :initx '(n n_bits)
 114           '((cond ((equal n 0) t)
 115                   (t (list (setq regs (cons (send areg :new n_bits) regs))
 116                   (send self :initx (setq n (- n 1)) n_bits))))))
 117
 118 (send reg_bank :answer :load '(reg val)
 119           '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
 120                  (t (setq curr_reg (nth (+ reg 1) regs))
 121                     (curr_reg :load val)))))
 122
 123 (send reg_bank :answer :see '(reg)
 124           '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
 125                  (t (setq curr_reg (nth (+ reg 1) regs))
 126                     (curr_reg :see)))))
 127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 128 ; The Class alu
 129
 130 ;alu - an n bit alu
 131
 132 (setq alu (send Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
 133
 134 ; methods
 135
 136 (send alu :answer :isnew '(n)
 137      '((send self :init n)
 138        self))
 139
 140 (send alu :answer :init '(n)
 141      '((setq n_bits n)
 142        (setq maxu_val (- (pow2 n) 1))
 143        (setq maxs_val (- (pow2 (- n 1)) 1))
 144        (setq mins_val (- (- 0 maxs_val) 1))
 145        (setq minu_val 0)
 146        (setq nf 0)
 147        (setq zf 0)
 148        (setq vf 0)
 149        (setq cf 0)))
 150
 151 (send alu :answer :check_arith '(a b)
 152      '((cond ((and (send self :arith_range a) (send self :arith_range b)) t)
 153              (t ()))))
 154
 155 (send alu :answer :check_logic '(a b)
 156      '((cond ((and (send self :logic_range a) (send self :logic_range b)) t)
 157              (t ()))))
 158
 159 (send alu :answer :arith_range '(a)
 160      '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
 161              ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
 162              (t t))))
 163
 164 (send alu :answer :logic_range '(a)
 165      '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
 166              (t t))))
 167
 168 (send alu :answer :set_flags '(a b r)
 169      '((if (equal 0 r) ((setq zf 1)))
 170        (if (< r 0) ((setq nf 1)))
 171        (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
 172                   (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
 173        (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
 174                   (and (>= r 0) (< b 0))) ((setq cf 1)))))
 175
 176 (send alu :answer :add '(a b &aux result)
 177      '((cond ((null (send self :check_arith a b)) ())
 178             (t (send self :clear_flags)
 179                (setq result (+ a b))
 180                (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
 181                    (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
 182                (send self :set_flags a b result)
 183                result))))
 184
 185 (send alu :answer :or '(a b &aux result)
 186      '((cond ((null (send self :check_logic a b)) ())
 187             (t (send self :clear_flags)
 188                (setq result (bit-ior a b))
 189                (send self :set_flags a b result)
 190                result))))
 191
 192 (send alu :answer :and '(a b &aux result)
 193      '((cond ((null (send self :check_logic a b)) ())
 194             (t (send self :clear_flags)
 195                (setq result (bit-and a b))
 196                (send self :set_flags a b result)
 197                result))))
 198
 199 (send alu :answer :not '(a  &aux result)
 200      '((cond ((null (send self :check_logic a 0)) ())
 201             (t (send self :clear_flags)
 202                (setq result (bit-not a))
 203                (send self :set_flags a 0 result)
 204                result))))
 205
 206 (send alu :answer :subtract '(a b)
 207      '((send self '+ a (- 0 b))))
 208
 209 (send alu :answer :passa '(a)
 210      '(a))
 211
 212 (send alu :answer :zero '()
 213      '(0))
 214
 215 (send alu :answer :com '(a)
 216      '((send self :- 0 a)))
 217
 218 (send alu :answer :status '()
 219      '((princ (list "NF "nf"\n"))
 220        (princ (list "ZF "zf"\n"))
 221        (princ (list "CF "cf"\n"))
 222        (princ (list "VF "vf"\n"))))
 223
 224 (send alu :answer :clear_flags '()
 225      '((setq nf 0)
 226        (setq zf 0)
 227        (setq cf 0)
 228        (setq vf 0)))
 229
 230 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 231 ;
 232 ; The class Memory
 233 ;
 234
 235 (setq memory (send Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
 236
 237 ; methods
 238
 239 (send memory :answer :isnew '(addr_bits data_bits)
 240      '((send self :init addr_bits data_bits)
 241        self))
 242
 243 (send memory :answer :init '(addr_bits data_bits)
 244      '((setq nabits addr_bits)
 245        (setq ndbits data_bits)
 246        (setq maxu_val (- (pow2 data_bits) 1))
 247        (setq max_addr (- (pow2 addr_bits) 1))
 248        (setq maxs_val (- (pow2 (- data_bits 1)) 1))
 249        (setq mins_val (- 0 (pow2 (- data_bits 1))))
 250        (setq undef (+ maxu_val 1))
 251        (setq memry (array :new max_addr undef))))
 252
 253
 254 (send memory :answer :load '(loc val)
 255      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
 256              ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
 257              ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
 258              (t (memry :load loc val)))))
 259
 260 (send memory :answer :write '(loc val)
 261      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
 262              ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
 263              ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
 264              (t (memry :load loc val)))))
 265
 266
 267 (send memory :answer :read '(loc &aux val)
 268      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
 269              (t (setq val (memry :see loc))
 270                 (cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
 271                       (t val))))))
 272
 273
 274 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 275 ;
 276 ; The class array
 277
 278 (setq array (send Class :new '(arry)))
 279
 280 ; methods
 281
 282 (send array :answer :isnew '(n val)
 283        '((send self :init n val)
 284          self))
 285
 286 (send array :answer :init '(n val)
 287         '((cond ((< n 0) t)
 288               (t (setq arry (cons val arry))
 289                  (send self :init (- n 1) val)))))
 290
 291 (send array :answer :see '(n)
 292                '((nth (+ n 1) arry)))
 293
 294
 295 (send array :answer :load '(n val &aux left right temp)
 296        '((setq left (send self :left_part n arry temp))
 297          (setq right (send self :right_part n arry))
 298          (setq arry (append left (list val)))
 299          (setq arry (append arry right))
 300          val))
 301
 302 (send array :answer :left_part '(n ary left)
 303        '((cond ((equal n 0) (reverse left))
 304                (t (setq left (cons (car ary) left))
 305                   (send self :left_part (- n 1) (cdr ary) left)))))
 306
 307 (send array :answer :right_part '(n ary &aux right)
 308        '((cond ((equal n 0) (cdr ary))
 309                (t (send self :right_part (- n 1) (cdr ary))))))
 310
 311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;