From e676d3621cc68b3fab125b320c8c5efeaf892527 Mon Sep 17 00:00:00 2001 From: plugd Date: Sat, 16 Nov 2019 10:48:47 +0100 Subject: [PATCH] More instructions implemented. Dwarves and Imps now run. --- mars.scm | 161 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 107 insertions(+), 54 deletions(-) diff --git a/mars.scm b/mars.scm index 994a2b8..39133d2 100644 --- a/mars.scm +++ b/mars.scm @@ -5,6 +5,7 @@ (import (chicken io) (chicken string) (chicken random) + (chicken condition) matchable) ;;; Constants @@ -51,12 +52,12 @@ (case mode ((immediate) "#") ((direct) "$") - ((indirect-A "*")) - ((indirect-B "@")) - ((pre-indirect-A "{")) - ((pre-indirect-B "<")) - ((post-indirect-A "}")) - ((post-indirect-B ">")))) + ((indirect-A) "*") + ((indirect-B) "@") + ((pre-indirect-A) "{") + ((pre-indirect-B) "<") + ((post-indirect-A) "}") + ((post-indirect-B) ">"))) (define initial-instruction (make-instr 'DAT 'F 'immediate 0 'immediate 0 '())) @@ -79,9 +80,10 @@ (core-set! i (initial-instruction 'copy '())) (loop (+ i 1))))) -(define (core-dump) +(define (dump-core) (let loop ((i 0)) (unless (>= i core-size) + (print* i ":\t") ((core-get i) 'print) (loop (+ i 1))))) @@ -138,66 +140,71 @@ (define (player-ptrs player) (cdr player)) (define (player-set-ptrs! player ptrs) - (set-cdr! prog-queue ptrs)) + (set-cdr! player ptrs)) ;;; Executive function ;; -(define (run players step) +(define (run players steps-left) (cond - ((> step max-steps) players) ;Tie between remaining players - ((<= (length players) 1) players) ;There's only one player left who thus wins + ((<= steps-left 0) players) ;Tie between remaining players + ;; ((<= (length players) 1) players) ;There's only one player left who thus wins (else - (let ((player (car players)) - (other-players (cdr players)) - (ptrs (player-ptrs player))) - (let ((new-ptrs (execute-instr (car ptrs) (player-name player)))) - (if (null? new-ptrs) - (run other-players (+ step 1)) - (begin - (player-set-ptrs! (append (cdr ptrs) new-ptrs)) - (run (append other-players (list player)) (+ step 1))))))))) + (let* ((player (car players)) + (other-players (cdr players)) + (ptrs (player-ptrs player)) + (new-ptrs (execute-instr (car ptrs) (player-name player)))) + (if (null? new-ptrs) + (run other-players (- steps-left 1)) + (begin + (player-set-ptrs! player (append (cdr ptrs) new-ptrs)) + (run (append other-players (list player)) (- steps-left 1)))))))) (define (execute-instr ptr name) (let* ((instr (core-get ptr)) - (A-pointer (eval-operand (instr 'A-mode) (instr 'A-num) ptr)) - (B-pointer (eval-operand (instr 'B-mode) (instr 'B-num) ptr)) - (modifier (instr-modifier instr))) - (case (instr-opcode instr) - ((DAT) '()) ;Game over, man, game over! + (A-ptr (eval-operand (instr 'A-mode) (instr 'A-num) ptr)) + (B-ptr (eval-operand (instr 'B-mode) (instr 'B-num) ptr)) + (modifier (instr 'modifier))) + (case (instr 'opcode) + ((DAT) + '()) ;Game over, man, game over! ((MOV) - (case modifier - ((A) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'A-num) name)) - ((B) ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'B-num) name)) - ((AB) ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'A-num) name)) - ((BA) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'B-num) name)) - ((F) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'A-num) name) - ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'B-num) name)) - ((X) ((core-get B-pointer) 'set-A-num! ((core-get A-pointer) 'B-num) name) - ((core-get B-pointer) 'set-B-num! ((core-get A-pointer) 'A-num) name)) - ((I) ((core-get B-pointer) 'copy-from! (core-get A-pointer) name))) + (if (eq? modifier 'I) + ((core-get B-ptr) 'copy-from! (core-get A-ptr) name) + (combine A-ptr B-ptr modifier name (lambda (x y) y))) (list (addr+ ptr 1))) ((ADD) - (case modifier - ((A)) - ((B)) - ((AB)) - ((BA)) - ((F)) - ((X)))) + (combine-and-store A-ptr B-ptr modifier name addr+) + (list (addr+ ptr 1))) ((SUB) - (case modifier - ((A)) - ((B)) - ((AB)) - ((BA)) - ((F)) - ((X)))) - ((MUL)) - ((DIV)) - ((MOD)) - ((JMP)) + (combine-and-store A-ptr B-ptr modifier name + (lambda (x y) (addr+ x (- y)))) + (list (addr+ ptr 1))) + ((MUL) + (combine-and-store A-ptr B-ptr modifier name + (lambda (x y) (modulo (* (addr+ x core-size) + (addr+ y core-size)) + core-size))) + (list (addr+ ptr 1))) + ((DIV) + (condition-case + (begin + (combine-and-store A-ptr B-ptr modifier name + (lambda (x y) (quotient (addr x core-size) + (addr y core-size)))) + (list (addr+ ptr 1))) + ((exn arithmetic) '()))) + ((MOD) + (condition-case + (begin + (combine-and-store A-ptr B-ptr modifier name + (lambda (x y) (remainder (addr x core-size) + (addr y core-size)))) + (list (addr+ ptr 1))) + ((exn arithmetic) '()))) + ((JMP) + (list (addr+ ptr ((core-get A-ptr) 'A-num)))) ((JMZ)) ((JMN)) ((DJN)) @@ -207,7 +214,26 @@ ((SPL)) ((NOP) (list (addr+ ptr 1))) (else - (error "Unrecognised opcode" (instr-opcode instr)))))) + (error "Unrecognised opcode" (instr 'opcode)))))) + +(define (combine-and-store A-ptr B-ptr modifier name f) + (case modifier + ((A) ((core-get B-ptr) 'set-A-num! + (f ((core-get B-ptr) 'A-num) ((core-get A-ptr) 'A-num)) name)) + ((B) ((core-get B-ptr) 'set-B-num! + (f ((core-get B-ptr) 'B-num) ((core-get A-ptr) 'B-num)) name)) + ((AB) ((core-get B-ptr) 'set-B-num! + (f ((core-get B-ptr) 'B-num) ((core-get A-ptr) 'A-num)) name)) + ((BA) ((core-get B-ptr) 'set-A-num! + (f ((core-get B-ptr) 'A-num) ((core-get A-ptr) 'B-num)) name)) + ((F I) ((core-get B-ptr) 'set-A-num! + (f ((core-get B-ptr) 'A-num) ((core-get A-ptr) 'A-num))) name + ((core-get B-ptr) 'set-B-num! + (f ((core-get B-ptr) 'B-num) ((core-get A-ptr) 'B-num)) name)) + ((X) ((core-get B-ptr) 'set-A-num! + (f ((core-get B-ptr) 'A-num) ((core-get A-ptr) 'B-num)) name) + ((core-get B-ptr) 'set-B-num! + (f ((core-get B-ptr) 'B-num) ((core-get A-ptr) 'A-num)) name)))) (define (eval-operand mode num ptr) (addr+ ptr @@ -236,3 +262,30 @@ (addr+ num old-B-num))) (else (error "Unrecognized mode" mode))))) + +;;; TEST CODE + +(define addressing-test + (make-prog 'at (list + (make-instr 'DAT 'F 'immediate 42 'immediate 53 'at) + (make-instr 'DAT 'F 'immediate 123 'immediate 256 'at) + (make-instr 'MOV 'A 'indirect-B 4 'direct 7 'at) + (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) + (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) + (make-instr 'NOP 'I 'immediate 0 'immediate 0 'at) + (make-instr 'DAT 'F 'immediate -5 'immediate -6 'at)) 2)) + +(define imp + (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1 'imp)) 0)) + +(define dwarf + (make-prog 'dwarf (list + (make-instr 'DAT 'F 'immediate 0 'immediate -1 'dwarf) + (make-instr 'ADD 'AB 'immediate 5 'direct -1 'dwarf) + (make-instr 'MOV 'I 'direct -2 'indirect-B -2 'dwarf) + (make-instr 'JMP 'I 'immediate -2 'immediate 0 'dwarf)) 1)) + +(initialize-core) +(define players (install-progs (list dwarf imp))) + +(dump-core) -- 2.20.1