3l/ev.scm

;; 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?