+(define (make-core core-size opcode modifier A-mode A-num B-mode B-num)
+ (let ((opcodes (make-vector core-size opcode))
+ (modifiers (make-vector core-size modifier))
+ (A-modes (make-vector core-size A-mode))
+ (A-nums (make-vector core-size A-num))
+ (B-modes (make-vector core-size B-mode))
+ (B-nums (make-vector core-size B-num))
+ (names (make-vector core-size '())))
+ (lambda args
+ (match args
+ ((i 'copy-to j n)
+ (vector-set! opcodes j (vector-ref opcodes i))
+ (vector-set! modifiers j (vector-ref modifiers i))
+ (vector-set! A-modes j (vector-ref A-modes i))
+ (vector-set! A-nums j (vector-ref A-nums i))
+ (vector-set! B-modes j (vector-ref B-modes i))
+ (vector-set! B-nums j (vector-ref B-nums i))
+ (vector-set! names j n))
+ ((i 'copy-from-instr! instr)
+ (vector-set! opcodes i (instr-opcode instr))
+ (vector-set! modifiers i (instr-modifier instr))
+ (vector-set! A-mode i (instr-A-mode instr))
+ (vector-set! A-num i (instr-A-num instr))
+ (vector-set! B-mode i (instr-B-mode instr))
+ (vector-set! B-num i (instr-B-num instr))
+ (vector-set! names i (instr-name instr)))
+ ((i 'opcode) (vector-ref opcodes i))
+ ((i 'modifier) (vector-ref modifiers i))
+ ((i 'A-mode) (vector-ref A-modes i))
+ ((i 'A-num) (vector-ref A-nums i))
+ ((i 'B-mode) (vector-ref B-modes i))
+ ((i 'B-num) (vector-ref B-nums i))
+ ((i 'name) (vector-ref names i))
+ ((i 'set-opcode! x n) (vector-set! opcodes i x) (vector-set! names i n))
+ ((i 'set-modifier! x n) (vector-set! modifiers i x) (vector-set! names i n))
+ ((i 'set-A-mode! x n) (vector-set! A-modes i x) (vector-set! names i n))
+ ((i 'set-A-num! x n) (vector-set! A-nums i x) (vector-set! names i n))
+ ((i 'set-B-mode! x n) (vector-set! B-modes i x) (vector-set! names i n))
+ ((i 'set-B-num! x n) (vector-set! B-nums i x) (vector-set! names i n))
+ (('dump)
+ (let loop ((i 0))
+ (unless (>= i core-size))
+ (print* i ":\t")
+ (instr->string (vector-ref opcodes i)
+ (vector-ref modifiers i)
+ (vector-ref A-modes i)
+ (vector-ref A-nums i)
+ (vector-ref B-modes i)
+ (vector-ref B-nums i)
+ (vector-ref names i))))))))
+
+(define (addr+ . args)
+ (foldl (lambda (a b)
+ (modulo (+ a b core-size) core-size))
+ 0 args))
+
+;;; Programmes
+;;
+
+(define (make-prog name instrs offset)
+ (list name instrs offset))
+
+(define (prog-name prog) (list-ref prog 0))
+(define (prog-instrs prog) (list-ref prog 1))
+(define (prog-offset prog) (list-ref prog 2))
+
+(define (install-prog core prog addr)
+ (let loop ((ptr addr)
+ (instrs (prog-instrs prog)))
+ (unless (null? instrs)
+ (core ptr 'copy-from-instr! (car instrs))
+ (loop (addr+ ptr 1) (cdr instrs))))
+ (make-player (prog-name prog)
+ (addr+ addr (prog-offset prog))))