The HP-67 emulator, cleaning up some indirection code

At this point, the indirection code was getting unreasonable.  The case-insensitive label we use for indirection, “(i)”,  was starting to show up in too many places.  There’s no reason that the logic for indirection as applied to memory and flags can’t sit entirely in the memory and flag code.  So, this was pushed back into that module.  For simplicity, the I-register was moved from a special value in the structure to just another memory register, one indexed by the label “(i)”.  A new condition was defined for indirection operations that are attempted with the I-register out of its valid domain.  The HP-67 calculator required that the value in the I-register be from 0 to 25, inclusive, for store operations, and 0 to 3, inclusive, for flag operations.  Operations with invalid I-register will now signal a condition that will cause the calculator to enter an error state.

The memory code now looks like this:
stack.lisp

(defun canonicalize-memory-name (stack mem-name)
  (when (integerp mem-name)
    (setf mem-name (format nil "~D" mem-name)))
  (assert (stringp mem-name))
  (cond
    ((string-equal mem-name "(i)")
     (multiple-value-bind (junk int-val str-val)
         (get-i-register stack)
       (declare (ignore junk))
       (cond
         ((and (not *unlimited-indirection*)
               (or (< int-val 0) (> int-val 25)))
          (error (make-condition 'i-register-range-error
                                 :value int-val
                                 :min-allowed 0
                                 :max-allowed 25)))
         ((= int-val 25)
          "(i)")
         ((> int-val 19)
          (subseq "ABCDE"
                  (- int-val 20)
                  (- int-val 19)))
         (t
          str-val))))
    (t
     mem-name)))


(defun store-memory-by-name (stack name val)
  "Does no indirection, just stores under the name."
  (setf (stack-memory stack)
        (delete-duplicates
         (push (cons name val)
               (stack-memory stack))
         :key 'car
         :test 'string=
         :from-end t))
  val)

(defun recall-memory-by-name (stack name)
  "Does no indirection, just recalls from the name."
  (let ((record (assoc name
                       (stack-memory stack)
                       :test 'string=)))
    (if record
        (cdr record)
        0)))


(defun store-memory (stack name val)
  (setf name (canonicalize-memory-name stack name))
  (store-memory-by-name stack name val))


(defun recall-memory (stack name)
  (setf name (canonicalize-memory-name stack name))
  (recall-memory-by-name stack name))

stack.lisp
(defun set-i-register (stack value)
  (store-memory-by-name stack "(i)" value))

;; Returns 3 values.  The unmodified value of I, the greatest-integer
;; value, and a string holding the greatest-integer value
(defun get-i-register (stack)
  (let ((rval (recall-memory-by-name stack "(i)")))
    (values
     rval
     (floor rval)
     (format nil "~D" (floor rval)))))

The flag code looks like this:
stack.lisp

(defun canonicalize-flag-name (stack flag-name)
  (when (integerp flag-name)
    (setf flag-name (format nil "~D" flag-name)))
  (assert (stringp flag-name))
  (cond
    ((string-equal flag-name "(i)")
     (multiple-value-bind (junk int-val str-val)
         (get-i-register stack)
       (declare (ignore junk))
       (cond
         ((and (not *unlimited-indirection*)
               (or (< int-val 0) (> int-val 3)))
          (error (make-condition 'i-register-range-error
                                 :value int-val
                                 :min-allowed 0
                                 :max-allowed 3)))
         (t
          str-val))))
    (t
     flag-name)))
  

(defun set-flag-by-name (stack name &key clear)
  (let ((record (assoc name (stack-flags stack)
                       :test 'string=)))
    (cond
      (record
       (setf (cdr record) (not clear)))
      (t
       (setf (stack-flags stack)
             (push (cons name (not clear))
                   (stack-flags stack)))))))

(defun get-flag-by-name (stack name)
  (let* ((record (assoc name (stack-flags stack)
                       :test 'string=))
         (rval (cdr record)))
    (when (or (string= name "2")
              (string= name "3"))
      (set-flag-by-name stack name :clear t))
    rval))


(defun set-flag-fcn (stack name &key clear)
  (setf name (canonicalize-flag-name stack name))
  (set-flag-by-name stack name :clear clear))

(defun clear-flag-fcn (stack name)
  (set-flag-fcn stack name :clear t))

(defun get-flag-fcn (stack name)
  (setf name (canonicalize-flag-name stack name))
  (get-flag-by-name stack name))

Both are found in “stack.lisp”.

Several more key operations were coded in “calc1.lisp”.  The statistical operations, some flow-control operations, and a key that affects the way data is presented on the screen of the calculator.

The current code is in the git repository, under the tag v2014-11-02.

Leave a Reply

Your email address will not be published. Required fields are marked *

You may use these HTML tags and attributes: <a href="" title=""> <abbr title=""> <acronym title=""> <b> <blockquote cite=""> <cite> <code> <del datetime=""> <em> <i> <q cite=""> <s> <strike> <strong>

*

反垃圾邮件 / Anti-spam question * Time limit is exhausted. Please reload CAPTCHA.