eval.l

;;; -*- coke -*-

(define-form gcdebug prog ())
;;(define-form gcdebug prog `(let () ,@prog))

(define-form debug prog ())
;;(define-form debug prog `(let () ,@prog))

(define-form safe prog ())
;;(define-form safe prog `(let () ,@prog))

; Allocated structures in maru are kept in a singly linked circular list of chunks. Each chunk has a <header>, and
; may or may not contain a structure. When an empty chunk is filled with a new structure, if there is excess unused
; space in the chunk, the chunk is split and the second half is inserted in the linked list immediately after
; the first half. At initialization, the linked list is a singleton of a ~64k empty chunk.
; <header>:
;   size - number of bytes in the chunk, not including the <header>
;   flags - see below, starting with <header>-flags-used
;   next - pointer to the next chunk. The last chunk points back to the first chunk.
;   type - accessor is unused, but space is reserved so that storing the type at oop -1 will not clobber anything
(define-structure <header> (size flags next type))

; String buffer.
;   contents - pointer to malloc'd region, which doubles in size everytime more space is needed
;   size - number of bytes in malloc'd region; starts out as 32, remains a power of 2 as buffer grows
;   position - number of characters in buffer
(define-structure <buffer> (contents size position))

(define-function make-gc-protectors (vars)
  (map (lambda (v) (list 'gc_push_root (list 'address-of v)))
       vars))

(define-function make-gc-unprotectors (vars)
  (let ((result ()))
    (while (pair? vars)
      (set result (cons (list 'gc_pop_root (list 'address-of (car vars))) result))
      (set vars (cdr vars)))
    result))

(define-form gc-protect (vars . prog)
  `(let ()
     ,@(make-gc-protectors vars)
     (let ((__answer__ ,@prog))
       ,@(make-gc-unprotectors vars)
       __answer__)))

