Initial commit.
commit
b09b9283cd
@ -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
|
||||
|
||||
@ -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))
|
||||
@ -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))
|
||||
|
||||
)
|
||||
@ -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?
|
||||
@ -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))
|
||||
))
|
||||
@ -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))
|
||||
|
||||
|
||||
@ -0,0 +1,4 @@
|
||||
(define-syntax cond-expand
|
||||
(syntax-rules (prescheme)
|
||||
((_ (prescheme body ...) rest ...)
|
||||
(begin body ...))))
|
||||
@ -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)))))))
|
||||
|
||||
|
||||
Loading…
Reference in New Issue