From: plugd Date: Fri, 22 Nov 2019 15:24:08 +0000 (+0100) Subject: This is too adictive. X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=commitdiff_plain;h=6fa8a83fb4cf917fabe4c2bb930b8b092c9c7519;p=jars.git This is too adictive. --- diff --git a/dwarf.red b/dwarf.red new file mode 100644 index 0000000..d0abecb --- /dev/null +++ b/dwarf.red @@ -0,0 +1,17 @@ +;redcode + +;name Dwarf +;author A. K. Dewdney +;version 94.1 +;date April 29, 1993 + +;strategy Bombs every fourth instruction. +;assert CORESIZE % 4 == 0 + +ORG 1 ; Indicates execution begins with the second +; instruction (ORG is not actually loaded, and is + +DAT.F #0, #0 ; Pointer to target instruction. +ADD.AB #4, $-1 ; Increments pointer by step. +MOV.AB #0, @-2 ; Bombs target instruction. +JMP.A $-2, #0 ; Loops back two instructions. diff --git a/imp.red b/imp.red new file mode 100644 index 0000000..4ef2cc1 --- /dev/null +++ b/imp.red @@ -0,0 +1,6 @@ +;redcode + +;name Imp + +ORG 0 +MOV.I $0, $1 diff --git a/mars.scm b/mars.scm index 40e4ca1..23a0337 100644 --- a/mars.scm +++ b/mars.scm @@ -8,6 +8,7 @@ prog-name prog-instrs prog-offset + prog->string install-progs make-queue queue-owner @@ -55,7 +56,7 @@ (conc opcode "." modifier " " (mode->string A-mode) A-num - " " (mode->string B-mode) B-num)) + ", " (mode->string B-mode) B-num)) (else (error "Invalid instr arguments" args))))) @@ -177,7 +178,12 @@ (define (queue-set-ptrs! queue ptrs) (set-cdr! queue ptrs)) - + (define (prog->string prog) + (conc ";redcode\n\n" + ";name " (prog-name prog) "\n\n" + "ORG\t" (prog-offset prog) "\t; Execution offset\n\n" + (apply conc (map (lambda (instr) (conc (instr '->string) "\n")) (prog-instrs prog))))) + ;;; Executive function ;; diff --git a/parse.scm b/parse.scm deleted file mode 100644 index c2bec6a..0000000 --- a/parse.scm +++ /dev/null @@ -1,34 +0,0 @@ -(import (chicken irregex)) - -(define (string->instr str) - (let ((idx 0) - (l (string-length str)) - (whitespace-irx (irregex "[ \t]*")) - (newline-irx (irregex "\n")) - (comment-irx (irregex ";[^\n]*"))) - (define (accept-token irx mandatory) - (let ((wsmatch (irregex-match whitespace-irx (substr str idx)))) - (set! idx (+ idx (irregex-match-end-index wsmatch)))) ;Skip leading whitespace - (let ((res (irregex-match irx (substring str idx)))) - (if res - (begin - (set! idx (+ idx (irregex-match-end-index res))) - (irregex-match-substring res)) - (if mandatory - (error "Unexpected token at input string index" idx) - #f)))) - (define (accept-token-string token-str mandatory) - (accept-token (irregex token-str) mandatory)) - (define (load-file) - (let loop () - (if (line) - (loop)))) - (define (line) - (or (accept-token comment-irx #f) - (accept-token newline-irx #f) - (and(accept-token newline-irx #t)))) - (define (instruction) - (and (opcode) - (accept-token period-irx #t) - (accept-modifier))))) - diff --git a/parser.scm b/parser.scm new file mode 100644 index 0000000..11491b7 --- /dev/null +++ b/parser.scm @@ -0,0 +1,174 @@ +(module parser + (string->prog) + + (import scheme + (chicken base) + (chicken irregex) + (chicken io) + (chicken string) + mars) + + (define (string->prog str) + (let ((idx 0) + (l (string-length str)) + (whitespace-irx (irregex "^[ \t]+")) + (newline-irx (irregex "^\n")) + (comma-irx (irregex "^,")) + (period-irx (irregex "^\\.")) + (redcode-irx (irregex "^;redcode\n")) + (name-start-irx (irregex "^;[ \t]*name ")) + (name-irx (irregex "^[a-zA-Z0-9]+")) + (comment-irx (irregex "^(;[^\n]*)?\n")) + (org-irx (irregex "^ORG")) + (opcode-DAT-irx (irregex "^DAT")) + (opcode-MOV-irx (irregex "^MOV")) + (opcode-ADD-irx (irregex "^ADD")) + (opcode-SUB-irx (irregex "^SUB")) + (opcode-MUL-irx (irregex "^MUL")) + (opcode-DIV-irx (irregex "^DIV")) + (opcode-MOD-irx (irregex "^MOD")) + (opcode-JMP-irx (irregex "^JMP")) + (opcode-JMZ-irx (irregex "^JMZ")) + (opcode-JMN-irx (irregex "^JMN")) + (opcode-DMN-irx (irregex "^JMN")) + (opcode-DJN-irx (irregex "^DJN")) + (opcode-CMP-irx (irregex "^CMP")) + (opcode-SEQ-irx (irregex "^SEQ")) + (opcode-SNE-irx (irregex "^SNE")) + (opcode-SLT-irx (irregex "^SLT")) + (opcode-SPL-irx (irregex "^SPL")) + (opcode-NOP-irx (irregex "^NOP")) + (modifier-A-irx (irregex "^A")) + (modifier-B-irx (irregex "^B")) + (modifier-AB-irx (irregex "^AB")) + (modifier-BA-irx (irregex "^BA")) + (modifier-F-irx (irregex "^F")) + (modifier-X-irx (irregex "^X")) + (modifier-I-irx (irregex "^I")) + (mode-immediate-irx (irregex "^#")) + (mode-direct-irx (irregex "^\\$")) + (mode-indirect-A-irx (irregex "^\\*")) + (mode-indirect-B-irx (irregex "^@")) + (mode-pre-indirect-A-irx (irregex "^\\{")) + (mode-pre-indirect-B-irx (irregex "^<")) + (mode-post-indirect-A-irx (irregex "^\\}")) + (mode-post-indirect-B-irx (irregex "^>")) + (number-irx (irregex "^(\\+|-)?[0-9]+"))) + (define (accept-token irx . rest) + (let ((wsmatch (irregex-search whitespace-irx (substring str idx)))) + (if wsmatch + (set! idx (+ idx (irregex-match-end-index wsmatch))))) ;Skip leading whitespace + (let ((mandatory (and (= (length rest) 1) (car rest))) + (res (irregex-search irx (substring str idx)))) + (if res + (begin + (set! idx (+ idx (irregex-match-end-index res))) + (irregex-match-substring res)) + (if mandatory + (error "Unexpected token at input string index" idx) + #f)))) + (define (load-file) + (accept-token redcode-irx #t) + (let loop ((instrs '()) + (offset 0) + (name '())) + (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))))) + (define (line) + (or (name-line) + (comment-line) + (org-line) + (instruction-line))) + (define (name-line) + (if (accept-token name-start-irx) + (cons 'name (string->symbol (accept-token name-irx #t))) + #f)) + (define (comment-line) + (if (accept-token comment-irx) + '(comment) + #f)) + (define (org-line) + (if (accept-token org-irx) + (cons 'org (string->number (accept-token number-irx #t))) + #f)) + (define (instruction-line) + (let ((oc (opcode))) + (if oc + (let ((x (accept-token period-irx #t)) + (modif (modifier)) + (A-mode (mode)) + (A-num (accept-token number-irx #t)) + (y (accept-token comma-irx #t)) + (B-mode (mode)) + (B-num (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))) + (define (opcode) + (let ((res (or (accept-token opcode-DAT-irx) + (accept-token opcode-MOV-irx) + (accept-token opcode-ADD-irx) + (accept-token opcode-SUB-irx) + (accept-token opcode-MUL-irx) + (accept-token opcode-DIV-irx) + (accept-token opcode-MOD-irx) + (accept-token opcode-JMP-irx) + (accept-token opcode-JMZ-irx) + (accept-token opcode-JMN-irx) + (accept-token opcode-DJN-irx) + (accept-token opcode-CMP-irx) + (accept-token opcode-SEQ-irx) + (accept-token opcode-SNE-irx) + (accept-token opcode-SLT-irx) + (accept-token opcode-SPL-irx) + (accept-token opcode-NOP-irx)))) + (if res (string->symbol res) #f))) + (define (modifier) + (string->symbol + (or (accept-token modifier-AB-irx) + (accept-token modifier-BA-irx) + (accept-token modifier-A-irx) + (accept-token modifier-B-irx) + (accept-token modifier-F-irx) + (accept-token modifier-X-irx) + (accept-token modifier-I-irx)))) + (define (mode) + (or (mode-immediate) + (mode-direct) + (mode-indirect-A) + (mode-indirect-B) + (mode-pre-indirect-A) + (mode-pre-indirect-B) + (mode-post-indirect-A) + (mode-post-indirect-B))) + (define (mode-immediate) + (and (accept-token mode-immediate-irx) + 'immediate)) + (define (mode-direct) + (and (accept-token mode-direct-irx) + 'direct)) + (define (mode-indirect-A) + (and (accept-token mode-indirect-A-irx) + 'indirect-A)) + (define (mode-indirect-B) + (and (accept-token mode-indirect-B-irx) + 'indirect-B)) + (define (mode-pre-indirect-A) + (and (accept-token mode-pre-indirect-A-irx) + 'pre-indirect-A)) + (define (mode-pre-indirect-B) + (and (accept-token mode-pre-indirect-B-irx) + 'pre-indirect-B)) + (define (mode-post-indirect-A) + (and (accept-token mode-post-indirect-A-irx) + 'post-indirect-A)) + (define (mode-post-indirect-B) + (and (accept-token mode-post-indirect-B-irx) + 'post-indirect-B)) + (load-file)))) diff --git a/test.scm b/test.scm index 090c941..7f6f921 100644 --- a/test.scm +++ b/test.scm @@ -1,27 +1,30 @@ -(import mars visualizer) - -(define addressing-test - (make-prog 'at (list - (make-instr 'DAT 'F 'immediate 42 'immediate 53) - (make-instr 'DAT 'F 'immediate 123 'immediate 256) - (make-instr 'MOV 'A 'indirect-B 4 'direct 7) - (make-instr 'NOP 'I 'immediate 0 'immediate 0) - (make-instr 'NOP 'I 'immediate 0 'immediate 0) - (make-instr 'NOP 'I 'immediate 0 'immediate 0) - (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2)) - -(define imp - (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0)) - -(define dwarf - (make-prog 'dwarf (list - (make-instr 'DAT 'F 'immediate 0 'immediate -1) - (make-instr 'ADD 'AB 'immediate 5 'direct -1) - (make-instr 'MOV 'I 'direct -2 'indirect-B -2) - (make-instr 'JMP 'I 'immediate -2 'immediate 0)) 1)) - -(define palette '((imp . "red") - (dwarf . "blue"))) +(import mars visualizer parser) + +;; (define addressing-test +;; (make-prog 'at (list +;; (make-instr 'DAT 'F 'immediate 42 'immediate 53) +;; (make-instr 'DAT 'F 'immediate 123 'immediate 256) +;; (make-instr 'MOV 'A 'indirect-B 4 'direct 7) +;; (make-instr 'NOP 'I 'immediate 0 'immediate 0) +;; (make-instr 'NOP 'I 'immediate 0 'immediate 0) +;; (make-instr 'NOP 'I 'immediate 0 'immediate 0) +;; (make-instr 'DAT 'F 'immediate -5 'immediate -6)) 2)) + +;; (define imp +;; (make-prog 'imp (list (make-instr 'MOV 'I 'direct 0 'direct 1)) 0)) + +;; (define dwarf +;; (make-prog 'dwarf (list +;; (make-instr 'DAT 'F 'immediate 0 'immediate -1) +;; (make-instr 'ADD 'AB 'immediate 5 'direct -1) +;; (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))) + +(define palette '((Imp . "red") + (Dwarf . "blue"))) (define vis (make-vis 640 480 8000 palette)) @@ -31,4 +34,4 @@ (define queues (install-progs core (list dwarf imp))) -;; (run-mars core queues 10000) +(run-mars core queues 10000)