[ create a new paste ] login | about

Link: http://codepad.org/Ep7u8l1h    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Apr 24:
; 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")


Create a new paste based on this one


Comments: