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