summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorThomas Hintz <t@thintz.com>2018-08-21 21:42:50 -0700
committerThomas Hintz <t@thintz.com>2018-08-21 21:42:50 -0700
commitb09b9283cd5adbfa5e88a10f1473bdf1474a5df0 (patch)
treec5cb14d5c4f8e2c72fbd09708c9def2ce0d38a46
download3l-b09b9283cd5adbfa5e88a10f1473bdf1474a5df0.tar.gz
Initial commit.HEADmaster
-rw-r--r--Makefile49
-rw-r--r--ev-environment.scm17
-rw-r--r--ev-runtime.scm114
-rw-r--r--ev.scm740
-rw-r--r--heap-writer.scm93
-rw-r--r--packages.scm18
-rw-r--r--ps-macros.scm4
-rw-r--r--terminal.scm120
8 files changed, 1155 insertions, 0 deletions
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..99c48aa
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,49 @@
+.PHONY: all rebuild clean spotless newimage
+
+all: tos.sys
+
+rebuild: clean all
+
+run:
+ qemu-system-x86_64 -vga std -smp 8 -m 256 -drive id=disk,file=bmfs.image,format=raw,if=none -device ahci,id=ahci -device ide-drive,drive=disk,bus=ahci.0 -name "LLL"
+
+tos.sys: vm.bin pure64.sys
+ dd if=/dev/zero of=kernel.bin bs=1M count=1
+ dd if=vm.bin of=kernel.bin bs=512 conv=notrunc
+ dd if=heap.bin of=kernel.bin seek=256 bs=512 conv=notrunc
+ ./bmfs bmfs.image write kernel.bin
+ cat pure64.sys kernel64.sys > tos.sys
+ dd if=tos.sys of=bmfs.image bs=512 seek=16 conv=notrunc
+
+vm.bin: vm.o vm-loader.o heap.bin
+ gcc -T vm.ld -o vm.bin -ffreestanding -O3 -nostdlib vm-loader.o vm.o -lgcc -mno-red-zone
+
+vm.o: vm.c prescheme.h
+ gcc -O3 -o vm.o -c vm.c -nostdlib -nostartfiles -nodefaultlibs -mno-red-zone -std=gnu99 -ffreestanding
+
+vm.c: ev.scm ps-macros.scm packages.scm terminal.scm
+ scheme48 -i ps-vm-compiler.image < compile-vm.scm
+
+vm-loader.o: vm-loader.asm
+ nasm -f elf64 vm-loader.asm -o vm-loader.o
+
+heap.bin: heap-writer.scm ev.scm ev-runtime.scm ev-environment.scm
+ csi -s heap-writer.scm
+
+heap-debug.bin: heap-writer.scm ev.scm ev-runtime.scm ev-environment.scm
+ csi -D debug -s heap-writer.scm
+
+newimage:
+ dd if=/dev/zero of=bmfs.image bs=1M count=8
+ ./bmfs bmfs.image format /force
+ dd if=bmfs_mbr.sys of=bmfs.image bs=512 conv=notrunc
+ ./bmfs bmfs.image create kernel.bin 1
+ make clean
+
+clean:
+ rm -f *.o *.so *.bin tos.sys heap-writer vm.c
+
+spotless:
+ rm -f bmfs.image
+ make clean
+
diff --git a/ev-environment.scm b/ev-environment.scm
new file mode 100644
index 0000000..5e03943
--- /dev/null
+++ b/ev-environment.scm
@@ -0,0 +1,17 @@
+`(((quote set! type value eq?
+ nil env
+ + -
+ cons car cdr
+ eval record vau wrap
+ byte-set!
+ type-eq?
+ xyz)
+
+ ,(make-quote) ,(make-assign) ,(make-type) ,(make-value) ,(make-eq?)
+ ,(make-nil) ,(make-env)
+ ,(make-add) ,(make-sub)
+ ,(make-cons) ,(make-car) ,(make-cdr)
+ ,(make-eval) ,(make-record) ,(make-vau) ,(make-wrap)
+ ,(make-byte-set!)
+ ,(make-type-eq?)
+ 10))
diff --git a/ev-runtime.scm b/ev-runtime.scm
new file mode 100644
index 0000000..7752549
--- /dev/null
+++ b/ev-runtime.scm
@@ -0,0 +1,114 @@
+(
+(set! quote (vau ((x)) x))
+
+(set! list (wrap (vau (elements) elements)))
+
+(set! lambda
+ (vau ((formals body) env)
+ (wrap (eval (list (quote vau) (list formals) body) env))))
+
+(set! *vga-mem* 753664)
+
+(set! $eq?
+ (vau ((a b conseq alt) env)
+ (eval (eq? (eval a env) (eval b env)
+ conseq
+ alt)
+ env)))
+
+(set! $type-eq?
+ (vau ((a b conseq alt) env)
+ (eval (type-eq? (eval a env) (eval b env)
+ conseq
+ alt)
+ env)))
+
+(set! *nil-record* (nil))
+
+(set! $null?
+ (vau ((x conseq alt) env)
+ (eval
+ ($eq? (eval x env) *nil-record* conseq alt)
+ env)))
+
+;; BUG not finding the variable bindings in a VAU
+(lambda () 1)
+
+;; (set! map
+;; (lambda (proc lis)
+;; ($null? lis
+;; lis
+;; (cons (proc (car lis)) (map proc (cdr lis))))))
+
+;; ;; ((vau ((x y))
+;; ;; body)
+;; ;; (1 2))
+;; (set! let
+;; (vau ((vars body) env)
+;; ((eval (list (quote vau) (list (map car vars))
+;; body)
+;; env))))
+
+;; (set! cseq
+;; (lambda (n op)
+;; ($eq? n 5
+;; 0
+;; (cseq (+ n 1) (write-char (+ n 80))))))
+
+;; (set! *a-pair* (cons 98 99))
+;; (set! $pair?
+;; (vau ((obj conseq alt) env)
+;; (eval ($type-eq? (eval obj env) *a-pair* conseq alt) env)))
+
+;; (set! char-rec-num 100)
+;; (set! char-rec (record char-rec-num))
+;; (set! char (lambda (n) (cons char-rec n)))
+;; (set! char-val (lambda (c) (cdr c)))
+
+;; (set! $char?
+;; (vau ((obj conseq alt) env)
+;; ((lambda (res)
+;; (eval ($pair? res
+;; (type-eq? (car res) char-rec conseq alt)
+;; alt)
+;; env))
+;; obj)))
+
+;; (set! write-char
+;; ((lambda (pos)
+;; (lambda (c)
+;; (list (byte-set! pos (char-val c)) (set! pos (+ pos 2)))))
+;; (+ *vga-mem* 8)))
+
+;; (set! write-val
+;; ((lambda (pos)
+;; (lambda (v)
+;; (list (byte-set! pos v) (set! pos (+ pos 2)))))
+;; (+ *vga-mem* 8)))
+
+;; ;; (map write-char
+;; ;; (map char
+;; ;; (list 72 101 108 108 111 44 32 119 111 114 108 100 33)))
+
+;; (set! print
+;; (lambda (obj)
+;; ($char? obj
+;; (map write-char (list (char 35) (char 92) obj))
+;; ($pair? obj
+;; (map print (list (char 40) (map print obj) (char 41)))
+;; (write-char (char 33))
+;; ))))
+
+;; (set! print2
+;; (lambda (obj)
+;; ($char? obj
+;; (write-char (char 72))
+;; (write-char (char 73)))))
+
+
+
+;; ;; BUG? type-eq? is evaluating its arguments? Isn't it supposed to
+;; ;; though since it's a primitive? Yes, it is.
+;; (write-val (type-eq? (car (char 80)) (car (char 100)) 89 78))
+
+)
diff --git a/ev.scm b/ev.scm
new file mode 100644
index 0000000..e31ed16
--- /dev/null
+++ b/ev.scm
@@ -0,0 +1,740 @@
+;; Expands to variables prepended with enum name and a period (.). See
+;; enum 'err' for an example.
+(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-syntax define*
+ (syntax-rules ()
+ ((_ x)
+ (syntax-error "invalid define* form " x))
+ ((_ var val)
+ (define var val))
+ ((_ var val rest ...)
+ (begin (define var val)
+ (define* rest ...)))))
+
+;; nan: not a number
+;; nap: not a pair
+;; nar: not a record
+;; example: err.nan-add
+(enum err
+ ((nan-add 0)
+ (nan-sub 1)
+ (nan-mult 2)
+ (nan-quotient 3)
+ (nan-remainder 4)
+ (nap-car 5)
+ (nap-cdr 6)
+ (nap-set-car! 7)
+ (nap-set-cdr! 8)
+ (unknown-inst 9)
+ (bad-arg-count-apply 10)
+ (ran-out-of-fuel 11)
+ (nar-record-type 12)
+ (nar-record-value 13)
+ (nan-untag-number 14)
+ (primitive-not-found 15)
+ (operation-not-found 16)
+ (variable-not-found 17)
+ (type-not-found 18)
+ (oom 19)
+ (nap-record-type 20) ; for record objs
+ ))
+
+(define* pair-mask #b1111
+ pair-spec #b0000
+ number-mask #b1
+ number-spec #b1 ; also in tag-number define-records macro
+ record-mask #b10
+ record-spec #b10)
+
+;; NOTE! if word-size is not half of block-size update the algorithm
+;; in (cons).
+(define* *word-size* 8 ; bytes
+ *block-size* 16) ; bytes
+
+;;;;;;; PreScheme ;;;;;;;
+(cond-expand
+(prescheme
+(define* halt (external "PS_HALT" (=> () null))
+ vm-init (external "vm_init" (=> () null)))
+
+; also in tag-number define-records macro
+(define (twos-complement obj)
+ (if (>= obj 0)
+ (shift-left obj 1)
+ (shift-left (+ (bitwise-not (abs obj)) 1) 1)))
+
+; also in tag-number define-records macro
+(define* (tag-number obj) (bitwise-xor (twos-complement obj) number-spec)
+ (tag-record obj) (bitwise-xor (shift-left obj 2) record-spec)
+ (tag-nil) (tag-record (tag-number 0)) ; TODO check if prescheme inlines this
+ (nil) (tag-nil))
+
+(define (matches-spec? obj mask spec) (= (bitwise-and obj mask) spec))
+
+(define* (pair? obj) (matches-spec? obj pair-mask pair-spec)
+ (number? obj) (matches-spec? obj number-mask number-spec)
+ (record? obj) (matches-spec? obj record-mask record-spec)
+ (nil? obj) (= obj (tag-nil))) ; TODO make sure prescheme inlines
+
+(define (untag-number obj)
+ (if (>= obj 0)
+ (arithmetic-shift-right obj 1)
+ (- 0 (+ (arithmetic-shift-right (bitwise-not obj) 1) 1))))
+(define (untag-record obj) (arithmetic-shift-right obj 2))
+
+(define *error* 0)
+(define *error-obj* 999)
+
+(define-syntax assert
+ (syntax-rules ()
+ ((_ test good err-num print-obj err-val)
+ (if test good (begin (set! *error* err-num) (set! *error-obj* print-obj) err-val)))))
+
+(define (untag-number/chk n)
+ (assert (number? n) (untag-number n) err.nan-untag-number n 0))
+;; TODO check for overflows
+;; TODO this doesn't work for negative numbers!
+(define (twos-complement-add n n2)
+ (assert (and (number? n) (number? n2)) (+ n n2 -1) err.nan-add (list n n2) 0))
+
+(define (twos-complement-sub n n2)
+ (assert (and (number? n) (number? n2)) (+ (- n n2) 1) err.nan-sub (list n n2) 0))
+
+(define (mult n1 n2)
+ (assert (and (number? n1) (number? n2))
+ (tag-number (* (untag-number n1) (untag-number n1)))
+ err.nan-mult
+ (list n1 n2)
+ 0))
+
+(define (quotient/chk n1 n2)
+ (assert (and (number? n1) (number? n2))
+ (tag-number (quotient (untag-number n1) (untag-number n2)))
+ err.nan-quotient
+ (list n1 n2)
+ 0))
+(define (remainder/chk n1 n2)
+ (assert (and (number? n1) (number? n2))
+ (tag-number (remainder (untag-number n1) (untag-number n2)))
+ err.nan-remainder
+ (list n1 n2)
+ 0))
+
+;; (define (display-error n)
+;; (unsigned-byte-set! (integer->address 753664) 69)
+;; (unsigned-byte-set! (integer->address (+ 753664 2)) (+ n 48)))
+
+(define (display-error n obj)
+ (terminal:put-char #\E)
+ (terminal:put-number n)
+ (terminal:put-char #\<)
+ (print* obj)
+ (terminal:put-char #\>)
+ (terminal:put-char #\space))
+
+(define *alloc-address* null-address)
+(define *end-of-memory* 0)
+(define *oom-pair* 1) ; ??? 0 test as a "tagged" pair, so we aren't going with that
+
+;; cons overshoots *end-of-memory* by block size
+(define (cons a b)
+ (let ((start (address->integer *alloc-address*)))
+ (assert (< start *end-of-memory*)
+ (begin
+ (word-set! *alloc-address* a)
+ (word-set! (address+ *alloc-address* *word-size*) b)
+ (set! *alloc-address* (address+ *alloc-address* *block-size*))
+ start)
+ err.oom (tag-number -1) *oom-pair*)))
+
+(define (car pair)
+ (assert (pair? pair) (word-ref (integer->address pair)) err.nap-car pair (tag-nil)))
+(define (cdr pair)
+ (assert (pair? pair) (word-ref (address+ (integer->address pair) *word-size*))
+ err.nap-cdr pair (tag-nil)))
+
+(define (car/chk pair)
+ (assert (pair? pair) (word-ref (integer->address pair)) err.nap-car pair (tag-nil)))
+(define (cdr/chk pair)
+ (assert (pair? pair) (word-ref (address+ (integer->address pair) *word-size*))
+ err.nap-cdr pair (tag-nil)))
+
+(define (set-car! pair val)
+ (assert (pair? pair) (word-set! (integer->address pair) val)
+ ;; TODO find a better way to get prescheme to have the
+ ;; correct return value for the error condition.
+ err.nap-set-car! (list pair val) (word-set! (integer->address #xffff00) 0)))
+(define (set-cdr! pair val)
+ (assert (pair? pair) (word-set! (address+ (integer->address pair) *word-size*) val)
+ err.nap-set-cdr! (list pair val) (word-set! (integer->address #xffff00) 0)))
+
+(define (alloc bytes)
+ (let ((beginning-of-block (address->integer *alloc-address*)))
+ (set! *alloc-address*
+ (address+ *alloc-address*
+ (if (<= bytes *block-size*)
+ *block-size*
+ (+ bytes (- *block-size* (remainder bytes *block-size*))))))
+ beginning-of-block))
+
+(define (record-obj type val)
+ (cons (tag-record type) val))
+
+(define (record-obj? obj)
+ (and (pair? obj) (record? (car obj))))
+
+;; If OBJ is a pair that points to a record return its type.
+(define (record-obj-type obj)
+ (assert (pair? obj)
+ (let ((rec (car obj)))
+ (assert (record? rec) rec
+ err.nar-record-type rec 0))
+ err.nap-record-type obj 0))
+
+;; If OBJ is a pair that points to a record return its value.
+(define (record-obj-value obj)
+ (assert (pair? obj)
+ (assert (record? (car obj)) (cdr obj)
+ err.nar-record-value obj 0)
+ err.nap-record-type obj 0))
+
+(define null? nil?)
+
+(define-syntax list
+ (syntax-rules ()
+ ((_) (tag-nil))
+ ((_ element)
+ (cons element (tag-nil)))
+ ((_ element r)
+ (cons element (list r)))
+ ((_ element r ...)
+ (cons element (list r ...)))))
+
+(define (list-tail x k)
+ (if (= k 0)
+ x
+ (list-tail (cdr x) (- k 1))))
+
+(define (list-ref lis k)
+ (car (list-tail lis k)))
+
+(define (reverse lis)
+ (if (null? lis)
+ lis
+ (let loop ((remaining lis) (new-head (tag-nil)))
+ (if (pair? (cdr remaining))
+ (loop (cdr remaining)
+ (cons (car remaining) new-head))
+ (cons (car remaining) new-head)))))
+
+(define (cadr x) (car (cdr x))) (define (caddr x) (car (cdr (cdr x))))
+(define (cadddr x) (car (cdr (cdr (cdr x)))))
+(define (cddr x) (cdr (cdr x))) (define (cdddr x) (cdr (cdr (cdr x))))
+) ; end cond-expand prescheme
+
+
+(else ; cond-expand else
+
+(define (twos-complement obj)
+ (if (>= obj 0)
+ obj
+ (+ (bitwise-not (abs obj)) 1)))
+(define (tag-number obj)
+ (bitwise-xor (arithmetic-shift (twos-complement obj) 1) number-spec))
+(define (untag-number obj)
+ (if (>= obj 0)
+ (arithmetic-shift obj -1)
+ (- 0 (+ (arithmetic-shift (bitwise-not obj) -1) 1))))
+(define untag-number/chk untag-number)
+(define (twos-complement-add n n2)
+ (+ n n2 -1))
+(define (twos-complement-sub n n2)
+ (+ (- n n2) 1))
+
+(define quotient/chk quotient)
+(define remainder/chk remainder)
+
+;;; If you want easier debugging.
+;; (define (twos-complement-add n n2) (+ n n2))
+;; (define (twos-complement-sub n n2) (- n n2))
+;; (define (tag-number n) n)
+;; (define (untag-number n) n)
+(define (tag-nil) '())
+(define (nil) (tag-nil))
+(define nil? null?)
+(define-record-type record (tag-record value) record?
+ (value untag-record))
+
+(define-record-printer record
+ (lambda (obj port)
+ (print "#<record " (untag-record obj) ">")))
+
+(define (record-obj type val)
+ (cons (tag-record type) val))
+
+(define (record-obj? obj)
+ (and (pair? obj) (record? (car obj))))
+
+;; If OBJ is a pair that points to a record return its type.
+(define (record-obj-type obj)
+ (if (record-obj? obj)
+ (car obj)
+ (error "not a record obj")))
+
+;; If OBJ is a pair that points to a record return its value.
+(define (record-obj-value obj)
+ (if (record-obj? obj)
+ (cdr obj)
+ (error "not a record obj")))
+
+(define (word-set! addr val) (void))
+(define (unsigned-byte-set! addr val)
+ (display val) (void))
+(define (integer->address n) n)
+
+(define *error* 0)
+(define *error-obj* 999)
+(define (put-number n) (display n))
+(define (put-char c) (display c))
+
+(define (halt) '())
+(define (initialize) '())
+
+(define-syntax goto
+ (syntax-rules ()
+ ((_ body ...)
+ (begin (body ...)))))
+
+(define (display-error n obj)
+ (error (conc "VM error: " n "<" obj ">")))
+
+(define (mult n1 n2) (tag-number (* (untag-number n1) (untag-number n2))))
+
+)) ; end cond-expand
+
+(define-syntax define-records
+ (lambda (x r c)
+ ;; TODO move iota and conc in to another pre-scheme module and
+ ;; import for syntax
+ (define (iota k . start)
+ (define (iota* k i)
+ (if (< i k)
+ (cons i (iota* k (+ i 1)))
+ '()))
+ (let ((start (if (null? start) 0 (car start))))
+ (iota* (+ k start) start)))
+ (define (conc . r)
+ (apply string-append (map (lambda (x) (if (symbol? x) (symbol->string x) x)) r)))
+ (define (tag-number n)
+ (bitwise-xor (twos-complement n) #b1))
+ (define (twos-complement obj)
+ (if (>= obj 0)
+ (arithmetic-shift obj 1)
+ (arithmetic-shift (+ (bitwise-not (abs obj)) 1) 1)))
+ `(begin
+ ,@(map
+ (lambda (inst n)
+ (let* ((has-args (list? inst))
+ (name (if has-args (car inst) inst))
+ (args (if has-args (cdr inst) '())))
+ `(begin (,(r 'define) (,(string->symbol (conc 'make- name)) ,@args)
+ ,(if has-args
+ `(record-obj ,n (list ,@args))
+ `(tag-record ,n)))
+ ,(if has-args
+ `(,(r 'define) (,(string->symbol (string-append (symbol->string name) "-type?")) ,(r 'obj))
+ (,(r 'and) (record-obj? ,(r 'obj))
+ (,(r '=) (untag-record (record-obj-type ,(r 'obj))) ,n)))
+ `(,(r 'define) (,(string->symbol (string-append (symbol->string name) "-type?")) ,(r 'obj))
+ (,(r 'and) (record? ,(r 'obj))
+ (,(r '=) (untag-record ,(r 'obj)) ,n))))
+ ,@(if has-args
+ (map (lambda (arg slot)
+ `(,(r 'define) (,(string->symbol
+ (conc name '- arg))
+ ,(r 'obj))
+ (list-ref (record-obj-value ,(r 'obj)) ,slot)))
+ args (iota (length args)))
+ '()))))
+ (cdr x) (map tag-number (iota (length (cdr x)) 1)))))) ; start at 1, 0 is nil
+
+(define-records
+ variable ;; TODO not used?
+ quote
+ assign
+ call/cc
+ (symbol char-list)
+ type
+ value
+ tag
+ untag
+ eq?
+ nil
+ env
+ word-set!
+ word-ref
+ byte-set!
+ byte-ref
+ alloc
+ add
+ sub
+ mult
+ quotient
+ remainder
+ abs
+ cons
+ car
+ cdr
+ eval
+ ;; (macro proc)
+ (operative vars dyn-var has-dyn-var? proc static-env)
+ (applicative obj)
+ wrap
+ unwrap
+ set-car!
+ set-cdr!
+ primitive
+ apply
+ record
+ vau
+ type-eq?
+ )
+
+(cond-expand (prescheme 0) (else (define symbol-type? symbol?)))
+
+(define (list-of-values exps env)
+ (if (null? exps)
+ (nil)
+ (cons (ev (car exps) env)
+ (list-of-values (cdr exps) env))))
+
+(define (apply-primitive-proc proc args env)
+ ;; TODO check num args
+ ;; In process of converting from all primitives having all args
+ ;; being evaled to just some of them.
+ (cond ((add-type? proc) (twos-complement-add (ev (car args) env)
+ (ev (car (cdr args)) env)))
+ ((sub-type? proc) (twos-complement-sub (ev (car args) env)
+ (ev (car (cdr args)) env)))
+ ((car-type? proc) (car/chk (ev (car args) env)))
+ ((cdr-type? proc) (cdr/chk (ev (car args) env)))
+ ((env-type? proc) env)
+ ((eval-type? proc) (ev (car args) (ev (car (cdr args)) env)))
+ ;; ((list-of-values-type? proc))
+ ((cons-type? proc) (cons (ev (car args) env) (ev (car (cdr args)) env)))
+ ((nil-type? proc) (nil))
+ ((wrap-type? proc) (make-applicative (ev (car args) env)))
+ ;; TODO this doesn't even make sense. Someone could
+ ;; (tag-record -1) and then this would say it is a number!
+ ;; ((type-type? proc) (cond ((number? (car args)) (tag-number -1))
+ ;; ((record? (car args))
+ ;; (untag-record (car args)))
+ ;; ((nil? (car args)) (tag-number -2))
+ ;; ((pair? (car args)) (tag-number -3)) ; TODO possible?
+ ;; (else
+ ;; (assert #f -3 err.type-not-found (tag-number -99)))))
+ ((value-type? proc)
+ (let ((args (list-of-values args env)))
+ (cond ((record? (car args)) (untag-record (car args)))
+ ((or (number? (car args)) (pair? args))
+ (car args))
+ (else
+ (assert #f -3 err.type-not-found (car args) (tag-number -98))))))
+ ((record-type? proc) (tag-record (ev (car args) env)))
+ ;; ((tag-type? proc) (record (car args) (car (cdr args))))
+ ;; ((untag-type? proc) (cond ((number? (car args)) (car args))
+ ;; ((record? (car args)) (record-value (car args)))))
+ ;; ((set-car!-type? proc) (set-car! (car args) (car (cdr args))))
+ ((byte-set!-type? proc)
+ (unsigned-byte-set!
+ (integer->address (untag-number/chk (ev (car args) env)))
+ (untag-number/chk (ev (car (cdr args)) env)))
+ (tag-number 0))
+ ((eq?-type? proc)
+ (if (= (ev (car args) env) (ev (car (cdr args)) env))
+ (car (cdr (cdr args)))
+ (car (cdr (cdr (cdr args))))))
+ ((type-eq?-type? proc)
+ (let ((a (ev (car args) env))
+ (b (ev (cadr args) env)))
+ (cond ((and (pair? a) (pair? b))
+ (car (cdr (cdr args))))
+ ((and (record? a) (record? b)
+ (= (untag-record a) (untag-record b)))
+ (car (cdr (cdr args))))
+ ((= a b)
+ (car (cdr (cdr args))))
+ (else (car (cdr (cdr (cdr args))))))))
+ (else
+ args
+ ;; (assert #f #f err.primitive-not-found (tag-number 0))
+ ))
+ )
+
+(define (ev-sequence exps env)
+ (if (null? (cdr exps))
+ (ev (car exps) env)
+ (begin (ev (car exps) env)
+ (ev-sequence (cdr exps) env))))
+
+;; (define (ev-apply proc args env)
+;; (if (pair? proc)
+;; (ev-sequence (cdr (cdr proc)) (extend-environment (car (cdr proc)) args (car proc)))
+;; (apply-primitive-proc proc args env)))
+
+(define (ev-args args env)
+ (let loop ((args args) (res (nil)))
+ (if (null? args)
+ (reverse res) ;; TODO store applicative and/or operative args
+ ;; in reverse so we don't have to do a reverse here
+ (loop (cdr args) (cons (ev (car args) env) res)))))
+
+(define (empty-list seed)
+ (let loop ((acc (nil)) (seed seed))
+ (if (null? seed) acc (loop (cons (nil) acc) (cdr seed)))))
+
+(define (make-frame variables values)
+ (cons variables values))
+(define (frame-variables frame) (car frame))
+(define (frame-values frame) (cdr frame))
+(define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+(define (assignment? op) (assign-type? op))
+(define (assignment-variable exp) (car (cdr exp)))
+(define (assignment-value exp) (car (cdr (cdr exp))))
+
+(define (self-evaluating? exp)
+ (or (number? exp) (nil? exp) (operative-type? exp) (applicative-type? exp)
+ (and (not (symbol-type? exp)) (record? exp))))
+
+(define (extend-environment vars vals base-env)
+ (cons (make-frame vars vals) base-env))
+
+(define (find-variable var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop (cdr env)))
+ ((eq? var (car vars))
+ (values vals #t))
+ (else (scan (cdr vars) (cdr vals)))))
+ (if (null? env)
+ (values var #f)
+ (let ((frame (car env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+(define (lookup-variable-value var env)
+ (receive (vals found) (find-variable var env)
+ (if found
+ (car vals)
+ (begin
+ ;; (display-error var)
+ (display-error err.variable-not-found var)
+ err.variable-not-found))))
+
+(define (set-variable-value! var val env)
+ (receive (vals found) (find-variable var env)
+ (if found
+ (set-car! vals val)
+ (add-binding-to-frame! var val (car env)))
+ (nil)))
+
+(define-syntax guard
+ (syntax-rules (*error*)
+ ((_ body ...)
+ (if (= *error* 0)
+ (begin body ...)
+ (begin
+ (display-error *error* *error-obj*)
+ (tag-number 999))))))
+
+(define (extend-operative-environment op x e)
+ (let* ((not-list-arg (pair? (car (operative-vars op))))
+ (operative-var-list
+ (if not-list-arg
+ (operative-vars op)
+ (list (operative-vars op))))
+ (vals (if not-list-arg (cdr x) (list (cdr x)))))
+ (if (= (operative-has-dyn-var? op) 1)
+ (extend-environment (cons (operative-dyn-var op)
+ operative-var-list)
+ (cons e vals)
+ (operative-static-env op))
+ (extend-environment operative-var-list
+ vals
+ (operative-static-env op)))))
+
+(define (construct-operative x e)
+ (if (nil? (cdr (car x)))
+ (make-operative (car (car x)) (nil) 0 (cdr x) e)
+ ;; Include dynamic environment.
+ (make-operative (car (car x)) (car (cdr (car x))) 1 (cdr x) e)))
+
+(define (ev x e)
+ (guard
+ (cond ((self-evaluating? x) x)
+ ((symbol-type? x) (lookup-variable-value x e))
+ (else
+ (let ((op (ev (car x) e)))
+ (guard
+ (cond ((assignment? op)
+ (set-variable-value! (car (cdr x)) (ev (car (cdr (cdr x))) e) e))
+ ((operative-type? op)
+ (ev-sequence
+ (operative-proc op)
+ (extend-operative-environment op x e)))
+ ((applicative-type? op)
+ (ev (cons (applicative-obj op) (ev-args (cdr x) e)) e))
+ ((vau-type? op)
+ (construct-operative (cdr x) e))
+ (else (apply-primitive-proc op (cdr x) e)))))))))
+
+;; (define *prim-env*
+;; (extend-environment
+;; '(+ ev vau eval wrap set! nil cons env)
+;; `(,(make-add)
+;; ,(make-eval)
+;; ,(make-vau)
+;; ,(make-eval)
+;; ,(make-wrap)
+;; ,(make-assign)
+;; ,(make-nil)
+;; ,(make-cons)
+;; ,(make-env))
+;; (nil)))
+
+;; (ev '((vau (elements) elements) 1 2 3)
+;; *prim-env*)
+
+;; ;; (ev '(set! quote* (vau ((x)) x))
+;; ;; *prim-env*)
+;; ;; (ev '(quote* xyz)
+;; ;; *prim-env*)
+
+(cond-expand (prescheme 0)
+(else
+(define (precompile-sexp x)
+ (cond ((number? x) (tag-number x))
+ ((symbol? x)
+ (make-symbol
+ (map (compose tag-number char->integer)
+ (string->list (symbol->string x)))))))
+(precompile-sexp 'set!)))
+
+(define *env* #x220000)
+;; (define *oblist* #x220010)
+(define *exps* #x220008)
+
+(define s-add 0)
+(define s-set! 0)
+(define s-x 0)
+
+(define (print-debug-table start words)
+ (let loop ((i 0))
+ (if (< i words)
+ (begin (terminal:put-number (+ start (* i 8)))
+ (terminal:put-char #\:)
+ (terminal:put-char #\space)
+ (terminal:put-number
+ (word-ref (integer->address (+ start (* i 8)))))
+ (terminal:put-char #\newline)
+ (loop (+ i 1))))))
+
+(define (print* obj)
+ (cond ((number? obj)
+ (terminal:put-number (untag-number obj)))
+ ((symbol-type? obj)
+ (let loop ((o (symbol-char-list obj)))
+ (terminal:put-char (ascii->char (untag-number (car/chk o))))
+ (if (not (nil? (cdr o)))
+ (loop (cdr/chk o)))))
+ ((record? obj)
+ (terminal:put-char #\#)
+ (terminal:put-char #\<)
+ (terminal:put-number (untag-number (untag-record obj)))
+ (terminal:put-char #\>))
+ ((pair? obj)
+ ;; must not be in a function or prescheme could make it in to
+ ;; a dependency loop
+ (terminal:put-char #\()
+ (let loop ((o obj))
+ (print* (car o))
+ (if (not (nil? (cdr o)))
+ (begin (terminal:put-char #\space)
+ (if (pair? (cdr o))
+ (loop (cdr o))
+ (begin (terminal:put-char #\.)
+ (terminal:put-char #\space)
+ (print* (cdr o)))))))
+ (terminal:put-char #\)))
+ ((nil? obj)
+ (terminal:put-char #\()
+ (terminal:put-char #\)))
+ (else (terminal:put-char #\E))))
+
+(define (run-ev)
+ (set! *alloc-address* (integer->address #x300000))
+ ;; a single pair will be consed after this location
+ (set! *end-of-memory* #x1000000) ; 32 MiB
+ (set! *oom-pair* (cons (make-nil) (make-nil)))
+
+
+ (set! *env* (word-ref (integer->address *env*)))
+ (set! *exps* (word-ref (integer->address *exps*)))
+
+ (let loop ((exps (car *exps*)))
+ (if (null? (cdr exps))
+ (ev (car exps) *env*)
+ (begin (ev (car exps) *env*)
+ (loop (cdr exps)))))
+
+)
+
+(define (keyboard-handler key)
+ (+ key 0))
+
+(define (kmain)
+ ;; see note in prescheme.h
+ (vm-init)
+ ;; (init)
+
+ (terminal:initialize)
+
+
+ (run-ev)
+ (let loop ()
+ (halt)
+ (loop))
+ )
+
+;; NOTE!
+;; dynamic variable binding can be accomplished by looking up a
+;; variable in the dynamic environment instead of the lexical
+;; environment that was stored when the procedure was created.
+;; if one wants a variable to be dynamic scoped for calls later on it
+;; can bind a variable in the static environment to the one in the
+;; dynamic environment.
+
+;; (define bar `(,(env) (x) (baz x)))
+;; (bar (lookup-variable x (current-env))) ; x is dynamic for the
+;; ; duration of the execution of
+;; ; bar's body
+
+;; NOTE! is it possible to do tail-recursion with the current
+;; evaluator if the code in the tail position is always evaluated in
+;; its own loop?
diff --git a/heap-writer.scm b/heap-writer.scm
new file mode 100644
index 0000000..7904501
--- /dev/null
+++ b/heap-writer.scm
@@ -0,0 +1,93 @@
+(import chicken scheme ports data-structures)
+(use srfi-1 extras posix)
+
+(include "ev.scm")
+
+
+(define (symbol->num-list sym)
+ (map char->integer (string->list (symbol->string sym))))
+
+(define (write-val v)
+ (let loop ((v v) (acc '()))
+ (if (= v 0)
+ (for-each write-byte
+ (reverse
+ ;; NOTE assumes little endian
+ (append (make-list (- *word-size* (length acc)) 0) acc)))
+ (loop (quotient v 256) (cons (remainder v 256) acc)))))
+
+
+(define a (if (feature? 'debug)
+ 0
+ #x220000))
+(if (= a 0)
+ (begin (newline) (print "!!!!!! heap-writer DEBUG MODE !!!!!") (newline)))
+
+(define (write-cons obj1 obj2)
+ (let ((start a))
+ (write-val obj1)
+ (write-val obj2)
+ (set! a (+ a 16))
+ start))
+
+(define *oblist* '())
+(define (make-heap obj)
+ (define (tag-record obj) (bitwise-xor (arithmetic-shift obj 2) record-spec))
+ (define symbol-tag (tag-record (untag-record (record-obj-type (make-symbol '())))))
+ (define (tag-nil) (tag-record (tag-number 0)))
+ (define (has-symbol? sym)
+ (alist-ref sym *oblist*))
+ (define (push-oblist-symbol sym loc)
+ (set! *oblist* (cons (cons sym loc) *oblist*)))
+ (define (oblist-symbol-record sym)
+ (alist-ref sym *oblist*))
+ ;; (define (tag-number n) n)
+ (define (loop obj)
+ (cond ((number? obj)
+ (tag-number obj))
+ ((nil? obj)
+ (tag-nil))
+ ((record? obj)
+ (tag-record (untag-record obj)))
+ ((record-obj? obj)
+ (write-cons (tag-record (untag-record (record-obj-type obj)))
+ (loop (record-obj-value obj))))
+ ((symbol? obj)
+ (if (has-symbol? obj)
+ (oblist-symbol-record obj)
+ (let ((rec (write-cons symbol-tag
+ (write-cons (loop (symbol->num-list obj))
+ (tag-nil)))))
+ (push-oblist-symbol obj rec)
+ rec)))
+ ((pair? obj)
+ (write-cons (loop (car obj)) (loop (cdr obj))))
+ (else (error "unknown"))))
+ (loop obj))
+
+(with-output-to-file (if (feature? 'debug) "heap-debug.bin" "heap.bin")
+ (lambda ()
+ ;; (set! a 0)
+ ;; (set! *oblist* '())
+ ;; lets call the stuff at the beginning "the header"
+ ;; could also include the tip of the oblist (and make the oblist
+ ;; an actual list of its own) Also, make the header real big for
+ ;; future binary compatibility so more things can be added to it
+ ;; without causing old images to become invalid
+ ;; also make the values in the headers offsets and have ev.scm
+ ;; calculate the actual location that way the heap can be moved to
+ ;; places in memory without having to recompile
+ ;; ALSO add to header the end of the heap so that *alloc-address*
+ ;; can be set to it when run-ev starts
+ (write-val 0) ; written over for env start address
+ (write-val 0) ; written over for exps start address
+ (set! a (+ a 16))
+ (make-heap (eval (car (read-file "ev-environment.scm"))))
+ (let ((fp (file-position (current-output-port))))
+ (set-file-position! (current-output-port) 0)
+ (write-val (- a 16))
+ (set-file-position! (current-output-port) fp))
+ (make-heap (read-file "ev-runtime.scm"))
+ (set-file-position! (current-output-port) 8)
+ (write-val (- a 16))
+ ))
diff --git a/packages.scm b/packages.scm
new file mode 100644
index 0000000..69a008a
--- /dev/null
+++ b/packages.scm
@@ -0,0 +1,18 @@
+(define-structure vm
+ (export kmain keyboard-handler
+ )
+ (open prescheme ps-memory ps-receive ps-macros (modify terminal (prefix terminal:)))
+ (for-syntax (open scheme bitwise))
+ (files ev))
+
+(define-structure ps-macros
+ (export cond-expand)
+ (open prescheme)
+ (files ps-macros))
+
+(define-structure terminal
+ (export initialize put-number put-char)
+ (open prescheme ps-memory)
+ (files terminal))
+
+
diff --git a/ps-macros.scm b/ps-macros.scm
new file mode 100644
index 0000000..8b0c6dc
--- /dev/null
+++ b/ps-macros.scm
@@ -0,0 +1,4 @@
+(define-syntax cond-expand
+ (syntax-rules (prescheme)
+ ((_ (prescheme body ...) rest ...)
+ (begin body ...))))
diff --git a/terminal.scm b/terminal.scm
new file mode 100644
index 0000000..1e62171
--- /dev/null
+++ b/terminal.scm
@@ -0,0 +1,120 @@
+(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)))))))
+
+