codepad
[
create a new paste
]
login
|
about
Language:
C
C++
D
Haskell
Lua
OCaml
PHP
Perl
Plain Text
Python
Ruby
Scheme
Tcl
; assembler, part 3 (define (sprintf fmt . args) (define (escape cs) (define (octal? c) (char<=? #\0 c #\7)) (define (c->o c) (- (char->integer c) 48)) (cond ((null? cs) (error 'escape "incomplete")) ((not (char=? (car cs) #\\)) (values (car cs) (cdr cs))) ((null? (cdr cs)) (error 'escape "malformed")) ((char=? (cadr cs) #\b) (values #\backspace (cddr cs))) ((char=? (cadr cs) #\f) (values #\page (cddr cs))) ((char=? (cadr cs) #\n) (values #\newline (cddr cs))) ((char=? (cadr cs) #\r) (values #\return (cddr cs))) ((char=? (cadr cs) #\t) (values #\tab (cddr cs))) ((octal? (cadr cs)) (let loop ((k 3) (cs (cdr cs)) (oct 0)) (if (and (positive? k) (pair? cs) (octal? (car cs))) (loop (- k 1) (cdr cs) (+ (* oct 8) (c->o (car cs)))) (values (integer->char oct) cs)))) (else (values (cadr cs) (cddr cs))))) (define (specifier cs arg) (define (c->d c) (- (char->integer c) 48)) (define (justify str left? pad? width) (let ((len (string-length str))) (cond ((<= width len) str) (left? (string-append str (make-string (- width len) #\space))) ((and pad? (not left?)) (string-append (make-string (- width len) #\0) str)) (else (string-append (make-string (- width len) #\space) str))))) (define (rnd num prec) (if prec (/ (round (* num (expt 10 prec))) (expt 10 prec)) num)) (define (trunc num) (inexact->exact (truncate num))) (let ((cs (cdr cs)) (left? #f) (pad? #f) (width 0) (prec #f)) (when (and (pair? cs) (char=? (car cs) #\-)) (set! left? #t) (set! cs (cdr cs))) (when (and (pair? cs) (char=? (car cs) #\0)) (set! pad? #t) (set! cs (cdr cs))) (do () ((or (null? cs) (not (char-numeric? (car cs))))) (set! width (+ (* width 10) (c->d (car cs)))) (set! cs (cdr cs))) (when (and (pair? cs) (char=? (car cs) #\.)) (set! cs (cdr cs)) (set! prec 0) (do () ((or (null? cs) (not (char-numeric? (car cs))))) (set! prec (+ (* prec 10) (c->d (car cs)))) (set! cs (cdr cs)))) (if (null? cs) (error 'specifier "incomplete") (case (car cs) ((#\c) (values (justify (string (integer->char arg)) left? #f width) (cdr cs))) ((#\d) (values (justify (number->string (trunc arg)) left? pad? width) (cdr cs))) ((#\f) (values (justify (number->string (rnd arg prec)) left? pad? width) (cdr cs))) ((#\o) (values (justify (number->string (trunc arg) 8) left? pad? width) (cdr cs))) ((#\s) (values (justify (if prec (substring arg 0 prec) arg) left? #f width) (cdr cs))) ((#\x) (values (justify (number->string (trunc arg) 16) left? pad? width) (cdr cs))) ((#\%) (values "%" cs)) (else (error 'specifier "unsupported")))))) (let loop ((cs (string->list fmt)) (args args) (out (list))) (cond ((null? cs) (if (pair? args) (error 'printf "too many arguments") (list->string (reverse out)))) ((char=? (car cs) #\\) (call-with-values (lambda () (escape cs)) (lambda (c rest) (loop rest args (cons c out))))) ((char=? (car cs) #\%) (if (null? (cdr cs)) (error 'sprintf "incomplete specifier") (if (char=? (cadr cs) #\%) (loop (cddr cs) args (cons #\% out)) (if (null? args) (error 'printf "not enough arguments") (call-with-values (lambda () (specifier cs (car args))) (lambda (str rest) (loop rest (cdr args) (append (reverse (string->list str)) out)))))))) (else (loop (cdr cs) args (cons (car cs) out)))))) (define (printf fmt . args) (display (apply sprintf fmt args))) (define labels (list)) (define opcodes '(("const" . 0) ("get" . 1) ("put" . 2) ("ld" . 3) ("st" . 4) ("add" . 5) ("sub" . 6) ("jpos" . 7) ("jz" . 8) ("j" . 9) ("halt" . 10))) (define (split line) (define (skip-blanks) (let loop () (if (or (null? line) (not (char-whitespace? (car line)))) #f (begin (set! line (cdr line)) (loop))))) (define (get-string) (let loop ((str (list))) (if (or (null? line) (char-whitespace? (car line))) (list->string (reverse str)) (let ((c (car line))) (set! line (cdr line)) (loop (cons c str)))))) (let* ((lbl (get-string)) (_ (skip-blanks)) (opc (get-string)) (_ (skip-blanks)) (obj (get-string)) (_ (skip-blanks))) (values lbl opc obj (list->string line)))) (define (asm1 file-name) ; first-pass (set! labels (list)) (with-input-from-file file-name (lambda () (let loop ((k 0) (line (read-line)) (lines (list))) (if (eof-object? line) (reverse lines) (if (or (string=? line "") (char=? (string-ref line 0) #\#)) (loop k (read-line) lines) (call-with-values (lambda () (split (string->list line))) (lambda (lbl opc obj cmt) (when (not (string=? lbl "")) (set! labels (cons (cons lbl k) labels))) (loop (+ k 1) (read-line) (cons (vector k lbl opc obj cmt) lines)))))))))) (define (asm2 lines) ; second pass (let ((mem (make-vector 1000 0))) (do ((lines lines (cdr lines))) ((null? lines) mem) (let ((num (vector-ref (car lines) 0)) (opc (vector-ref (car lines) 2)) (obj (vector-ref (car lines) 3))) (vector-set! mem num (+ (* (cdr (assoc opc opcodes)) 1000) (if (assoc obj labels) (cdr (assoc obj labels)) (if (not (string=? obj "")) (string->number obj) 0)))))))) (define (sim mem) (let loop ((pc 0) (acc 0)) (let ((addr (modulo (vector-ref mem pc) 1000)) (code (quotient (vector-ref mem pc) 1000))) (case code ((1) (loop (+ pc 1) (read))) ; get ((2) (display acc) (newline) (loop (+ pc 1) acc)) ; put ((3) (loop (+ pc 1) (vector-ref mem addr))) ; ld ((4) (vector-set! mem addr acc) (loop (+ pc 1) acc)) ; st ((5) (loop (+ pc 1) (+ acc (vector-ref mem addr)))) ; add ((6) (loop (+ pc 1) (- acc (vector-ref mem addr)))) ; sub ((7) (loop (if (positive? acc) addr (+ pc 1)) acc)) ; jpos ((8) (loop (if (zero? acc) addr (+ pc 1)) acc)) ; jz ((9) (loop addr acc)) ; j ((10) (if #f #f)) ; halt (else (error 'sim "unrecognized command")))))) (define (widths lines) (apply vector (map (lambda (xs) (apply max xs)) (apply map list (map (lambda (line) (map string-length (cdr (vector->list line)))) lines))))) (define (listing file-name) (let* ((lines (asm1 file-name)) (mem (asm2 lines)) (widths (widths lines))) (define (wid n) (string-append "%-" (number->string (vector-ref widths n)) "s ")) (with-input-from-file file-name (lambda () (let loop ((k 0) (line (read-line)) (lines lines)) (when (not (eof-object? line)) (if (or (string=? line "") (char=? (string-ref line 0) #\#)) (begin (printf "%s\n" line) (loop k (read-line) lines)) (begin (printf "%03d: " k) (printf "%05d " (vector-ref mem k)) (printf (wid 0) (vector-ref (car lines) 1)) (printf (wid 1) (vector-ref (car lines) 2)) (printf (wid 2) (vector-ref (car lines) 3)) (printf (wid 3) (vector-ref (car lines) 4)) (printf "\n") (loop (+ k 1) (read-line) (cdr lines)))))))))) (listing "program.asm")
Private
[
?
]
Run code
Submit