(define-function make-gc-let* (inits prog)
  (if (pair? inits)
      `((let (,(car inits)) (gc-protect (,(caar inits)) ,@(make-gc-let* (cdr inits) prog))))
    prog))

(define-form gc-let* (inits . prog) (car (make-gc-let* inits prog)))

(compile-begin)

; oh man, this just got real.
; I think I'm finally starting to get it.
; When (compile-end) is reached, maru will traverse its own environment, and dump its top-level
; definitions into assembly (eval.s). Here, (extern) merely produces a tiny wrapper (of type <extern>) around
; the symbol (e.g. 'strlen), but when this definition is compiled by emit.l into assembly, it will output

;	.section __IMPORT,__pointers,non_lazy_symbol_pointers
;   _strlen_24stub:
; 	.indirect_symbol _strlen
; 	.long 0
; 	.text

; so the object file produced by the assembly can be linked with the libc primitives. Thus, when Maru generates itself,
; the copy cannot rely in anyway on the original boot-eval.c. That is why, for instance, subr_print must be redefined below, so
; that it depends only on externs like 'putc and not on the original implementation.
(define abort	(extern	'abort))
(define exit	(extern	'exit))
(define malloc	(extern	'malloc))
(define free	(extern	'free))
(define memset	(extern	'memset))
(define memcpy	(extern	'memcpy))
(define printf	(extern	'printf))
(define fprintf	(extern	'frintf))
(define sprintf	(extern	'sprintf))

(define stderr			0)

(define gc_quantum		65504); size to request from OS when need more space; not sure why this is 32 bytes "short"
(define gc_frequency		65536); pre-emptive collection triggered when gc_alloc_count = this number

; these three stat trackers are for debugging messages only; they are each assigned after every sweep
(define gc_objects_live		0)
(define gc_bytes_used		0)
(define gc_bytes_free		0)

(define gc_roots		0); pointer to a malloc'd "array" (not an <array>) where gc roots are kept
(define gc_root_count		0); size of (C-style) array
(define gc_root_max		0); supposed to be powers of two (standard realloc pattern for vectors) but I think it's buggy

(define gc_memory_base		0); pointer to first chunk
(define gc_memory_last		0); pointer to last allocation block
(define gc_alloc_count		0); number of allocations since the last garbage collection; can trigger pre-emptive collection if reaches gc_frequency
(define gc_collection_count	0)

(define-form size-of-structure (type)	(* 4 (array-at %structure-sizes (eval type))))

(define-form <header>-flags-used ()	1); whether chunk contains a structure
(define-form <header>-flags-atom ()	2); an (unused?) optimization, to avoid traversing chunks (in mark phase) that have no children
(define-form <header>-flags-mark ()	4); set during mark, cleared during sweep

(define-form <header>-flags-used+atom ()	(+ (<header>-flags-used) (<header>-flags-atom)))

(define-function max (a b)	(if (> a b) a b))

(define trace_stack	0)
(define trace_depth	0)

(define-function die ()
  (let ((i trace_depth))
    (while (<= 0 (set i (- i 1)))
      (printf "%3d: " i)
      (k_dumpln (k_array_at trace_stack i))))
  (exit 1))

(define-function fatal (reason)		(printf "\neval.k: %s\n" reason) (exit 1))

(define-function fatal1 (fmt arg)	(printf "\neval.k: ") (printf fmt arg)		(printf "\n") (die))
(define-function fatal2 (fmt arg brg)	(printf "\neval.k: ") (printf fmt arg brg)	(printf "\n") (die))

(define-form k_error args
  `(let ()
     (printf "\neval.k: error: ")
     ,@(map (lambda (arg) (list (if (string? arg) 'printf 'k_print) arg)) args)
     (printf "\n")
     (die)))

(define-function new_memory_block (size)
  (let ((ptr (malloc size)))
    (or ptr (fatal "out of memory"))
    (set (<header>-size  ptr) (- size (size-of-structure <header>)))
    (set (<header>-flags ptr) 0)
    (set (<header>-next  ptr) ptr)
    (debug (printf "BRK %p %d %d/%d\n" ptr size gc_alloc_count gc_frequency))
    ptr))

(define-function gc_initialise ()
  (let ((ptr (new_memory_block gc_quantum)))
    (set gc_memory_base ptr)
    (set gc_memory_last ptr)))

; this might be buggy. 'max 32' means you can never have more than 32 roots at a time
; but gc_push_root never returns failure. If the max is reached, new roots will continue to be
; added past the region of allocated memory.
; there also seems to be another bug: gc_root_max starts out zero. double zero is still zero. So
; in fact all roots are kept in unallocated memory?
(define-function gc_push_root (ptr)
  (and (= gc_root_count gc_root_max)
       (let* ((roots (malloc (* 4 (set gc_root_max (max 32 (* 2 gc_root_max)))))))
	 (memcpy roots gc_roots (* 4 gc_root_count))
	 (and gc_roots (free gc_roots))
	 (set gc_roots roots)))
  (set-oop-at gc_roots gc_root_count ptr)
  (debug (printf "gc add root %d at %p\n" gc_root_count ptr))
  (set gc_root_count (+ 1 gc_root_count)))

(define-function gc_pop_root (ptr)
  (or gc_root_count (fatal "root table underflow"))
  (set gc_root_count (- gc_root_count 1))
  (debug (printf "gc del root %d at %p %s\n" gc_root_count ptr))
  (or (= ptr (oop-at gc_roots gc_root_count)) (fatal "non-lifo root")))

(define-function gc_grow_memory (size)
  (let ((brk (new_memory_block size)))
    (set (<header>-next brk) (<header>-next gc_memory_last))
    (set (<header>-next gc_memory_last) brk)))

(define-function gc_size (obj)	(<header>-size (- obj (size-of-structure <header>))))

(define-function gc_malloc_atomic (size)
  (let* ((obj (gc_malloc size)))
    (set (<header>-flags (- obj (size-of-structure <header>))) (<header>-flags-used+atom)); mark as used and childless
    obj))

(define-function gc_malloc (size)
  (set size (& -4 (+ 3 size)))
  (and (= gc_alloc_count gc_frequency) (gc_gcollect))
  (let* ((first (<header>-next gc_memory_last))
	 (chunk first)
	 (ssize (+ size (size-of-structure <header>))))
    (while 1
      (while
	(let ()
	  (debug (printf "alloc? %d %p %p [%p] %d >= %d %d\n" (<header>-flags chunk) chunk (<header>-next chunk) first (<header>-size chunk) size (<= size (<header>-size chunk))))
	  (if (= 0 (<header>-flags chunk)); if chunk is empty
	      (let ((csize (<header>-size chunk)))
                ; if there are additional empty chunks immediately after this one, and they are adjacent in memory, skip forward to the last of them
		(while (and (= 0 (<header>-flags (<header>-next chunk)))
			    (= (<header>-next chunk) (+ chunk (+ (size-of-structure <header>) csize))))
		  (let ((next (<header>-next chunk)))
		    (set (<header>-next chunk) (<header>-next next))
		    (set csize (set (<header>-size chunk) (+ csize (+ (size-of-structure <header>) (<header>-size next)))))
		    (and (= next gc_memory_last) (set gc_memory_last chunk))))
		(if (or (< ssize csize) (= size csize)); and if chunk is large enough to hold new structure
		    (let ()
		      (debug (printf "csize %d\n" csize))
		      (and (> csize ssize) ; always true??
			   (let ((split (+ chunk ssize)))
			     (debug (printf "split %d: %p + %d -> %p + %d\n" csize chunk size split (- csize (+ size (size-of-structure <header>)))))
			     (set (<header>-size  split) (- csize (+ size (size-of-structure <header>))))
			     (set (<header>-flags split) 0)
			     (set (<header>-next  split) (<header>-next chunk))
			     (set (<header>-size  chunk) size)
			     (set (<header>-next  chunk) split)
			     (set csize size)))
		      (set (<header>-flags chunk) (<header>-flags-used))
		      (set gc_memory_last chunk)
		      (debug (printf "alloc chunk %p\n" chunk))
		      (let ((obj (+ chunk (size-of-structure <header>))))
			(memset obj 0 csize)
			(set gc_alloc_count (+ gc_alloc_count 1))
			(return obj))))))
	  (!= first (set chunk (<header>-next chunk)))))
      (gc_grow_memory (max (+ (size-of-structure <header>) size) gc_quantum)))))

(define-function gc_sweep ()
  (debug (printf "sweep\n"))
  (let ((ptr gc_memory_base)
	(nobjs 0)
	(nused 0)
	(nfree 0))
    (while ptr
      (debug (printf "sweep? %d %p + %d\n" (<header>-flags ptr) ptr (<header>-size ptr)))
      (let ((flags (<header>-flags ptr)))
	(if (& flags (<header>-flags-mark))
	    (let ()
	      (set nused (+ nused (<header>-size ptr)))
	      (set nobjs (+ nobjs 1))
	      (set (<header>-flags ptr) (^ flags (<header>-flags-mark))))
	  (debug (printf "collect %p %d\n" ptr (<header>-size ptr)))
	  (set nfree (+ nfree (<header>-size ptr)))
	  (set (<header>-flags ptr) 0)))
      (and (= gc_memory_base (set ptr (<header>-next ptr)))
	   (set ptr 0)))
    (set gc_objects_live nobjs)
    (set gc_bytes_used nused)
    (set gc_bytes_free nfree)
    (debug (printf "GC: %d used, %d free, %d allocations\n" nused nfree gc_alloc_count))
    ;;(and (< nfree nused) (gc_grow_memory gc_quantum))
    ))

(define-function gc_mark_and_trace (obj)
  (and obj
       (not (& 1 obj))
       (let* ((ptr   (- obj (size-of-structure <header>)))
	      (flags (<header>-flags ptr)))
	 (debug (printf "mark and trace %p flags %d\n" obj flags))
	 (safe (or (& (<header>-flags-used) flags) (fatal1 "attempt to mark dead object %p" ptr)))
	 (or (& flags (<header>-flags-mark))
	     (let ()
	       (set (<header>-flags ptr) (| flags (<header>-flags-mark)))
	       (or (& flags (<header>-flags-atom))
		   (let ((size (>> (<header>-size ptr) 2)))
		     (debug (printf "mark %p %d type %d\n" ptr size (<header>-type ptr)))
		     (while size
		       (set size (- size 1))
		       (debug (printf "@%d %p\n" size (oop-at obj size)))
		       (gc_mark_and_trace (oop-at obj size))))))))))

(define-function gc_gcollect ()
  (gcdebug
    (or (& 1023 (set gc_collection_count (+ gc_collection_count 1)))
	(fprintf stderr "%d collections\n" gc_collection_count 1)))
  (let ((i 0))
    (while (< i gc_root_count)
      (debug (let ((ptr (oop-at gc_roots i))) (printf "mark gc root %d : %p -> %p\n" i ptr (oop-at ptr 0))))
      (gc_mark_and_trace (oop-at (oop-at gc_roots i) 0))
      (set i (+ 1 i))))
  (gc_sweep)
  (set gc_alloc_count 0))

;;; ----------------------------------------------------------------

(define strlen	(extern 'strlen))
(define strcmp	(extern 'strcmp))
(define strdup	(extern 'strdup))
(define strtoul	(extern 'strtoul))
(define getc	(extern 'getc))
(define putc	(extern 'putc))
(define ungetc	(extern 'ungetc))
(define fopen	(extern 'fopen))
(define fdopen	(extern 'fdopen))
(define fclose	(extern 'fclose))
(define fflush	(extern 'fflush))
(define fscanf	(extern 'fscanf))

(define EOF	-1)

; todo: come back and annotate each of these (including the section below, for symbols, globals, etc.
; for just this section, describe each type's evaluator and applicator
(define <undefined>	 0)
(define <long>		 1)
(define <string>	 2)
(define <symbol>	 3)
(define <pair>		 4)
(define <_array>	 5)
(define <array>		 6); pointer to an _array
(define <expr>		 7)
(define <form>		 8)
(define <fixed>		 9)
(define <subr>		10)

(define symbols			0); points to the head of the cons list of (intern'd) <symbol>s
(define globals			0); points to the head of the association list for the global environment
(define expanders		0)
(define encoders		0)
(define evaluators		0)
(define applicators		0)
(define s_t			0)
(define s_dot			0)
(define s_set			0)
(define s_lambda		0)
(define s_let			0)
(define s_quote			0)
(define s_quasiquote		0)
(define s_unquote		0)
(define s_unquote_splicing	0)
(define s_expanders		0)
(define s_encoders		0)
(define s_evaluators		0)
(define s_applicators		0)
(define f_set			0)
(define f_quote			0)
(define f_lambda		0)
(define f_let			0)

(define opt_verbose		0)

; Even though Ted Kaehler wanted to get rid of idst vtables and replace them with object tables,
; I guess Piumarta still thinks keeping things at address -1 is a good idea. (I have no opinion myself.)
(define-function new-bits (type size)
  (let ((obj (gc_malloc_atomic size)))
    (set (oop-at obj -1) type)
    obj))

(define-function new-oops (type size)
  (let ((obj (gc_malloc size)))
    (set (oop-at obj -1) type)
    obj))

(define-function new-<long> (bits)
  (let ((obj (new-bits <long> (size-of-structure <long>))))
    (set (<long>-_bits obj) bits)
    obj))

(define-function _new-<string> (len)
  (let ((str (new-oops <string> (size-of-structure <string>))))
    (gc-protect (str)
      (set (<string>-size  str) (new-<long> len))
      (set (<string>-_bits str) (gc_malloc_atomic (+ len 1)))
      str)))

(define-function new-<string> (cstr)
  (let ((len (strlen cstr)))
    (let ((obj (_new-<string> len)))
      (memcpy (<string>-_bits obj) cstr len)
      obj)))

(define-function new-<symbol> (cstr)
  (let ((obj (new-bits <symbol> (size-of-structure <symbol>))))
    (set (<symbol>-_bits obj) (strdup cstr))
    obj))

(define-function new-<pair> (head tail)
  (let ((obj (new-oops <pair> (size-of-structure <pair>))))
    (set (<pair>-head obj) head)
    (set (<pair>-tail obj) tail)
    obj))

(define-function new-<array> (size)
  (let ((arr (new-oops <array> (size-of-structure <array>))))
    (gc-protect (arr)
      (set (<array>-_array arr) (new-oops <_array> (* 4 size)))
      arr)))

(define-function new-<expr> (defn env)
  (let ((obj (new-oops <expr> (size-of-structure <expr>))))
    (set (<expr>-defn obj) defn)
    (set (<expr>-env  obj) env )
    obj))

(define-function new-<form> (fn)
  (let ((obj (new-oops <form> (size-of-structure <form>))))
    (gc-protect (obj)
      (set (<form>-function obj) fn)
      obj)))

; some of these gc-protects look like they are unnecessary, and so are maybe here only just to be future proof,
; e.g. if (set ...) were modified in a way that added an allocation, the protect would be necessary
(define-function new-<fixed> (fn)
  (let ((obj (new-oops <fixed> (size-of-structure <fixed>))))
    (gc-protect (obj)
      (set (<fixed>-function obj) fn)
      obj)))

(define-function new-<subr> (_imp _name)
  (let ((obj (new-bits <subr> (size-of-structure <subr>))))
    (gc-protect (obj)
      (set (<subr>-_imp  obj) _imp )
      (set (<subr>-_name obj) _name)
      obj)))

(define-form is (type arg)
  `(let ((__arg__ ,arg))
     (and __arg__
	  (not (& 1 __arg__))
	  (= ,type (oop-at __arg__ -1)))))

(define-form get-type (arg)
  `(let ((__arg__ ,arg))
     (safe (and __arg__ (or (& (<header>-flags-used) (<header>-flags (- __arg__ (size-of-structure <header>)))) (fatal1 "attempt to access dead object %p type %d" __arg__))))
     (if __arg__
	 (oop-at __arg__ -1)
       <undefined>)))

(define-function type_check_fail (exp act)
  (fatal2 "illegal type: expected %d got %d" exp act))

(define-form get (type field object)
  `(let ((__obj__ ,object))
     (safe (let ((t (get-type __obj__))) (or (= ,type t) (type_check_fail ,type t))))
     (,(concat-symbol (concat-symbol type '-) field) __obj__)))

(define-form put (type field object value)
  `(let ((__obj__ ,object))
     (safe (let ((t (get-type __obj__))) (or (= ,type t) (type_check_fail ,type t))))
     (set (,(concat-symbol (concat-symbol type '-) field) __obj__) ,value)))

(define-form get_long (obj)	`(oop-at ,obj 0))

(define-form get_head (obj)	`(oop-at ,obj 0))
(define-form get_tail (obj)	`(oop-at ,obj 1))
(define-form set_tail (obj val)	`(set-oop-at ,obj 1 ,val))

(define-function is_blank (c)	(or 	 ( = ?   c)			; sp
				    	 ( = ?\t c)			; ht
				    	 ( = ?\n c)			; nl
				    	 ( = ?\v c)			; vt
				    	 ( = ?\f c)			; ff
				    	 ( = ?\r c)))			; cr

(define-function is_digit10 (c)	    (and (<= ?0  c) (<= c ?9)))		; 0 1 2 3 4 5 6 7 8 9

(define-function is_digit16 (c)	(or (and (<= ?0  c) (<= c ?9))		; 0 1 2 3 4 5 6 7 8 9
				    (and (<= ?a  c) (<= c ?f))		; a b c d e f
				    (and (<= ?A  c) (<= c ?F))))	; A B C D E F

(define-function is_alpha (c)	(or (and (<= ?a  c) (<= c ?z))		; a b c d e f g h i j k l m n o p q r s t u v w x y z
				    (and (<= ?A  c) (<= c ?Z))))	; A B C D E F G H I J K L M N O P Q R S T U V W X Y Z

(define-function is_letter (c)	(or      ( = ?!  c)			; !
				    (and (<= ?#  c) (<= c ?&))		; # $ % &
				    (and (<= ?*  c) (<= c ?/))		; * + , - . /
					 ( = ?:  c)			; :
				    (and (<= ?<  c) (<= c ?Z))		; < = > ?  @ A B C D E F G H I J K L M N O P Q R S T U V W X Y Z
					 ( = ?\\ c)			; \
					 ( = ?^  c)			; ^
					 ( = ?_  c)			; _
				    (and (<= ?a  c) (<= c ?z))		; a b c d e f g h i j k l m n o p q r s t u v w x y z
					 ( = ?|  c)			; |
					 ( = ?~  c)))			; ~

(define-function new_buffer ()
  (let ((buf (malloc (size-of-structure <buffer>))))
    (set (<buffer>-contents buf) (malloc 32))
    (set (<buffer>-size     buf) 32)
    (set (<buffer>-position buf) 0)
    buf))

(define-function buffer_delete (buf)
  (free (<buffer>-contents buf))
  (free buf))

(define-function buffer_grow (buf)
  (let* ((size     (<buffer>-size buf))
	 (contents (malloc (* 2 size))))
    (memcpy contents (<buffer>-contents buf) size)
    (free (<buffer>-contents buf))
    (set (<buffer>-contents buf) contents)
    (set (<buffer>-size buf) (* 2 size))))

(define-function buffer_append (buf c)
  (and (= (<buffer>-position buf) (<buffer>-size buf))
       (buffer_grow buf))
  (let ((posn (<buffer>-position buf)))
    (set-string-at (<buffer>-contents buf) posn c)
    (set (<buffer>-position buf) (+ 1 posn))))

(define-function buffer_append_all (buf s)
  (let ((i 0)
	(c 0))
    (while (set c (string-at s i))
      (buffer_append buf c)
      (set i (+ 1 i)))))

(define-function buffer_contents (buf)
  (buffer_append buf 0)
  (set (<buffer>-position buf) (- (<buffer>-position buf) 1))
  (<buffer>-contents buf))

(define-function intern (cstr)
  (let ((list symbols))
    (while (is <pair> list)
      (let ((sym (get_head list)))
	(or (strcmp cstr (get <symbol> _bits sym))
	    (return sym)))
      (set list (get_tail list))))
  (let ((sym (new-<symbol> cstr)))
    (gc-protect (sym)
      (set symbols (new-<pair> sym symbols))
      sym)))

(define-function is_octal (c)		(and (<= ?0 c) (<= c ?7)))

(define-function is_hexadecimal (c)	(or (and (<= ?0 c) (<= c ?9))
					    (and (<= ?a c) (<= c ?f))
					    (and (<= ?A c) (<= c ?F))))

(define-function digit_value (c)
  (cond
    ((and (<= ?0 c) (<= c ?9))	(- c ?0))
    ((and (<= ?a c) (<= c ?z))	(- c (- ?a 10)))
    ((and (<= ?A c) (<= c ?Z))	(- c (- ?A 10)))
    (else			(fatal "illegal digit in character escape"))))

(define-function read_char (c stream)
  (if (= ?\\ c)
      (let ()
	(set c (getc stream))
	(cond
	  ((= c ?a)			?\a)
	  ((= c ?b)			?\b)
	  ((= c ?f)			?\f)
	  ((= c ?n)			?\n)
	  ((= c ?r)			?\r)
	  ((= c ?t)			?\t)
	  ((= c ?v)			?\v)
	  ((= c ?u)			(let ((a (getc stream))
					      (b (getc stream))
					      (c (getc stream))
					      (d (getc stream)))
					  (+ (<< (digit_value a) 24)
					     (+ (<< (digit_value b) 16)
						(+ (<< (digit_value c)  8)
						   (digit_value d)    )))))
	  ((= c ?x)			(let ((x 0))
					  (if (is_hexadecimal (set c (getc stream)))
					      (let ()
						(set x (digit_value c))
						(if (is_hexadecimal (set c (getc stream)))
						    (let ()
						      (set x (+ (* x 16) (digit_value c)))
						      (set c (getc stream))))))
					  (ungetc c stream)
					  x))
	  ((and (<= ?0 c) (<= c ?7))	(let ((x (digit_value c)))
					  (if (is_octal (set c (getc stream)))
					      (let ()
						(set x (+ (* x 8) (digit_value c)))
						(if (is_octal (set c (getc stream)))
						    (let ()
						      (set x (+ (* x 8) (digit_value c)))
						      (set c (getc stream))))))
					  (ungetc c stream)
					  x))
	  (else			(if (or (is_alpha c) (is_digit10 c))
				    (fatal1 "illegal character escape: \\%c" c)
				  c))))
    c))

(define-function read_number (c stream)
  (let ((buf (new_buffer))
	(neg (= ?- c)))
    (or neg (buffer_append buf c))
    (while (is_digit10 (set c (getc stream))) (buffer_append buf c))
    (and (= ?x c) (= 1 (<buffer>-position buf))
	 (let ()
	   (buffer_append buf c)
	   (while (is_digit16 (set c (getc stream))) (buffer_append buf c))))
    (ungetc c stream)
    (buffer_append buf 0)
    (let ((result (strtoul (<buffer>-contents buf) 0 0)))
      (buffer_delete buf)
      (new-<long> (if neg (- result) result)))))

(define-function read_symbol (c stream)
  (let ((buf (new_buffer)))
    (while (or (is_letter c) (is_digit10 c))
      (buffer_append buf c)
      (set c (getc stream)))
    (ungetc c stream)
    (buffer_append buf 0)
    (let ((result (intern (<buffer>-contents buf))))
      (buffer_delete buf)
      result)))

(define-function read_string (c stream)
  (let ((buf (new_buffer)))
    (while (!= ?\" (set c (getc stream)))
      (set c (read_char c stream))
      (and (= EOF c) (fatal "unterminated string literal"))
      (buffer_append buf c))
    (buffer_append buf 0)
    (let ((result (new-<string> (<buffer>-contents buf))))
      (buffer_delete buf)
      result)))

(define-function read_list (delim stream)
  (let* ((head (new-<pair> () ()))
	 (tail head)
	 (elt  ()))
    (gc-protect (head elt)
      (while (and (!= EOF (set elt (k_read stream))) (!= s_dot elt))
	(set elt (new-<pair> elt ()))
	(set tail (set_tail tail elt)))
      (and (= s_dot elt) (set_tail tail (k_read stream))))
    (let ((c (getc stream)))
      (if (= delim c)
	  (get_tail head)
	(fatal1 "missing closing '%c' delimiter while reading list" delim)))))

(define-function read_quote (prefix stream)
  (let ((qobj (k_read stream)))
    (and (= EOF qobj) (fatal "EOF while reading quoted literal"))
    (gc-protect (qobj)
      (set qobj (new-<pair> qobj ()))
      (set qobj (new-<pair> prefix qobj))
      qobj)))

(define-function k_read (stream)
  (while 1
    (let ((c (getc stream)))
      (cond
	((is_blank c)	())
	((= ?? c)	(return (new-<long> (read_char (getc stream) stream))))
	((= ?- c)	(return (if (is_digit10 (ungetc (getc stream) stream))
				    (read_number c stream)
				    (read_symbol c stream))))
	((= ?\' c)	(return (read_quote s_quote stream)))
	((= ?\` c)	(return (read_quote s_quasiquote stream)))
	((= ?\, c)	(return (let ((d (getc stream)))
				  (if (= ?@ d)
				      (read_quote s_unquote_splicing stream)
				    (ungetc d stream)
				    (read_quote s_unquote)))))
	((is_letter c)	(return (read_symbol c stream)))
	((= ?\( c)	(return (read_list ?\) stream)))	((= ?\) c)	(return (let () (ungetc c stream) EOF)))
	((= ?\[ c)	(return (read_list ?\] stream)))	((= ?\] c)	(return (let () (ungetc c stream) EOF)))
	((= ?\{ c)	(return (read_list ?\} stream)))	((= ?\} c)	(return (let () (ungetc c stream) EOF)))
	((is_digit10 c)	(return (read_number c stream)))
	((= ?\; c)	(while (and (!= ?\n (set c (getc stream)))
				    (!= ?\r c)
				    (!= EOF c))))
	((= ?\" c)	(return (read_string c stream)))
	((< c 0)	(return EOF))
	(else		(fatal1 "illegal character: %c" c))))))

(define-function do_print (obj storing)
  (debug (printf "{%p}" obj))
  (let ((type (get-type obj)))
    (cond
      ((= type <undefined>)	(printf "nil"))
      ((= type <long>)		(printf "%d" (get <long> _bits obj)))
      ((= type <string>)	(let ((bits (get <string> _bits obj)))
				  (if (not storing)
				      (printf "%s" bits)
				    (let ((i 0)
					  (c 0))
				      (printf "\"")
				      (while (set c (string-at bits i))
					(if (and (<= 32 c) (<= c 126))
					    (cond
					      ((= c ?\")	(printf "\\\""))
					      ((= c ?\\)	(printf "\\\\"))
					      (else		(printf "%c" c)))
					  (printf "\\%03o" c))
					(set i (+ 1 i)))
				      (printf "\"")))))
      ((= type <symbol>)	(printf "%s" (get <symbol> _bits obj)))
      ((= type <pair>)		(let ()
				  (printf "(")
				  (while (and (is <pair> obj) (!= globals obj))
				    (do_print (get_head obj) storing)
				    (and (is <pair> (set obj (get_tail obj))) (printf " ")))
				  (if (= globals obj)
				      (printf "<globals>")
				    (and obj
					 (let ()
					   (printf " . ")
					   (do_print obj storing))))
				  (printf ")")))
      ((= type <array>)		(let ((len (k_array_length obj)))
				  (printf "Array(")
				  (for (i 0 len)
				    (and i (printf " "))
				    (do_print (k_array_at obj i)))
				  (printf ")")))
      ((= type <expr>)		(let ()
				  (printf "Expr(")
				  (do_print (k_car (get <expr> defn obj)) storing)
				  (printf ")")))
      ((= type <form>)		(let ()
				  (printf "Form(")
				  (do_print (get <form> function obj) storing)
				  (printf ")")))
      ((= type <fixed>)		(let ()
				  (printf "Fixed(")
				  (do_print (get <fixed> function obj) storing)
				  (printf ")")))
      ((= type <subr>)		(printf "Subr(%s)" (get <subr> _name obj)))
      (else			(printf "<type:%d>" type)))))

(define-function k_print (obj) (do_print obj 0))	(define-function k_println (obj) (do_print obj 0) (printf "\n"))
(define-function k_dump  (obj) (do_print obj 1))	(define-function k_dumpln  (obj) (do_print obj 1) (printf "\n"))

;;; ----------------------------------------------------------------

(define-function k_define (name value env)
  (let ((ass (new-<pair> name value)))
    (gc-protect (ass)
      (let ((ent (new-<pair> ass (get_tail env))))
	(set_tail env ent)
	ass))))

(define-function k_assq (key list)
  (while (is <pair> list)
    (let ((head (get_head list)))
      (and (is <pair> head)
	   (= key (get_head head))
	   (return head)))
    (set list (get_tail list))))

(define-function k_car (list)	(and (is <pair> list) (get_head list)))
(define-function k_cdr (list)	(and (is <pair> list) (get_tail list)))

(define-function k_caar (list)	(k_car (k_car list)))
(define-function k_cadr (list)	(k_car (k_cdr list)))
(define-function k_cddr (list)	(k_cdr (k_cdr list)))

(define-function k_caddr (list)	(k_car (k_cdr (k_cdr list))))

(define-function k_string_length (obj)	(get_long (get <string> size obj)))

(define-function k_array_length (obj)
  (and (is <array> obj)
       (let ((_arr (get <array> _array obj)))
	 (let ((sz (/ (gc_size _arr) 4)))
	   sz))))

(define-function k_array_at (obj idx)
  (and (is <array> obj)
       (let* ((elts (get <array> _array obj))
	      (size (/ (gc_size elts) 4)))
	 (and (<= 0 idx) (< idx size)
	      (oop-at elts idx)))))

(define-function k_set_array_at (obj idx val)
  (and (is <array> obj)
       (let* ((elts (get <array> _array obj))
	      (size (/ (gc_size elts) 4)))
	 (and (<= 0 idx)
	      (let ()
		(or (< idx size)
		    (let* ((nsize (max (+ idx 1) (* size 2)))
			   (oops  (new-oops <_array> (* 4 nsize))))
		      (memcpy oops elts (* size 4))
		      (set elts (put <array> _array obj oops))))
		(set-oop-at elts idx val))))))

(define-function k_concat (head tail)
  (if (is <pair> head)
      (let ()
	(set tail (k_concat (get_tail head) tail))
	(gc-protect (tail)
	  (new-<pair> (get_head head) tail)))
    tail))

;;; ----------------------------------------------------------------

(define-function exlist (list env)
  (if (is <pair> list)
      (let ((head (k_expand (get_head list) env)))
	(gc-protect (head)
	  (let ((tail (exlist (get_tail list) env)))
	    (gc-protect (tail)
	      (new-<pair> head tail)))))
    list))

(define-function k_expand (exp env)
  (if (is <pair> exp)
      (let ((head (k_expand (get_head exp) env)))
	(gc_push_root (address-of head))
	(if (is <symbol> head)
	    (let ((val (k_cdr (k_assq head env))))
	      (if (is <form> val)
		  (let ()
		    (set head (k_apply (get <form> function val) (get_tail exp) env))
		    (set head (k_expand head env))
		    (gc_pop_root (address-of head))
		    (return head)))))
	(let ((tail (get_tail exp)))
	  (gc_push_root (address-of tail))
	  (or (= head s_quote) (set tail (exlist tail env)))
	  (and (= s_set head)
	       (is <pair>   (k_car  tail))
	       (is <symbol> (k_caar tail))
	       (let ((buf (new_buffer)))
		 (buffer_append_all buf "set-")
		 (buffer_append_all buf (get <symbol> _bits (get_head (get_head tail))))
		 (set head (intern (buffer_contents buf)))
		 (set tail (k_concat (get_tail (get_head tail)) (get_tail tail)))))
	  (set exp (new-<pair> head tail))
	  (gc_pop_root (address-of tail))
	  (gc_pop_root (address-of head))))
    (let ((fn (k_array_at (get_tail expanders) (get-type exp))))
      (and fn
	   (let ((args (new-<pair> exp ())))
	     (gc-protect (args)
	       (set exp (k_apply fn args env)))))))
  exp)

(define-function enlist (list env)
  (if (is <pair> list)
      (let ((head (k_encode (get_head list) env)))
	(gc-protect (head)
	  (let ((tail (enlist (get_tail list) env)))
	    (gc-protect (tail)
	      (new-<pair> head tail)))))
    list))

(define-function k_encode (exp env)
  (if (is <pair> exp)
      (let ((head (k_encode (get_head exp) env))
	    (tail (get_tail exp)))
	(gc-protect (head tail)
	  (if (is <symbol> head)
	      (let ((val (k_cdr (k_assq head env))))
		(and (or (is <fixed> val) (is <subr> val))
		     (set head val))))
	  (cond
	    ((= head f_let)		(let ((args (k_cadr exp))
					      (tmp  ()))
					  (gc-protect (env tmp)
					    (while (is <pair> args)
					      (let ((var (get_head args)))
						(and (is <pair> var) (set var (get_head var)))
						(set tmp (new-<pair> var ()))
						(set env (new-<pair> tmp env))
						(set args (get_tail args))))
					    (set tail (enlist tail env)))))
	    ((= head f_lambda)		(let ((args (k_cadr exp))
					      (tmp  ()))
					  (gc-protect (env tmp)
					    (while (is <pair> args)
					      (set tmp (new-<pair> (get_head args) ()))
					      (set env (new-<pair> tmp env))
					      (set args (get_tail args)))
					    (and args
						 (let ()
						   (set tmp (new-<pair> args ()))
						   (set env (new-<pair> tmp env))))
					    (set tail (enlist tail env)))))
	    ((!= head f_quote)		(set tail (enlist tail env))))
	  (set exp (new-<pair> head tail))))
    (let ((fn (k_array_at (get_tail encoders) (get-type exp))))
      (and fn (let () (printf "APPLY GOT ENCODER\n... " (k_println fn) 1)))
      (and fn
	   (let ((args (new-<pair> env ())))
	     (gc-protect (args)
	       (set args (new-<pair> exp args))
	       (printf "APPLY ENCODER\n... ") (k_print fn) (printf " ") (k_print args) (printf " ") (k_println env)
	       (set exp (k_apply fn args env)))))))
  exp)

(define-function k_eval (exp env)
  (let ((ev (k_array_at (get_tail evaluators) (get-type exp))))
    (and ev
	 (let ((args (new-<pair> exp ())))
	   (gc-protect (args)
	     (k_set_array_at trace_stack trace_depth exp)
	     (set trace_depth (+ trace_depth 1))
	     (set exp (k_apply ev args env))
	     (set trace_depth (- trace_depth 1)))))
    exp))

(define-function k_apply (fun arguments env)
  (if (is <subr> fun)
      ((get <subr> _imp fun) arguments env)
    (let ((ap (k_array_at (get_tail applicators) (get-type fun))))
      (if ap
	  (let ((args arguments))
	    (gc-protect (args)
			(set args (new-<pair> fun args))
			(k_apply ap args env)))
	(k_error "cannot apply: " fun)))))

(define-function subr_define (args env)
  (let ((sym (k_car args)))
    (or (is <symbol> sym) (k_error "non-symbol identifier in define: "sym))
    (let ((val (k_eval (k_cadr args) env)))
      (gc-protect (val)
        (k_define sym val globals)
	val))))

(define-function subr_lambda (args env)
  (new-<expr> args env))

(define-function subr_let (args env)
  (let ((env2     env)
	(tmp      ())
	(bindings (k_car args))
	(body     (k_cdr args)))
    (gc-protect (env2 tmp)
      (while (is <pair> bindings)
	(let ((binding (get_head bindings)))
	  (if (is <pair> binding)
	      (let ((sym  (get_head binding))
		    (prog (get_tail binding)))
		(while (is <pair> prog)
		  (set tmp (k_eval (get_head prog) env))
		  (set prog (get_tail prog)))
		(set tmp  (new-<pair> sym tmp))
		(set env2 (new-<pair> tmp env2)))))
	(set bindings (get_tail bindings)))
      (set tmp ())
      (while (is <pair> body)
	(set tmp (k_eval (get_head body) env2))
	(set body (get_tail body)))
     tmp)))  

(define-function subr_set (args env)
  (let ((var (k_assq (k_car args) env)))
    (or (is <pair> var) (k_error "undefined variable: (set "args")"))
    (set_tail var (k_eval (k_cadr args) env))))

(define-function subr_while (args env)
  (let ((tst  (k_car args))
	(prog args))
    (while (k_eval tst env)
      (let ((body prog))
	(while (is <pair> (set body (k_cdr body)))
	  (k_eval (get_head body) env))))))

(define-function subr_if (args env)
  (if (k_eval (k_car args) env)
      (k_eval (k_cadr args) env)
    (let ((ans ()))
      (set args (k_cdr args))
      (while (is <pair> (set args (k_cdr args)))
	(set ans (k_eval (get_head args) env)))
      ans)))

(define-function subr_or (args env)
  (let ((ans ()))
    (while (is <pair> args)
      (and (set ans (k_eval (get_head args) env))
	   (return ans))
      (set args (get_tail args)))))

(define-function subr_and (args env)
  (let ((ans s_t))
    (while (is <pair> args)
      (or (set ans (k_eval (get_head args) env))
	  (return ()))
      (set args (get_tail args)))
    ans))

(define-function subr_quote (args env)
  (k_car args))

(define-function subr_not (args env)
  (if (k_car args) () s_t))

(define-function arity2 (op args)
  (or (and (is <pair> args)
	   (is <pair> (get_tail args))
	   (= () (get_tail (get_tail args))))
      (fatal1 "%s: expected 2 arguments" op)))

(define-function arity3 (op args)
  (or (and (is <pair> args)
	   (is <pair> (get_tail args))
	   (is <pair> (get_tail (get_tail args)))
	   (= () (get_tail (get_tail (get_tail args)))))
      (fatal1 "%s: expected 3 arguments" op)))

(define-function subr_sub (args env)
  (or args (fatal "-: expected 1 or 2 arguments"))
  (let ((lhs (get_head args))
	(rhs (get_tail args)))
    (if (and (is <pair> rhs))
	(let ()
	  (set rhs (get_head rhs))
	  (if (and (is <long> lhs) (is <long> rhs))
	      (new-<long> (- (get_long lhs) (get_long rhs)))
	    (k_error "non-numeric argument: (- "lhs" "rhs")")))
      (if (and (is <long> lhs))
	  (new-<long> (- (get_long lhs)))
	(k_error "non-numeric argument: (- "lhs")")))))

(define-form define-binary (op name)
  `(define-function ,(concat-symbol 'subr_ (string->symbol name)) (args env)
     (arity2 ,name args)
     (let ((lhs (get_head args))
	   (rhs (get_head (get_tail args))))
       (if (and (is <long> lhs) (is <long> rhs))
	   (new-<long> (,op (get_long lhs) (get_long rhs)))
	 (k_error "non-numeric argument: (",name" "lhs" "rhs")")))))

(define-binary &  "bitand")
(define-binary |  "bitor")
(define-binary ^  "bitxor")
(define-binary +  "add")
(define-binary *  "mul")
(define-binary /  "div")
(define-binary << "shl")
(define-binary >> "shr")

(define-form define-relation (op name)
  `(define-function ,(concat-symbol 'subr_ (string->symbol name)) (args env)
     (arity2 ,name args)
     (let ((lhs (get_head args))
	   (rhs (get_head (get_tail args))))
       (if (and (is <long> lhs) (is <long> rhs))
	   (and (,op (get_long lhs) (get_long rhs)) s_t)
	 (k_error "non-numeric argument: (",name" "lhs" "rhs")")))))

(define-relation <  "lt")
(define-relation <= "le")
(define-relation >  "gt")

(define-function subr_eq (args env)
  (arity2 "=" args)
  (let* ((lhs  (get_head args))
	 (rhs  (get_head (get_tail args)))
	 (type (get-type lhs)))
    (cond
      ((= type <long>)		(and (is <long> rhs) (= (get_long lhs) (get_long rhs)) s_t))
      ((= type <string>)	(and (is <string> rhs) (not (strcmp (get <string> _bits lhs) (get <string> _bits rhs))) s_t))
      (else			(and (= lhs rhs) s_t)))))

(define-function subr_ne (args env)
  (arity2 "!=" args)
  (let* ((lhs  (get_head args))
	 (rhs  (get_head (get_tail args)))
	 (type (get-type lhs)))
    (cond
      ((= type <long>)		(and (is <long> rhs) (!= (get_long lhs) (get_long rhs)) s_t))
      ((= type <string>)	(and (is <string> rhs) (strcmp (get <string> _bits lhs) (get <string> _bits rhs))) s_t)
      (else			(and (!= lhs rhs) s_t)))))

(define-function subr_abort (args env)
  (abort))

(define-function subr_exit (args env)
  (let ((status (and (is <long> (k_car args)) (get_long (k_car args)))))
    (exit status)))

(define-function subr_dump (args env)
  (while (is <pair> args)
    (k_dump (get_head args))
    (set args (get_tail args))))

(define-function subr_print (args env)
  (while (is <pair> args)
    (k_print (get_head args))
    (set args (get_tail args))))

(define-function subr_warn (args env)
  (while (is <pair> args)
    (let* ((arg  (get_head args))
	   (type (get-type arg)))
      (cond
	((= type <string>) (fprintf stderr "%s" (get <string> _bits arg)))
	((= type <symbol>) (fprintf stderr "%s" (get <symbol> _bits arg)))))
    (set args (get_tail args))))

(define-function subr_apply_expr (args env)
  (let ((fun (k_car args)))
    (and (is <expr> fun)
	 (let ()
	   (let* ((arguments (k_cdr args))
		  (argl      arguments)
		  (defn      (get <expr> defn fun))
		  (formals   (k_car defn))
		  (tmp       ()))
	     (set env (get <expr> env fun))
	     (gc-protect (defn env tmp)
	       (while (is <pair> formals)
		 (or (is <pair> argl) (k_error "too few arguments: ("fun" "arguments")"))
		 (set tmp     (new-<pair> (get_head formals) (get_head argl)))
		 (set env     (new-<pair> tmp env))
		 (set formals (get_tail formals))
		 (set argl    (get_tail argl)))
	       (and (is <symbol> formals)
		    (let ()
		      (set tmp (new-<pair> formals argl))
		      (set env (new-<pair> tmp env))
		      (set argl ())))
	       (and argl (k_error "too many arguments: ("fun" "arguments")"))
	       (set defn (get_tail defn))
	       (while (is <pair> defn)
		 (set argl (k_eval (get_head defn) env))
		 (set defn (get_tail defn)))
	       argl))))))

(define-function subr_apply_fixed (args env)
  (let ((fun  (k_car args))
	(argl (k_cdr args)))
    (and (is <fixed> fun)
	 (k_apply (get <fixed> function fun) argl env))))

(define-function subr_apply (args env)
  (k_apply (k_car args) (k_cadr args) (or (k_caddr args) env)))

(define-function subr_eval_symbol (args env)
  (let ((exp (k_car args))
	(val (k_assq exp env)))
    (or (is <pair> val) (fatal1 "undefined variable: %s" (if (is <symbol> exp) (get <symbol> _bits exp) "(non-<symbol>)")))
    (get_tail val)))

(define-function evlist (obj env)
  (if (is <pair> obj)
      (let ((head (k_eval (get_head obj) env)))
	(gc-protect (head)
	  (let ((tail (evlist (get_tail obj) env)))
	    (gc-protect (tail)
	      (new-<pair> head tail)))))
    obj))

(define-function subr_eval_pair (args env)
  (let ((exp  (k_car args))
	(head (k_eval (k_car exp) env)))
    (gc-protect (head)
      (k_set_array_at trace_stack trace_depth exp)
      (set trace_depth (+ trace_depth 1))
      (set head (if (is <fixed> head)
		    (k_apply (get <fixed> function head) (get_tail exp) env)
		  (let ((args (evlist (get_tail exp) env)))
		    (gc-protect (args)
		      (k_apply head args env)))))
      (set trace_depth (- trace_depth 1))
      head)))

(define-function subr_eval (args env)
  (let ((x (k_car args))
	(e (or (k_cadr args) env)))
    (gc-protect (x)
      (set x (k_expand x e))
      (set x (k_encode x e))
      (k_eval x e))))

(define-function subr_cons	(args env)	(new-<pair> (k_car args) (k_cadr args)))
(define-function subr_string	(args env)	(_new-<string> (and (is <long> (k_car args)) (get_long (get_head args)))))
(define-function subr_array	(args env)	(new-<array> (and (is <long> (k_car args)) (get_long (get_head args)))))
(define-function subr_form	(args env)	(new-<form> (k_car args)))

(define-function subr_allocate (args env)
  (arity2 "allocate" args)
  (let ((type (get_head args))
	(size (get_head (get_tail args))))
    (and (is <long> type) (is <long> size)
	 (new-oops (get_long type) (* (get_long size) 4)))))

(define-function subr_type_of	(args env)	(and args (new-<long> (get-type (k_car args)))))
(define-function subr_stringP	(args env)	(and (is <string> (k_car args)) s_t))
(define-function subr_symbolP	(args env)	(and (is <symbol> (k_car args)) s_t))
(define-function subr_pairP	(args env)	(and (is <pair> (k_car args)) s_t))
(define-function subr_arrayP	(args env)	(and (is <array> (k_car args)) s_t))
(define-function subr_car	(args env)	(k_car (k_car args)))
(define-function subr_cdr	(args env)	(k_cdr (k_car args)))

(define-function subr_oop_at (args env)
  (arity2 "oop-at" args)
  (let ((obj (get_head args))
	(arg (get_head (get_tail args))))
    (and (is <long> arg)
	 (oop-at obj (get_long arg)))))

(define-function subr_set_oop_at (args env)
  (arity3 "set-oop-at" args)
  (let ((obj (get_head args))
	(arg (get_head (get_tail args)))
	(val (get_head (get_tail (get_tail args)))))
    (and (is <long> arg)
	 (set-oop-at obj (get_long arg) val))))

(define-function subr_array_length (args env)
  (new-<long> (k_array_length (k_car args))))

(define-function subr_array_at (args env)
  (arity2 "array-at" args)
  (let ((arr (get_head args))
	(arg (get_head (get_tail args))))
    (and (is <long> arg)
	 (k_array_at arr (get_long arg)))))

(define-function subr_set_array_at (args env)
  (arity3 "set-array-at" args)
  (let ((arr (get_head args))
	(arg (get_head (get_tail args)))
	(val (get_head (get_tail (get_tail args)))))
    (and (is <long> arg)
	 (k_set_array_at arr (get_long arg) val))))

(define-function subr_string_length (args env)
  (let ((arg (k_car args)))
    (and (is <string> arg)
	 (get <string> size arg))))

(define-function subr_string_at (args env)
  (arity2 "string-at" args)
  (let ((arr (get_head args))
	(arg (get_head (get_tail args))))
    (and (is <long> arg)
	 (let ((idx (get_long arg)))
	   (and (<= 0 idx) (< idx (k_string_length arr))
		(new-<long> (string-at (get <string> _bits arr) idx)))))))

(define-function subr_set_string_at (args env)
  (arity3 "set-string-at" args)
  (let ((arr (get_head args))
	(arg (get_head (get_tail args)))
	(val (get_head (get_tail (get_tail args)))))
    (and (is <long> arg) (is <long> val)
	 (let ((idx (get_long arg)))
	   (and (<= 0 idx) (< idx (k_string_length arr))
		(let ()
		  (set-string-at (get <string> _bits arr) idx (get_long val))
		  val))))))

(define-function subr_string_symbol (args env)
  (let ((arg (k_car args)))
    (if (is <symbol> arg)
	arg
      (and (is <string> arg)
	   (intern (get <string> _bits arg))))))

(define-function subr_symbol_string (args env)
  (let ((arg (k_car args)))
    (if (is <string> arg)
	arg
      (and (is <symbol> arg)
	   (new-<string> (get <symbol> _bits arg))))))

(define-function subr_long_string (args env)
  (let ((arg (k_car args)))
    (if (is <string> arg)
	arg
      (and (is <long> arg)
	   (let ((buf (malloc 32)))
	     (sprintf buf "%ld" (get_long arg))
	     (let ((result (new-<string> buf)))
	       (free buf)
	       result))))))

; clever. but in maru-2.4 <env> became a type in its own right, so maybe it was too clever?
(define-function subr_current_environment (args env)
  env)

;;; ----------------------------------------------------------------

(define-function repl_stream (stream)
  (let ((res 0))
    (fscanf stream "#!%*[^\012\015]")
    (while (!= EOF (set res (k_read stream)))
      (gc-protect (res)
	(and (> opt_verbose 0) (printf ";;; ") (k_dumpln res))
	(set res (k_expand res globals))	(and (> opt_verbose 2) (printf "expd--> ") (k_dumpln res))
	(set res (k_encode res globals))	(and (> opt_verbose 2) (printf "encd--> ") (k_dumpln res))
	(set res (k_eval   res globals))	(and (> opt_verbose 1) (printf "eval--> ") (k_dumpln res))
	))))

(define-function define-subr (name imp)
  (let ((tmp (new-<subr> imp name)))
    (gc-protect (tmp)
      (k_define (intern name) tmp globals))))

(define-function define-fsubr (name imp)
  (let ((tmp (new-<subr> imp name)))
    (gc-protect (tmp)
      (set tmp (new-<fixed> tmp))
      (k_define (intern name) tmp globals))))

(define-function main (argc argv)
  (set stderr (fdopen 2 "a"))

  (gc_initialise)		(gcdebug (set gc_frequency 1))

  (gc_push_root (address-of symbols))

  (set s_t			(intern "t"))
  (set s_dot			(intern "."))
  (set s_set			(intern "set"))
  (set s_lambda			(intern "lambda"))
  (set s_let			(intern "let"))
  (set s_quote			(intern "quote"))
  (set s_quasiquote		(intern "quasiquote"))
  (set s_unquote		(intern "unquote"))
  (set s_unquote_splicing	(intern "unquote-splicing"))

  (gc_push_root (address-of globals    ))
  (gc_push_root (address-of expanders  ))
  (gc_push_root (address-of encoders   ))
  (gc_push_root (address-of evaluators ))
  (gc_push_root (address-of applicators))

  (let ((tmp (new-<pair> (intern "*globals*") globals)))
    (gc-protect (tmp)
      (set globals (new-<pair> tmp globals))
      (set_tail tmp globals)
      (set tmp (new-<array> 0))  (set expanders   (k_define (intern "*expanders*"  ) tmp globals))
      (set tmp (new-<array> 0))  (set encoders    (k_define (intern "*encoders*"   ) tmp globals))
      (set tmp (new-<array> 0))  (set evaluators  (k_define (intern "*evaluators*" ) tmp globals))
      (set tmp (new-<array> 0))  (set applicators (k_define (intern "*applicators*") tmp globals))
      (k_set_array_at (get_tail evaluators)  <symbol> (new-<subr> subr_eval_symbol "eval-<symbol>"))
      (k_set_array_at (get_tail evaluators)  <pair>   (new-<subr> subr_eval_pair   "eval-<pair>"  ))
      (k_set_array_at (get_tail applicators) <fixed>  (new-<subr> subr_apply_fixed "apply-<fixed>"))
      (k_set_array_at (get_tail applicators) <expr>   (new-<subr> subr_apply_expr  "apply-<expr>" ))
      ))

  (define-fsubr "define"		subr_define)
  (define-fsubr "lambda"		subr_lambda)
  (define-fsubr "let"			subr_let)
  (define-fsubr "set"			subr_set)
  (define-fsubr "while"			subr_while)
  (define-fsubr "if"			subr_if)
  (define-fsubr "or"			subr_or)
  (define-fsubr "and"			subr_and)
  (define-fsubr "quote"			subr_quote)
  (define-subr  "not"			subr_not)
  (define-subr  "&"			subr_bitand)
  (define-subr  "|"			subr_bitor)
  (define-subr  "^"			subr_bitxor)
  (define-subr  "+"			subr_add)
  (define-subr  "-"			subr_sub)
  (define-subr  "*"			subr_mul)
  (define-subr  "/"			subr_div)
  (define-subr  "<<"			subr_shl)
  (define-subr  ">>"			subr_shr)
  (define-subr  "<"			subr_lt)
  (define-subr  "<="			subr_le)
  (define-subr  "!="			subr_ne)
  (define-subr  "="			subr_eq)
  (define-subr  ">"			subr_gt)
  (define-subr  "abort"			subr_abort)
  (define-subr  "exit"			subr_exit)
  (define-subr  "dump"			subr_dump)
  (define-subr  "print"			subr_print)
  (define-subr  "warn"			subr_warn)
  (define-subr  "apply"			subr_apply)
  (define-subr  "eval"			subr_eval)
  (define-subr  "cons"			subr_cons)
  (define-subr  "string"		subr_string)
  (define-subr  "array"			subr_array)
  (define-subr  "form"			subr_form)
  (define-subr  "allocate"		subr_allocate)
  (define-subr  "type-of"		subr_type_of)
  (define-subr  "string?"		subr_stringP)
  (define-subr  "symbol?"		subr_symbolP)
  (define-subr  "pair?"			subr_pairP)
  (define-subr  "array?"		subr_arrayP)
  (define-subr  "car"			subr_car)
  (define-subr  "cdr"			subr_cdr)
  (define-subr  "oop-at"		subr_oop_at)
  (define-subr  "set-oop-at"		subr_set_oop_at)
  (define-subr  "array-length"		subr_array_length)
  (define-subr  "array-at"		subr_array_at)
  (define-subr  "set-array-at"		subr_set_array_at)
  (define-subr  "string-length"		subr_string_length)
  (define-subr  "string-at"		subr_string_at)
  (define-subr  "set-string-at"		subr_set_string_at)
  (define-subr  "string->symbol"	subr_string_symbol)
  (define-subr  "symbol->string"	subr_symbol_string)
  (define-subr  "long->string"		subr_long_string)
  (define-subr  "current-environment"	subr_current_environment)

  (set f_set	(k_cdr (k_assq s_set	globals)))		(gc_push_root (address-of f_set   ))
  (set f_quote	(k_cdr (k_assq s_quote	globals)))		(gc_push_root (address-of f_quote ))
  (set f_lambda	(k_cdr (k_assq s_lambda	globals)))		(gc_push_root (address-of f_lambda))
  (set f_let	(k_cdr (k_assq s_let	globals)))		(gc_push_root (address-of f_let	  ))

  (set trace_stack (new-<array> 32))				(gc_push_root (address-of trace_stack))

  (while (set argc (- argc 1))
    (set argv (+ argv 4))
    (let ((arg (oop-at argv 0)))
      (cond
	((not (strcmp arg "-v"))	(set opt_verbose (+ 1 opt_verbose)))
	(else				(let ((stream (fopen (oop-at argv 0) "r")))
					  (or stream (fatal1 "no such file: %s" (oop-at argv 0)))
					  (repl_stream stream)
					  (fclose stream))))))
  (and (> opt_verbose 0)
       (let ()
	 (gc_gcollect)
	 (printf "GC: %d objects in %d bytes, %d free\n" gc_objects_live gc_bytes_used gc_bytes_free)))

  (fprintf stderr "%d objects in %d bytes, %d free\n" gc_objects_live gc_bytes_used gc_bytes_free)

  0)

(compile-end)