3l/terminal.scm

(define-syntax enum
  (lambda (x r c)
    (let ((name (symbol->string (cadr x))))
      `(,(r 'begin)
        ,@(map (lambda (var/val)
                 `(,(r 'define) ,(string->symbol
                                  (string-append name
                                                 "."
                                                 (symbol->string (car var/val))))
                   ,(cadr var/val)))
               (caddr x))))))

(define (word-set-at! addr index val)
  (word-set! (address+ addr index) val))

(define-syntax set++!
  (syntax-rules ()
    ((_ v)
     (begin (set! v (+ v 1)) v))))

(define-syntax set--!
  (syntax-rules ()
    ((_ v)
     (begin (set! v (- v 1)) v))))


(define (ipow base exp)
  (let loop ((r 1) (exp exp) (base base))
    (if (> exp 0)
        (let ((nr
               (if (> (bitwise-and exp 1) 0)
                   (* r base)
                   r)))
          (loop nr (arithmetic-shift-right exp 1) (* base base)))
        r)))

(enum vga-color
      ((black 0)
       (blue 1)
       (green 2)
       (cyan 2)
       (red 4)
       (magenta 5)
       (brown 6)
       (light-grey 7)
       (dark-grey 8)
       (light-blue 9)
       (light-green 10)
       (light-cyan 11)
       (light-red 12)
       (light-magenta 13)
       (light-brown 14)
       (white 15)))

(define (make-color fg bg)
  (bitwise-ior fg (shift-left bg 4)))

(define (make-vga-entry c color)
  (bitwise-ior c (shift-left color 8)))

(define *terminal-index*)
(define *terminal-color*)
(define *terminal-buffer*)

(define (initialize)
  (set! *terminal-index* 0)
  (set! *terminal-color* (make-color vga-color.green vga-color.black))
  (set! *terminal-buffer* (integer->address #xB8000))
  (let loop ((y 0))
    (if (< y 4000)
        (begin
          (word-set! (address+ *terminal-buffer* y)
                     (make-vga-entry (char->ascii #\space)
                                     *terminal-color*))
          (loop (+ y 2)))))
  )

(define (set-color color)
  (set! *terminal-color* color))

(define (put-entry-at c color index)
  (word-set-at! *terminal-buffer* index
                (make-vga-entry (char->ascii c) color)))

(define (put-char c)
  (if (char=? c #\newline)
      (begin
        (set! *terminal-index*
          (+ *terminal-index* (- 160 (remainder *terminal-index* 160)))))
      (begin
        (put-entry-at c *terminal-color* *terminal-index*)
        (set! *terminal-index* (+ *terminal-index* 2)))))

(define *ascii-numeric-start* 48)
(define (put-number num)
  ;; Can handle up to a uint32
  (define (num-digits num n)
    (cond ((>= num 100000000)
           (num-digits (quotient num 100000000) (+ n 8)))
          ((>= num 10000)
           (num-digits (quotient num 10000) (+ n 4)))
          ((>= num 100)
           (num-digits (quotient num 100) (+ n 2)))
          ((>= num 10)
           (+ n 1))
          (else n)))

  (if (< num 0)
      (put-char #\-))
  (let ((ndigits (num-digits (abs num) 1)))
    (let loop ((digits-remaining (- ndigits 1))
               (mult (ipow 10 (- ndigits 1)))
               (num (abs num)))
      (put-char
       (ascii->char (+ *ascii-numeric-start* (quotient num mult))))
      (if (> digits-remaining 0)
          (let ((remains (- digits-remaining 1)))
            (loop remains (ipow 10 remains) (remainder num mult)))))))