home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / LISP / CLISP.ZIP / CLisp / lsp / hdwr < prev    next >
Lisp/Scheme  |  1992-10-02  |  9KB  |  312 lines
  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. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  312.