COMET II.rkt

#lang racket

(require srfi/1 srfi/60)

;;;;;; 1 システム COMET IIの仕様

;;;;; 1.1 ハードウェアの仕様

;;;; 1. 1語は16ビットで,そのビット構成は,次のとおりである。 

;;;; 2. 主記憶の容量は65536語で，そのアドレスは0～65535番地である。

(define (make-main-memory)
  (make-vector 65536))

(define (dump memory s n)
  (map (lambda (k)
         (let ((obj (vector-ref memory k)))
           (string-append
            (number->string obj)
            "\n")))
       (iota n s)))

(define memory-ref vector-ref)

(define (memory-set memory k obj)
  (let ((v (vector-copy memory))
        (obj (logand obj #xFFFF)))
    (vector-set! v k obj)
    v))

;;;; 3. 数値は，16ビットの2進数で表現する。負数は，2の補数で表現する。

(define (toArithmetic n)
  (if (logbit? 15 n)
      (- n #x10000)
      n))

;;;; 4. 制御方式は逐次制御で，命令語は1語長又は2語長である。

(define (inc registers . arg)
  ((registers 'PR-set) (+ (registers 'PR-ref) (if (null? arg)
                                                  1
                                                  (car arg)))))

;;;; 5. レジスタとして，GR（16ビット），SP（16ビット），PR（16ビット），
;;;; FR（3ビット）の4種類がある。

(define (make-registers . arg)
  (let ((v (if (null? arg)
               (vector
                ;;;  GR（汎用レジスタ，General Register）は，GR0～GR7の8個があり，
                ;;; 算術，論理，比較，シフトなどの演算に用いる。 このうち，
                ;;; GR1～GR7のレジスタは，指標レジスタ（index register） として
                ;;; アドレスの修飾にも用いる。
                (make-vector 8)
                ;;;  SP（スタックポインタ，Stack Pointer）は， スタックの最上段の
                ;;; アドレスを保持している。
                '()
                ;;;  PR（プログラムレジスタ，Program Register）は， 次に実行すべき
                ;;; 命令語の先頭アドレスを保持している。
                0
                ;;;  FR（フラグレジスタ，Flag Register）は， OF（Overflow Flag）
                ;;; ，SF（Sign Flag），ZF（Zero Flag）と呼ぶ 3個のビットからなり，
                ;;; 演算命令などの実行によって次の値が設定される。 これらの値は，
                ;;; 条件付き分岐命令で参照される。
                (make-vector 3))
               (car arg))))
    (lambda (message)
      (case message
        ((show-registers) `("PR=" ,(vector-ref v 2) "\n"
                                  "SP=" ,(vector-ref v 1) "\n"
                                  "FR(OF,SF,ZF)=" ,(vector-ref v 3) "\n"
                                  ,@(map 
                                     (lambda (k) 
                                       (string-append
                                        "GR" 
                                        (number->string k) 
                                        "=" 
                                        (number->string
                                         (vector-ref 
                                          (vector-ref v 0) k))
                                        "\n"))
                                     (iota 8))))
        ((GR-ref) (lambda (k)
                    (vector-ref (vector-ref v 0) k)))
        ((GR-set) (lambda (k obj)
                    (let ((u (vector-copy v))
                          (w (vector-copy (vector-ref v 0)))
                          (obj (logand obj #xFFFF)))
                      (vector-set! w k obj)
                      (vector-set! u 0 w)
                      (make-registers u))))
        ((push) (lambda (val)
                  (let ((u (vector-copy v))
                        (stack (vector-ref v 1)))
                    (vector-set! u 1 (cons val stack))
                    (make-registers u))))
        ((pop) (let ((u (vector-copy v))
                     (stack (vector-ref v 1)))
                 (vector-set! u 1 (cdr stack))
                 (values (car stack) (make-registers u))))
        ((PR-ref) (vector-ref v 2))
        ((PR-set) (lambda (obj)
                    (let ((u (vector-copy v)))
                      (vector-set! u 2 obj)
                      (make-registers u))))
        ;; OF
        ; 算術演算命令の場合は，演算結果が-32768～32767に収まらなくなったとき1になり， 
        ; それ以外のとき0になる。 論理演算命令の場合は，演算結果が0～65535に収まらなく
        ; なったとき1になり， それ以外のとき0になる。
        ((OF-ref) (vector-ref (vector-ref v 3) 0))
        ((OF-set) (lambda (val tag)
                    (let ((u (vector-copy v))
                          (w (vector-copy (vector-ref v 3))))
                      (vector-set! w 0 (case tag
                                         ((Arithmetic)
                                          (if (<= -32768 val 32767)
                                              0
                                              1))
                                         ((Logical)
                                          (if (<= 0 val 65535)
                                              0
                                              1))
                                         ((Shift)
                                          (if val 1 0))
                                         (else 0)))
                      (vector-set! u 3 w)
                      (make-registers u))))
        ;; SF
        ; 演算結果の符号が負（ビット番号15が1）のとき1，それ以外のとき0になる。
        ((SF-ref) (vector-ref (vector-ref v 3) 1))
        ((SF-set) (lambda (val)
                    (let ((u (vector-copy v))
                          (w (vector-copy (vector-ref v 3))))
                      (vector-set! w 1 (if (boolean? val)
                                           (if val 1 0)
                                           (if (logbit? 15 val)
                                               1
                                               0)))
                      (vector-set! u 3 w)
                      (make-registers u))))
        ;; ZF
        ; 演算結果が零（全部のビットが0）のとき1，それ以外のとき0になる。
        ((ZF-ref) (vector-ref (vector-ref v 3) 2))
        ((ZF-set) (lambda (val)
                    (let ((u (vector-copy v))
                          (w (vector-copy (vector-ref v 3))))
                      (vector-set! w 2 (if (zero? val)
                                           1
                                           0))
                      (vector-set! u 3 w)
                      (make-registers u))))
        (else (error "Unknown request -- REGISTER: " message))
        ))))

;;;; 6. 論理加算又は論理減算は，被演算データを符号のない数値とみなして， 加算又は
;;;; 減算する。

;;;;; 1.2 命令

;;; 命令の形式及びその機能を示す。 ここで，一つの命令コードに対し2種類のオペランドが
;;; ある場合， 上段はレジスタ間の命令，下段はレジスタと主記憶間の命令を表す。


;;;; 1.2.1 ロード，ストア，ロードアドレス命令

;;; ロード
;;; LoaD

(define (LD r obj registers)
  (((O*1 obj registers) 'GR-set) r obj))

;;; ストア
;;; STore

(define (ST r k registers memory)
  (values registers (memory-set memory k ((registers 'GR-ref) r)))) 

;;; ロードアドレス
;;; Load ADdress

(define (LAD r obj registers)
  ((registers 'GR-set) r obj))

;;;; 1.2.2 算術，論理演算命令

;;; 算術加算
;;; ADD Arithmetic

(define (ADDA r z registers)
  (let ((n (apply + (map toArithmetic `(,((registers 'GR-ref) r) ,z)))))
    (((O n registers 'Arithmetic) 'GR-set) r n)))

;;; 論理加算
;;; ADD Logical

(define (ADDL r z registers)
  (let ((n (+ ((registers 'GR-ref) r) z)))
    (((O n registers 'Logical) 'GR-set) r n)))

;;; 算術減算
;;; SUBtract Arithmetic

(define (SUBA r z registers)
  (let ((n (apply - (map toArithmetic `(,((registers 'GR-ref) r) ,z)))))
    (((O n registers 'Arithmetic) 'GR-set) r n)))

;;; 論理減算
;;; SUBtract Logical

(define (SUBL r z registers)
  (let ((n (- ((registers 'GR-ref) r) z)))
    (((O n registers 'Logical) 'GR-set) r n)))

;;; 論理積
;;; AND

(define (AND r n registers)
  (let ((obj (logand ((registers 'GR-ref) r) n)))
    (((O*1 obj registers) 'GR-set) r obj)))

;;; 論理和
;;; OR

(define (OR r n registers)
  (let ((obj (logior ((registers 'GR-ref) r) n)))
    (((O*1 obj registers) 'GR-set) r obj)))

;;; 排他的論理和
;;; eXclusive OR

(define (XOR r n registers)
  (let ((obj (logxor ((registers 'GR-ref) r) n)))
    (((O*1 obj registers) 'GR-set) r obj)))

;;;; 1.2.3 比較演算命令

;;; 算術比較
;;; ComPare Arithmetic

(define (CPA r x registers)
  (let ((cmp (apply - (map toArithmetic `(,((registers 'GR-ref) r) ,x)))))
    (O*1 cmp registers negative?)))

;;; 論理比較
;;; ComPare Logical

(define (CPL r x registers)
  (let ((cmp (- ((registers 'GR-ref) r) x)))
    (O*1 cmp registers negative?)))

;;;; 1.2.4 シフト演算命令

;;; 算術左シフト
;;; Shift Left Arithmetic

(define (SLA r count registers)
  (let ((val ((registers 'GR-ref) r)))
    (let ((sign (logand val #x8000))
          (body (bit-field (ash val count) 0 15))
          (flag (logbit? (- 15 count) val)))
      (let ((obj (toArithmetic (logior sign body))))
        (((O*2 obj registers flag) 'GR-set) r obj)))))

;;; 算術右シフト
;;; Shift Right Arithmetic

(define (SRA r count registers)
  (let ((val (toArithmetic ((registers 'GR-ref) r))))
    (let ((obj (ash val (- count)))
          (flag (logbit? (- count 1) val)))
      (((O*2 obj registers flag) 'GR-set) r obj))))

;;; 論理左シフト
;;; Shift Left Logical

(define (SLL r count registers)
  (let ((val ((registers 'GR-ref) r)))
    (let ((obj (logand (ash val count) #xffff))
          (flag (logbit? (- 16 count) val)))
      (((O*2 obj registers flag) 'GR-set) r obj))))

;;; 論理右シフト
;;; Shift Right Logical

(define (SRL r count registers)
  (let ((val ((registers 'GR-ref) r)))
    (let ((obj (ash val (- count)))
          (flag (logbit? (- count 1) val)))
      (((O*2 obj registers flag) 'GR-set) r obj))))

;;;; 1.2.5 分岐命令

;;; 正分岐
;;; Jump on Plus

(define (JPL target registers)
  (if (and (zero? (registers 'SF-ref)) (zero? (registers 'ZF-ref)))
      ((registers 'PR-set) target)
      registers))

;;; 負分岐
;;; Jump on MINUS

(define (JMI target registers)
  (if (= (registers 'SF-ref) 1)
      ((registers 'PR-set) target)
      registers))

;;; 非零分岐
;;; Jump on Non Zero

(define (JNZ target registers)
  (if (zero? (registers 'ZF-ref))
      ((registers 'PR-set) target)
      registers))

;;; 零分岐
;;; Jump on Zero

(define (JZE target registers)
  (if (= (registers 'ZF-ref) 1)
      ((registers 'PR-set) target)
      registers))

;;; オーバーフロー分岐
;;; Jump on OVerflow

(define (JOV target registers)
  (if (= (registers 'OF-ref) 1)
      ((registers 'PR-set) target)
      registers))

;;; 無条件分岐
;;; unconditional Jump

(define (JUMP target registers)
  ((registers 'PR-set) target))

;;;; 1.2.6 スタック操作命令

;;; プッシュ
;;; PUSH

(define (PUSH target registers)
  ((registers 'push) target))

;;; ポップ
;;; POP

(define (POP r registers)
  (let-values (((val registers) (registers 'POP)))
    ((registers 'GR-set) r val)))

;;;; 1.2.7 コール，リターン命令

;;; コール
;;; CALL subroutine

(define (CALL target registers)
  ((((registers 'push) (registers 'PR-ref)) 'PR-set) target))

;;; リターン
;;; RETurn from subroutine

(define (RET registers)
  (let-values (((val registers) (registers 'pop)))
    ((registers 'PR-set) val)))

;;;; 1.2.8 その他

;;; スーパーバイザコール
;;; SuperVisor CALL

(define (SVC target registers memory)
  (case target
    ((0) (for-each display (registers 'show-registers))
         (values registers memory))
    ((1) (let ((ch (lambda () (cdr (assv (read-char) *char-code*)))))
           (let loop ((k ((registers 'GR-ref) 1))
                      (count ((registers 'GR-ref) 2))
                      (memory memory))
             (if (zero? count)
                 (values registers memory)
                 (loop (+ k 1) (- count 1) (memory-set memory k (ch)))))))
    ((2) (for-each (lambda (k)
                     (write-char
                      (cdr (assv (memory-ref memory k) *JIS-X-0201*))))
                   (iota ((registers 'GR-ref) 2) ((registers 'GR-ref) 1)))
         (values registers memory))
    ((3) (for-each display (dump memory ((registers 'GR-ref) 0) 32))
         (values registers memory))
    (else (error "Unknown request -- REGISTER: " target))))

;;; ノーオペレーション
;;; No operation

(define (NOP registers)
  registers)

;;;; 注

;;; r, r1, r2
;; いずれも GRを示す。指定できるGRはGR0～GR7

;;; adr
;; アドレスを示す。指定できる値の範囲は0～65535

(define (address memory k)
  (memory-ref memory (+ k 1)))

;;; x
;; 指標レジスタとして用いるGRを示す。指定できるGRはGR1～GR7

(define (r2 registers k)
  (if (zero? k)
      k
      ((registers 'GR-ref) k)))

;;; [ ]
;; [ ]内の指定は省略できることを示す。

;;; ( )
;; ( )内のレジスタ又はアドレスに格納されている内容を示す。

;;; 実効アドレス
;; adrとxの内容との論理加算値又はその値が示す番地

(define (addressing adr x registers memory)
  (memory-ref memory (+ (r2 registers x) (address memory adr))))

;;; ←
;; 演算結果を，左辺のレジスタ又はアドレスに格納することを示す。

;;; +L, -L
;; 論理加算，論理減算を示す。

;;; FRの設定
;; ○ : 設定されることを示す。

(define (O val registers tag)
  ((((((registers 'OF-set) val tag) 'SF-set) val) 'ZF-set) val))

;; ○*1: 設定されることを示す。ただし、OFには0が設定される。

(define (O*1 val registers . pred)
  ((((((registers 'OF-set) val 'Zero) 'SF-set) 
     (if (null? pred)
         val
         ((car pred) val)))
    'ZF-set) val))

;; ○*2: 設定されることを示す。ただし、OFにはレジスタから最後に送り出されたビットの値
;; が設定される。

(define (O*2 val registers flag)
  ((((((registers 'OF-set) flag 'Shift) 'SF-set) val) 'ZF-set) val))

;; — : 実行前の値が保持されることを示す。
;;;;; 1.3 文字の符号表

;;;; 1. JIS X 0201 ラテン文字・片仮名用8ビット符号で規定する文字の符号表を使用する。

(define *latin-char*
  (alist-cons 126 #\̅
              (alist-cons 92 #\¥
                          (alist-delete 126
                                        (alist-delete 92
                                                      (map (lambda (x)
                                                             (cons x (integer->char x)))
                                                           (iota 128)))))))

(define *katakana*
  (map (lambda (x)
         (cons (- x 65216) (integer->char x)))
       (iota 94 65377)))

;;;; 2. 次に符号表の一部を示す。 

(define *JIS-X-0201*
  (append *latin-char* *katakana*))

(define *char-code*
  (map (lambda (x)
         (cons (cdr x) (car x)))
       *JIS-X-0201*))

;;; 1文字は８ビットからなり，上位4ビットを列で，下位4ビットを行で示す。 例えば，
;;; 間隔，4，H，\のビット構成は，16進表示で，それぞれ20，34，48，5Cである。
;;; ビット構成が21～7E（及び表では省略しているA1～DF）に対応する文字を図形文字と
;;; いう。 図形文字は，表示（印刷）装置で，文字として表示（印字）できる。

;;;; 3. この表にない文字とそのビット構成が必要な場合は，問題中で与える。

;;;;;; 参考資料

;;;; 参考資料は,COMET IIの理解を助けるため又は COMET IIの処理系作成者に対する
;;;; 便宜のための資料である。したがって,COMET II,CASL IIの仕様に影響を与える
;;;; ものではない。

;;;;; 命令語の構成

;;;; 命令語の構成は定義しないが，次のような構成を想定する。ここで，OPの数値は
;;;; 16進表示で示す。

(define (COMET-II memory)
  (let loop ((registers (make-registers)) (memory memory))
    (let ((k (registers 'PR-ref)))
      (let ((bytes (memory-ref memory k)))
        (let ((OP (bit-field bytes 8 16))
              (r (bit-field bytes 4 8))
              (x (bit-field bytes 0 4)))
          (case OP
            ((#x0) (loop (inc (NOP registers)) memory))
            ((#x10) (loop (inc (LD r (addressing k x registers memory) 
                                   registers) 2)
                          memory))
            ((#x11) (let-values (((registers memory) 
                                  (ST r (addressing k x registers memory))))
                      (loop (inc registers 2) (memory))))
            ((#x12) (loop (inc (LAD r (+ (r2 registers x)
                                         (address memory k)) registers) 2)
                          memory))
            ((#x14) (loop (inc (LD r (r2 registers x) registers))
                          memory))
            ((#x20) (loop (inc (ADDA r (addressing k x registers memory) 
                                     registers) 2)
                          memory))
            ((#x21) (loop (inc (SUBA r (addressing k x registers memory) 
                                     registers) 2)
                          memory))
            ((#x22) (loop (inc (ADDL r (addressing k x registers memory)
                                     registers) 2)
                          memory))
            ((#x23) (loop (inc (SUBL r (addressing k x registers memory)
                                     registers) 2)
                          memory))
            ((#x24) (loop (inc (ADDA r (r2 registers x) registers)) memory))
            ((#x25) (loop (inc (SUBA r (r2 registers x) registers)) memory))
            ((#x26) (loop (inc (ADDL r (r2 registers x) registers)) memory))
            ((#x27) (loop (inc (SUBL r (r2 registers x) registers)) memory))
            ((#x30) (loop (inc (AND r (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x31) (loop (inc (OR r (addressing k x registers memory)
                                   registers) 2)
                          memory))
            ((#x32) (loop (inc (XOR r (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x34) (loop (inc (AND r (r2 registers x) registers)) memory))
            ((#x35) (loop (inc (OR r (r2 registers x) registers)) memory))
            ((#x36) (loop (inc (XOR r (r2 registers x) registers)) memory))
            ((#x40) (loop (inc (CPA r (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x41) (loop (inc (CPL r (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x44) (loop (inc (CPA r (r2 x registers) registers)) memory))
            ((#x45) (loop (inc (CPL r (r2 x registers) registers)) memory))
            ((#x50) (loop (inc (SLA r (+ (r2 registers x) 
                                         (address memory k)) registers) 2)
                          memory))
            ((#x51) (loop (inc (SRA r (+ (r2 registers x)
                                         (address memory k)) registers) 2)
                          memory))
            ((#x52) (loop (inc (SLL r (+ (r2 registers x)
                                         (address memory k)) registers) 2)
                          memory))
            ((#x53) (loop (inc (SRL r (+ (r2 registers x)
                                         (address memory k)) registers) 2)
                          memory))
            ((#x61) (loop (inc (JMI (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x62) (loop (inc (JNZ (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x63) (loop (inc (JZE (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x64) (loop (inc (JUMP (addressing k x registers memory)
                                     registers) 2)
                          memory))
            ((#x65) (loop (inc (JPL (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x66) (loop (inc (JOV (addressing k x registers memory)
                                    registers) 2)
                          memory))
            ((#x70) (loop (inc (PUSH (addressing k x registers memory)
                                     registers) 2)
                          memory))
            ((#x71) (loop (inc (POP r registers)) memory))
            ((#x80) (loop (inc (CALL (addressing k x registers memory)
                                     registers) 2)
                          memory))
            ((#x81) (loop (inc (RET registers)) memory))
            ((#xF0) (let-values (((registers memory) 
                                  (SVC (addressing k x registers memory)
                                       registers memory)))
                      (loop (inc registers 2) memory)))
            (else (error "Unknown request -- COMET II: " OP))))))))