You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
121 lines
3.3 KiB
Scheme
121 lines
3.3 KiB
Scheme
6 years ago
|
(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)))))))
|
||
|
|
||
|
|