From 7526b1f66f4c7a0d460d0e267b1eb4553c0d981b Mon Sep 17 00:00:00 2001 From: plugd Date: Sat, 23 Nov 2019 01:36:05 +0100 Subject: [PATCH] Parsing and execution of loadfiles working. --- imp.red | 9 ++++--- mars.scm | 79 +++++++++++++++++++++++++++++++++++------------------- parser.scm | 27 ++++++++++++------- test.scm | 46 +++++++++++++++++++++++++------ 4 files changed, 113 insertions(+), 48 deletions(-) diff --git a/imp.red b/imp.red index 4ef2cc1..766ae4e 100644 --- a/imp.red +++ b/imp.red @@ -1,6 +1,9 @@ ;redcode -;name Imp +;name Imp +;author A. K. Dewdney +;version 94.1 +;date April 29, 1993 -ORG 0 -MOV.I $0, $1 +ORG 0 +MOV.I $0, $1 diff --git a/mars.scm b/mars.scm index 23a0337..9610d10 100644 --- a/mars.scm +++ b/mars.scm @@ -9,10 +9,12 @@ prog-instrs prog-offset prog->string + dump-prog install-progs make-queue queue-owner queue-ptrs + dump-queue make-core run-mars) @@ -55,7 +57,7 @@ (('->string) (conc opcode "." modifier - " " (mode->string A-mode) A-num + "\t" (mode->string A-mode) A-num ", " (mode->string B-mode) B-num)) (else (error "Invalid instr arguments" args))))) @@ -95,6 +97,12 @@ (let loop ((remaining-fns set-functions)) (unless (null? remaining-fns) ((car remaining-fns) i n)))) + (define (dump i) + (print* i ":\t" ((norm-ref core-vec i) '->string)) + (let ((n (norm-ref names-vec i))) + (unless (null? n) + (print* "\t;" n))) + (print)) (let loop ((i 0)) (unless (>= i core-size) (vector-set! core-vec i (initial-instr 'make-copy)) @@ -116,27 +124,28 @@ ((i 'name) (norm-ref names-vec i)) (((? integer? i) v) ((norm-ref core-vec i) v)) (('->addr (? integer? i)) (norm-addr i)) - (('dump) - (let loop ((i 0)) - (unless (>= i core-size) - (print* i ":\t" ((vector-ref core-vec i) '->string)) - (let ((n (vector-ref names-vec i))) - (unless (null? n) - (print* "\t;" n))) - (print) - (loop (+ i 1))))) + (('dump i) + (let ((i1 (- i 4)) + (i2 (+ i 4))) + (let loop ((idx i1)) + (unless (> idx i2) + (if (= idx i) + (print* "*")) + (dump idx) + (loop (+ idx 1)))))) (('size) core-size))))) ;;; Programmes and task queues ;; - (define (make-prog name instrs offset) - (list name instrs offset)) + (define (make-prog name author instrs offset) + (list name author 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 (prog-author prog) (list-ref prog 1)) + (define (prog-instrs prog) (list-ref prog 2)) + (define (prog-offset prog) (list-ref prog 3)) (define (install-prog core prog addr) (let loop ((ptr addr) @@ -178,11 +187,24 @@ (define (queue-set-ptrs! queue ptrs) (set-cdr! queue ptrs)) + (define (dump-queue queue core) + (let loop ((ptrs (queue-ptrs queue))) + (unless (null? ptrs) + (core 'dump (car ptrs)) + (print) + (loop (cdr ptrs))))) + (define (prog->string prog) (conc ";redcode\n\n" - ";name " (prog-name prog) "\n\n" + ";name\t" (prog-name prog) "\n" + (if (not (null? (prog-author prog))) + (conc ";author\t" (prog-author prog) "\n\n") + "\n") "ORG\t" (prog-offset prog) "\t; Execution offset\n\n" (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog))))) + + (define (dump-prog prog) + (print (prog->string prog))) ;;; Executive function ;; @@ -190,19 +212,20 @@ (define (run-mars core queues steps-left) (cond ((<= steps-left 0) queues) ;Tie between remaining players - ;; ((<= (length queues) 1) queues) ;There's only one player left who thus wins + ((null? queues) queues) ;Everyone's dead (else (let* ((queue (car queues)) (remaining-queues (cdr queues)) (ptrs (queue-ptrs queue)) (new-ptrs (execute-instr core (car ptrs) (queue-owner queue)))) (if (null? new-ptrs) - (run-mars remaining-queues (- steps-left 1)) + (run-mars core remaining-queues (- steps-left 1)) (begin (queue-set-ptrs! queue (append (cdr ptrs) new-ptrs)) (run-mars core (append remaining-queues (list queue)) (- steps-left 1)))))))) (define (execute-instr core ptr name) + ;; (print ptr "\t" (core ptr '->string) "\t(" name ")") (let* ((A-ptr (eval-operand core (core ptr 'A-mode) (core ptr 'A-num) ptr name)) (B-ptr (eval-operand core (core ptr 'B-mode) (core ptr 'B-num) ptr name)) (modifier (core ptr 'modifier))) @@ -237,19 +260,19 @@ (list (core '->addr (+ ptr 1)))) ((exn arithmetic) '()))) ((JMP) - (list (core '->addr (+ ptr (core A-ptr 'A-num))))) + (list (core '->addr A-ptr))) ((JMZ) - (list (core '->addr (+ ptr (if (instr-zero? B-ptr modifier #f name) - (core A-ptr 'A-num) - 1))))) + (list (core '->addr (if (instr-zero? B-ptr modifier #f name) + A-ptr + (+ ptr 1))))) ((JMN) - (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #f name)) - (core A-ptr 'A-num) - 1))))) + (list (core '->addr (if (not (instr-zero? B-ptr modifier #f name)) + A-ptr + (+ ptr 1))))) ((DJN) - (list (core '->addr (+ ptr (if (not (instr-zero? B-ptr modifier #t name)) - (core A-ptr 'A-num) - 1))))) + (list (core '->addr (if (not (instr-zero? B-ptr modifier #t name)) + A-ptr + (+ ptr 1))))) ((SEQ CMP) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier =) 2 1))))) ((SNE) @@ -257,7 +280,7 @@ ((SLT) (list (core '->addr (+ ptr (if (compare-instrs core A-ptr B-ptr modifier <) 2 1))))) ((SPL) - (list (core '->addr (+ ptr 1) (core '->addr (+ ptr (core A-ptr 'A-num)))))) + (list (core '->addr (+ ptr 1) (core '->addr A-ptr)))) ((NOP) (list (core '->addr (+ ptr 1)))) (else diff --git a/parser.scm b/parser.scm index 11491b7..427d398 100644 --- a/parser.scm +++ b/parser.scm @@ -6,7 +6,7 @@ (chicken irregex) (chicken io) (chicken string) - mars) + srfi-13 mars) (define (string->prog str) (let ((idx 0) @@ -18,6 +18,8 @@ (redcode-irx (irregex "^;redcode\n")) (name-start-irx (irregex "^;[ \t]*name ")) (name-irx (irregex "^[a-zA-Z0-9]+")) + (author-start-irx (irregex "^;[ \t]*author ")) + (author-irx (irregex "^[^\n]*")) (comment-irx (irregex "^(;[^\n]*)?\n")) (org-irx (irregex "^ORG")) (opcode-DAT-irx (irregex "^DAT")) @@ -71,17 +73,20 @@ (accept-token redcode-irx #t) (let loop ((instrs '()) (offset 0) - (name '())) + (name '()) + (author '())) (let ((this-line (line))) (if this-line (case (car this-line) - ((name) (loop instrs offset (cdr this-line))) - ((comment) (loop instrs offset name)) - ((org) (loop instrs (cdr this-line) name)) - ((instr) (loop (cons (cdr this-line) instrs) offset name))) - (make-prog name (reverse instrs) offset))))) + ((name) (loop instrs offset (cdr this-line) author)) + ((author) (loop instrs offset name (cdr this-line))) + ((comment) (loop instrs offset name author)) + ((org) (loop instrs (cdr this-line) name author)) + ((instr) (loop (cons (cdr this-line) instrs) offset name author))) + (make-prog name author (reverse instrs) offset))))) (define (line) (or (name-line) + (author-line) (comment-line) (org-line) (instruction-line))) @@ -89,6 +94,10 @@ (if (accept-token name-start-irx) (cons 'name (string->symbol (accept-token name-irx #t))) #f)) + (define (author-line) + (if (accept-token author-start-irx) + (cons 'author (string-trim (accept-token author-irx #t))) + #f)) (define (comment-line) (if (accept-token comment-irx) '(comment) @@ -103,10 +112,10 @@ (let ((x (accept-token period-irx #t)) (modif (modifier)) (A-mode (mode)) - (A-num (accept-token number-irx #t)) + (A-num (string->number (accept-token number-irx #t))) (y (accept-token comma-irx #t)) (B-mode (mode)) - (B-num (accept-token number-irx #t)) + (B-num (string->number (accept-token number-irx #t))) (z (accept-token comment-irx #t))) (cons 'instr (make-instr oc modif A-mode A-num B-mode B-num))) #f))) diff --git a/test.scm b/test.scm index 7f6f921..178260d 100644 --- a/test.scm +++ b/test.scm @@ -1,4 +1,5 @@ -(import mars visualizer parser) +(import (chicken io) + mars visualizer parser) ;; (define addressing-test ;; (make-prog 'at (list @@ -20,18 +21,47 @@ ;; (make-instr 'MOV 'I 'direct -2 'indirect-B -2) ;; (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1)) -(define imp (string->prog (with-input-from-file "imp.red" read-string))) -(define dwarf (string->prog (with-input-from-file "dwarf.red" read-string))) +(condition-case + (vis 'destroy) + ((exn) #f)) -(define palette '((Imp . "red") - (Dwarf . "blue"))) +;; (define files '("dwarf.red")) +(define files '("imp.red" "dwarf.red")) -(define vis (make-vis 640 480 8000 palette)) +(define progs + (map + (lambda (fname) + (string->prog (with-input-from-file fname read-string))) + files)) + +(define colors '("red" "blue" "green" "magenta" "cyan")) + +(define color-map + (let loop ((entries '()) + (progs-left progs) + (colors-left colors)) + (if (null? progs-left) + entries + (let ((this-prog (car progs-left)) + (this-col (car colors-left))) + (loop (cons (cons (prog-name this-prog) this-col) entries) + (cdr progs-left) + (cdr colors-left)))))) + +(define vis (make-vis 640 480 8000 color-map)) (define core (make-core 8000 (make-instr 'DAT 'F 'immediate 0 'immediate 0) (lambda (i n) (vis 'update-owner i n)))) -(define queues (install-progs core (list dwarf imp))) +(define queues (install-progs core progs)) + +(for-each dump-prog progs) + +(set! queues (run-mars core queues 10000)) -(run-mars core queues 10000) +(for-each (lambda (q) + (print "Queue for " (queue-owner q) ":") + (dump-queue q core) + (print)) + queues) -- 2.20.1