#comment
     This file is part of Z80 Scheme Interpreter     

     Z80 Scheme Interpreter is free software; you can redistribute it and/or modify
     it under the terms of the GNU General Public License as published by
     the Free Software Foundation; either version 2 of the License, or
     (at your option) any later version.
 
     This program is distributed in the hope that it will be useful,
     but WITHOUT ANY WARRANTY; without even the implied warranty of
     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
     GNU General Public License for more details.
 
     You should have received a copy of the GNU General Public License
     along with this program; if not, write to the Free Software
     Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
 
     Copyright 2007, Spencer Putt
#endcomment


work		= OP1
last_eval	= OP4
last_env	= last_eval + 2
sp_save		= last_env
global_env	= last_env + 6

#define mark_tail() set 7,d
#define mark_nontail() res 7,d

#macro keyprim(kpname)
	push hl
	
	ld hl,kpname
	call work_strcmp
	
	pop hl
#endmacro

#macro keyword(kpname, kpcode)
	keyprim(kpname)
	ld bc,kpcode
	ret z
#endmacro


; input
; 	hl - pointer to a scheme expression
;	de - pointer to an environment
;	bit 7 of d -
;		1 : tail
;		0 : non-tail
;	a  - size of frame used for evaluation
; output
;	hl - result
#comment

Eval is the main evaluation function of the scheme interpreter

Environments are of form ((name . value) (name . value) (name . value))
Expression must be somewhat valid scheme expressions

Unlike most lisp interpreters this evaluator operators on text
instead of converting to lists first.  For now this isn't an issue,
but later it would be quite simple to do so just by modifying
"next arg" and "workfetch" since all operations are done
on "work" anyways.

#endcomment

evaluate:
	ex af,af'
	call next_char			; make sure we're out of whitespace
	ret z

	ld (last_eval),hl 
	
	ld a,(hl)
	call initiator?
	jr z,eval_expr

	call IsNumeric?
	jr nz,eval_var
eval_number:
	call workfetch
	jp worktofixnum
	
eval_var:
	ld a,(hl)
	cp $27				;quote char
	jr nz,_
	inc hl
	jp handle_quote	
_

	ld a,(hl)
	cp $23				; # character
	jr nz,_
	inc hl
	ld a,(hl)
	dec hl
	cp $5C				; \ character			
	jp nz,_
	
	inc hl
	inc hl	
	call work_fetch
	keyword(kwNul, char_nul)

	ld l,tag_char
	ld a,(work)
	ld h,a
	ret
	
char_nul:
	ld l,tag_char
	ld h,0
	ret
_


	call workfetch

	keyprim(kwT)
	jr nz,_
	
	ld hl,true
	ret	
_
	keyprim(kwF)
	jr nz,_
	
	ld hl,false
	ret	
_
	push de
	call symbol_find
	pop de
	call apply_env
	jp nz,err_var
	jp unstore
	
eval_expr:		; v
	inc hl		;(expr arg arg)
	call next_char
	ld a,(hl)
	call initiator?
	jp z,eval_nested
			;(op arg arg)
	call work_fetch
	
	call next_char

	ex af,af'				; get back your frame count
#comment
All the keywords we search for are sequentially
tested here
#endcomment
	
eval_keywords:
	call eval_find_keyword
	jr nz,eval_operator
	
	push bc
	ret
	
#comment
There's only a difference between nested and 
non nested because non nested expressions have to
be checked for keywords anyways

It's a bit of an optimization to just eval
the symbol to a closure than look everything up
again
#endcomment
	
; hl points to the arg list
eval_operator:		;(expr arg arg)
	push af				; save frame count
	push hl				; save arglist
	ld hl,work			; work will have operator

	push de
	res 7,d				; mark it as non-tail
	xor a
	call evaluate
	pop de

	ld c,l
	ld b,h
	pop hl
	pop af
	jr apply_inline_closure
	

; hl points to the operator position
eval_nested:
	ex af,af'
	push af				; save frame count
	push hl				; save arg list
	call next_arg
	ex (sp),hl			; first things first, save the arg list	

	push de
	res 7,d				; mark it as non-tail
	xor a
	call evaluate
	pop de	

	ld c,l
	ld b,h
	
	pop hl				; restore arg list
	pop af
	
	
; at this point you better have
;	de - environment
;	bc - closure
;	hl - args list
;	a  - frame count
apply_inline_closure:
	
	; must evaluate to a closure
	bit 7,d				; are we tail?
	push bc				; save closure


#comment
The next step is to run through the arglist of the closure
and add values to the env according to the args.

If the call is tail, we may first remove
the frame belonging to the current call.  The trick is each
eval passes along the argument count.
#endcomment
	push de				; save pre-frame reuse env (needed for eval args)

	jr z,_				; skip the frame-reuse code if it's nontail
	or a
	jr z,_				; skip the frame-reuse code if there was no frame

	ex de,hl
	ld b,a
closure_frame_remove:
	call list_cdr			; remove an binding pair
	djnz closure_frame_remove
	ex de,hl
	xor a
_

	; hl = argslist
	; de = new env
	ex de,hl
	ex (sp),hl			; save new env, restore old
	ex de,hl
	call handle_list		; create the arg values list
	pop de
	pop bc				; restore closure
	jp apply_closure
	
	
; input
;	hl - pointer to scheme expression
;	de - scheme env
; output
;	hl - result of evaluation
#comment
Eval preserve places an env that would be destroyed
onto the root stack

#endcomment
eval_preserve:
	push de
	call evaluate
	pop de
	ret
	
eval_nontail:
	res 7,d
	jp evaluate
	
eval_preserve_nontail:
	push de
	res 7,d
	call evaluate
	pop de
	ret
	
	
	
	
	
eval_find_keyword:
	keyword(kwIf, handle_if)

	keyword(kwCond, handle_cond)	; (cond ((test conseq) ... (else conseq)))
	
	keyword(kwLambda, handle_lambda); (lambda (formals* ...) body)
	
	keyword(kwLet, handle_let)	; (let ([name* var*] ...) body)
	
	keyword(kwLetrec, handle_letrec); (letrec ([name* var*] ...) body)
	
	keyword(kwAdd, handle_add)	; (+ a1 a2)
	
	keyword(kwSub, handle_sub)	; (- a1 a2)
	
	keyword(kwDiv, handle_div)	; (- a1 a2)
		
	keyword(kwMul, handle_mul)	; (* a1 a2)
	
	keyword(kwEqu, handle_equ)	; (= a1 a2)
	
	keyword(kwGR, handle_GR	)	; (> a1 a2)

	keyword(kwGRE, handle_GRE)	; (>= a1 a2)
	
	keyword(kwLS, handle_LS	)	; (< a1 a2)
	
	keyword(kwLSE, handle_LSE)	; (<= a1 a2)
		
	keyword(kwRemainder, handle_remainder)	; (- a1 a2)
	
	keyword(kwRandom, handle_random); (- a1 a2)
		
	keyword(kwQuote, handle_quote)	; (quote expr)
	
	keyword(kwCdr, handle_cdr)	; (cdr expr)
	
	keyword(kwCons, handle_cons)	; (cons expr)
	
	keyword(kwCar, handle_car)	; (car expr)
	
	keyword(kwNull?, handle_null?)	; (null? ls)
	
	keyword(kwAppend, handle_append); (append ls1 ls2)
	
	keyword(kwnot, handle_not)	; (not arg)
	
	keyword(kwor, handle_or	)	; (or arg arg* ...)
	
	keyword(kwand, handle_and)	; (and arg arg* ...)
	
	keyword(kwDefine, handle_define); (define name arg)
	
	keyword(kwList, handle_list)	; (list arg* ...)
	
	keyword(kwEq?, handle_eq?)	; (eq? a1 a2)
	
	keyword(kwEqual?, handle_equal?); (equal? a1 a2)
	
	keyword(kwZero?, handle_zero?)	; (zero? a1)
	
	keyword(kwSub1, handle_sub1)	; (sub1 a1)
	
	keyword(kwAdd1, handle_add1)	; (add1 a1)
	
	keyword(kwList?, handle_list?)	; (list? a1)
	
	keyword(kwNumber?, handle_number?) ; (number? a1)
	
	keyword(kwSymbol?, handle_symbol?) ; (boolean? a1)
	
	keyword(kwBoolean?, handle_boolean?) ; (boolean? a1)
	
	keyword(kwPair?, handle_pair?)	; (pair? a1)
	
	keyword(kwMember, handle_member) ; (member a1 a2)
	
	keyword(kwAssq, handle_assq)	; (assq a1 a2)

	keyword(kwMap, handle_map)	; (map a1 a2)
	
	keyword(kwBegin, handle_begin)
	
	keyword(kwSet!, handle_set!)

	keyword(kwSetCar!, handle_set_car!)
	keyword(kwSetCdr!, handle_set_cdr!)
	
	keyword(kwMakeVector, handle_make_vector!)
	
	keyword(kwVectorSet!, handle_vector_set!)
	keyword(kwVectorRef, handle_vector_ref)
	keyword(kwVectorLength, handle_vector_length)
	
	keyword(kwGarbageCollect, handle_garbage_collect)
	keyword(kwHeapUsed, handle_heap_used)
	keyword(kwExit, exit)
	ret	
	
	
	
;; =================================== ;;
handle_if:
#comment
Scheme "if" consequences and alternatives are
never both evaluated, this is an exception
to the language
#endcomment
	push af
	
	push hl
	call next_arg
	ex (sp),hl
	
	;     v
	; (if test conseq altern)
	call eval_preserve_nontail			; eval the "test" portion
	
	ld a,l
	pop hl
	cp FALSE
	call z,next_arg						; if the test = false, skip first arg
	
	pop af
	;          *      *
	; (if test conseq altern)
	jp evaluate
	
;; =================================== ;;
;      v	
;(cond ((test conseq) ... (else altern)))
handle_cond:
	push af
handle_cond_loop:
	ld a,(hl)
	call terminator?
	jp z,handle_cond_done
	
	push hl				
	inc hl

	;        v	
	;(cond ((test conseq) ... (else altern)))
	push hl
	call work_fetch
	ld hl,kwElse
	call work_strcmp
	pop hl
	jr nz,_								; is the keyword "else"?
	
	call next_arg
	pop bc
	pop af
	jp evaluate
	
_
	push hl
	call eval_preserve_nontail
	
	ld a,l
	cp FALSE
	pop hl
	jr z,_
	
	call next_arg
	pop bc
	pop af
	jp handle_begin
	
_	
	pop hl
	call next_arg
	jp handle_cond_loop
	
handle_cond_done:
	pop af
	ld hl,void
	ret
		
;; =================================== ;;	
handle_lambda:
	jp make_closure
 
 
 ;; ================================== ;;
handle_letrec:

	push hl				; store original arg pointer

	push af
	inc hl
	call next_char			; move to first (if there is one) binding pair
	pop af
	
	push hl				; store start of first binding pair
handle_letrec_initial_loop:
	push af

	ld a,(hl)
	call terminator?
	jr z,done_handle_letrec_initial
	
	push hl
	inc hl
	
	call work_fetch
	call symbol_make		; grab the identifier
	
	ld bc,empty
	call extend_env			; add an empty binding pair to the env
	
	pop hl
	call next_arg
	
	pop af
	inc a
	jp handle_letrec_initial_loop
	
done_handle_letrec_initial:
	pop hl				; pop off final frame count
	ex (sp),hl			; put final frame count back, get off arg pointer
	
handle_letrec_loop:
	ld a,(hl)
	call terminator?
	jr z,done_handle_letrec
	
	push hl
	inc hl
	call next_char
	
	push de
	call handle_set!
	pop de				; de = env
	
	pop hl
	call next_arg
	jp handle_letrec_loop
	
done_handle_letrec:
	pop af				; restore final frame count
	
	pop hl				; restore original arg pointer
	push af
	call next_arg
	pop af
	jp handle_begin			; run implicit begin
	
;; =================================== ;;	
;     v	
;(let ((name value) ...) expr)
;(let name ((name value) ...) expr)
handle_let:
	push af
	ld a,(hl)
	call initiator?
	pop bc
	ld a,b
	jp nz, handle_named_let
	
	call handle_let_binding_pairs
;                        v	
;(let ((name value) ...) expr)
	jp handle_begin
	
handle_named_let:
	push hl				; save name position
	
	call next_arg			; goto binding pairs

	;v
	;((var val) ...)
	push hl
	
	inc hl
	call next_char			; first binding pair
	
	; v
	;((var val) ...)
	exx
	ld de,empty_env
	exx
	; de - env
	; hl - binding pairs

	call argcount
	ld b,a
handle_named_let_loop:
	dec b
	jp m,handle_named_let_next
	
	push bc
	push hl

	ld a,b
	call get_nth_arg
	
	inc hl				; pass parenthesis
	call next_char
	
	push hl
	
	call work_fetch
	call symbol_make
	
	ex (sp),hl			; store symbol, restore arg pointer
	
	call next_arg
	jp nz,err_arg			; without an arg, this is an error
	
	exx\ push de\ exx

	call eval_preserve_nontail

	push hl
	
	exx
	pop bc				; value
	pop de				; env
	pop hl				; name
	call extend_env			; add this onto the env'
	exx
	
	
	pop hl
	pop bc
	
	jp handle_named_let_loop
	
handle_named_let_next:
	pop hl
	call next_arg
	
	; de - env
	; de' - env'
	; hl - code
	ex (sp),hl			; save code, restore name
	
	call work_fetch
	call symbol_make		; get the named let name
	
	push hl				; save name
	call alloc			; alloc closure
	
	push hl
	ld a,l
	or tag_closure
	ld l,a

	ld c,l
	ld b,h
	pop hl
	
	ex (sp),hl			; save raw address (not closure tagged)
					; restore symbol name
	
	;name = named let name, env = current env, bc = tagged closure
	call extend_env			; add the symbol to the current env
		
	pop hl				; restore raw closure address
	
	; stack - code
	; hl - closure address
	; de - env
	; de' - env'
	
	exx
		ex de,hl
		
		; stack - code
		; hl - list of binding pairs	; the env here is just a list of binding
						; pairs afterall, we started with an empty env
		
		push hl			;((ls '(a b c)) (n 6))
		ld c,1 | 128
		call list_zip_nth_arg		
		;call pretty_print

		ex (sp),hl			; store the values list
		ld c,0
		call list_zip_nth_arg		; get the names list

		ex de,hl			; de = names list
		
		call alloc			; allocate env . names pair
		call set_cdr!_skip		; set the cdr to the list of names
		
		push hl				; save address of env . names pair (skip doesn't tag it)
	exx
	ex (sp),hl			; save closure address
					; restore address of env . names
	
	call set_car!_skip		; set car to the current env (nasty on heap but a good short cut)
	

	; stack - closure addr
	;	- values list
	;	- code
	; hl - env . names
	; de - env
	
	pop de				; restore closure addr
	ex de,hl			; hl = closure addr, de = env . names
	ld a,e
	or tag_pair
	ld e,a
	call set_car!_skip
	
	; stack - values list
	;	- code
	; hl - closure addr
	; de - env . names
	
	pop bc				; restore values list
	pop de				; code
	call set_cdr!_skip
	
	
; input
;	bc - closure
;	hl - arglist			; pair or single arg
; output
;	hl - result of applying closure

	push bc
	ex (sp),hl
	pop bc
	jp apply_closure_skip		; skip the tag checking (I guarantee no tag)
	
	
	
; input
;	hl - pointer to binding pairs
;	a  - frame size
handle_let_binding_pairs:
	inc hl
handle_let_loop:
	push af
	
	ld a,(hl)
	call terminator?
	jr z,done_handle_let

	push hl
;       v
;(let ((name value) ...) expr)
	inc hl
	
	push hl
	
	call work_fetch			; get a name (in work)
	call symbol_make		; turn it into a symbol
	
	ex (sp),hl			; get back pointer / store symbol
	
	call next_arg
	jp nz,err_arg
	
;            v	
;(let ((name value) ...) expr)
	call eval_preserve_nontail

	ld b,h
	ld c,l				; bc gets value	
	
	pop hl
	call extend_env

	pop hl
	
	call next_arg
	pop af
	inc a				; add to the frame size
	jp handle_let_loop
	
done_handle_let:
	pop af
;                      v	
;(let ((name value) ...) expr)
	inc hl
	ret
	
;; =================================== ;;
handle_add:
	call eval_two_args
	jp fixnum_add
	
;; =================================== ;;	
handle_sub:
	break()
	call eval_two_args
	jp fixnum_sub
	
;; =================================== ;;	
handle_div:
	call eval_two_args
	jp fixnum_div	

;; =================================== ;;	
handle_mul:
	call eval_two_args
	jp fixnum_mul	
	
;; =================================== ;;	
handle_remainder:
	call eval_two_args
	call fixnum_div
	ex de,hl							; get the remainder into hl
	ret	
	
handle_random:
	call eval_nontail
	jp fixnum_random	
	
;; =================================== ;;	
handle_equ:
	call eval_two_args
	jp fixnum_equal?
	
;; =================================== ;;
handle_GR:
	call eval_two_args
	jp fixnum_GR
;; =================================== ;;
handle_GRE:
	call eval_two_args
	jp fixnum_GRE
;; =================================== ;;
handle_LS:
	call eval_two_args
	jp fixnum_LS
;; =================================== ;;
handle_LSE:
	call eval_two_args
	jp fixnum_LSE

;; =================================== ;;
handle_null?:
	call eval_nontail
	jp list_null?
	
;; =================================== ;;
handle_append:
	call eval_two_args
	
	assert_type(pair, hl)
	assert_type(pair, de)
	
	jp list_append
	
;; =================================== ;;
handle_not:
	call eval_nontail
	ld a,l
	cp false
	jp nz_to_bool
	
;; =================================== ;;
;	v
;(quote expr)
handle_quote:
	ld a,(hl)
	call initiator?
	jr z, nested_quote
	
	ld a,(hl)
	cp $27
	jr nz,not_inner_quote
	
	push hl
	
	ld hl,kwQuote
	call work_fetch
	call symbol_make		; make the quote symbol
	
	ex (sp),hl
	
	inc hl
	call next_char
	call handle_quote
	ld de,null
	call list_cons
	ex de,hl
	pop hl
	jp list_cons
	
not_inner_quote:
	
	call isNumeric?
	push af
	call work_fetch
	pop af
	jp z,worktofixnum
	
	jp symbol_make
	
	
nested_quote:
	inc hl
	
; input
; 	hl - string like this   x x x)
; output
;	hl - output pair
quote_long_list:
	ld a,(hl)
	call terminator?
	jp z,quote_empty_list		; if we were allowed to reach the end, it's a proper list
	

	push hl
	call workfetch
	
	keyprim(kwDot)
	pop hl				;                 v
	jr nz,quote_long_list_rest	; check for       . x)
	
	
	call next_arg			;   v
	jp nz,err_list			; . x)
	
	jp handle_quote
	
	
quote_long_list_rest:
	push hl
	call handle_quote
	
	ex (sp),hl
	
	call next_arg
	call quote_long_list		;
	ex de,hl
	pop hl
	
	jp list_cons
	
quote_empty_list:
	ld hl,null
	ret

;; =================================== ;;	
;      v
;(cons kar kdr)
handle_cons:
	push hl
	
	call eval_preserve
	
	ex (sp),hl
	call arg_skip
	
	call evaluate
	pop de
	ex de,hl
	jp list_cons
	
;; =================================== ;;	
;     v
;(cdr ls)
handle_cdr:
	call evaluate			; evaluate ls
	jp list_cdr			; get the cdr
	
handle_car
	call evaluate
	jp list_car
	
;; =================================== ;;
;    v
;(or arg1 arg* ...)	
handle_or:
handle_or_loop:
	ld a,(hl)
	cp $29
	jp z,done_handle_or_false
	
	push hl

	call eval_preserve		; get the value
	
	ld a,l
	cp false
	jr nz,done_handle_or_true
	pop hl
	
	call next_arg
	jp handle_or_loop
	
done_handle_or_false:
	ld hl,false
	ret
done_handle_or_true:
	pop bc
	ret
	
;; =================================== ;;
;     v
;(and arg1 arg* ...)	
handle_and:
handle_and_loop:
	ld a,(hl)
	cp $29
	jp z,done_handle_and_true
	
	push hl

	call eval_preserve		; get the value
	
	ld a,l
	cp false
	jr z,done_handle_and_false
	pop hl
	
	call next_arg
	jp handle_and_loop
	
done_handle_and_false:
	pop bc
	ret
done_handle_and_true:
	ld hl,true
	ret
	
	
;; =================================== ;;
#comment
Although this can start with any environment,
it is almost required to be the global env
#endcomment
;        v
;(define name arg)
handle_define:
	push hl
	
	push af
	call work_fetch			; get a name (in work)
	call symbol_make		; turn it into a symbol
	pop af	
	
	push af
	push hl				; save symbol
	
	ld de,(global_env)
	push de				; save old environment
	call apply_env	
	pop de
	
	pop hl				; restore symbol
	jr z, define_already_defined
	
	ld bc,empty
	call extend_env
	
	ld (global_env),de
	
define_already_defined:
	pop af
	
	pop hl
	jp handle_set!
	
;; =================================== ;;
handle_list:

handle_list_loop:
	ld a,(hl)
	call terminator?
	jp z,done_handle_list

	push hl

	call eval_preserve_nontail	; get the value

	ex (sp),hl
	call next_arg

	call handle_list
	ex de,hl
	pop hl
	jp list_cons
	
done_handle_list:
	ld hl,null
	ret

;; =================================== ;;
handle_eq?:
	call eval_two_args
	call symbol_equal?
	jp nz_to_bool
	
;; =================================== ;;	
handle_equal?
	call eval_two_args
	jp equal?
	
;; =================================== ;;
handle_zero?:
	call eval_nontail
	jp fixnum_zero?

;; =================================== ;;
handle_sub1:
	call eval_nontail
	jp fixnum_sub1
	
;; =================================== ;;
handle_add1:
	call eval_nontail
	jp fixnum_add1	

;; =======================2============ ;;	
handle_list?:
	call eval_nontail
	
handle_list?_loop:
	call list_null_nz
	jp z, z_true
	
	push hl
	call handle_pair?
	pop hl
	jp nz, nz_false

	call list_cdr
	jp handle_list?_loop
	
;; =================================== ;;	
handle_number?
	call eval_nontail
	
	ld a,l
	and tag_mask
	cp tag_fixnum
	jp nz_to_bool
;; =================================== ;;		
handle_boolean?:
	call eval_nontail

	ld a,l
	and escape_mask
	cp tag_bool
	jp nz_to_bool
;; =================================== ;;		
handle_symbol?:
	call eval_nontail

	ld a,l
	and escape_mask
	cp tag_symbol
	jp nz_to_bool
	
;; =================================== ;;
handle_pair?
	call eval_nontail

	ld a,l
	and tag_mask
	cp tag_pair
	jp nz_to_bool
	
;; =================================== ;;
handle_member:
	call eval_two_args
	ex de,hl
	jp list_memq
	
;; =================================== ;;
handle_assq:
	call eval_two_args

	call list_assq
	ret nz
	ex de,hl
	call list_car
	ret
	
;; =================================== ;;
handle_map:
	push hl
	call eval_preserve_nontail
	ex (sp),hl
	call next_arg
	call handle_list		; convert the the arguments to a list
	call list_zip
	pop bc

handle_map_loop:
	call list_null_nz
	ret z
	
	push hl
;	de - environment
;	bc - closure
;	hl - args list
;	a  - frame count
	push de
	call list_car
	push bc
	call apply_closure
	pop bc
	pop de

	ex (sp),hl
	call list_cdr
	call handle_map_loop
	ex de,hl
	
	pop hl
	jp list_cons

;; =================================== ;;
;       v
;(begin expr1 ... exprn)
handle_begin:
	push af
	ld a,(hl)
	call terminator?
	pop bc
	ld a,b
	ret z
	
	push af				; save original frame size
	push de				; save the original tail bit
	
handle_begin_loop:
	push hl
	call next_arg
	pop hl
	jp nz,begin_last_expr
	
	push hl

	call eval_preserve_nontail	; get the value
	
	pop hl
	
	call next_arg
	jp handle_begin_loop

begin_last_expr:
	pop de
	pop af
	jp evaluate
	
	
;; =================================== ;;
;      v
;(set! var val)
handle_set!:
	push hl
	push af
	call work_fetch
	call symbol_make
	pop af
	ex (sp),hl
	call next_arg
	
	call eval_preserve_nontail
	
	ex (sp),hl
	call apply_env			; look up the symbol in question
	pop de				; restore new value
	ret nz				; for now, just exit if the symbol doesn't exist
	
	call set_car!

	ld hl,void
	ret
	
;; =================================== ;;
;          v
;(set-car! ls val)
handle_set_car!:
	call eval_two_args
	jp set_car!
	
;; =================================== ;;
;          v
;(set-cdr! ls val)
handle_set_cdr!:
	call eval_two_args
	jp set_cdr!
	
	
	
;; =================================== ;;
;             V
;(make-vector length value)
handle_make_vector!:
	call eval_two_args
	call fixnum_to_value
	jp vector_create
	
;; =================================== ;;
;             v
;(vector-set! v i value)	
handle_vector_set!:
	push hl
	call eval_preserve_nontail
	ex (sp),hl
	call next_arg
	call eval_two_args

	ex de,hl
	ld b,h
	ld c,l
	
	pop hl
	ex de,hl
	call fixnum_to_value
	ex de,hl
	call vector_set!
	ld hl,void
	ret


;; =================================== ;;
;            v
;(vector-ref v i)
handle_vector_ref:
	call eval_two_args
	ex de,hl
	call fixnum_to_value
	ex de,hl
	jp vector_ref


;; =================================== ;;
handle_vector_length:
	call eval_nontail
	call block_size
	add hl,hl\ add hl,hl
	ret

;; =================================== ;;
handle_garbage_collect:
	ld hl,(ap)

	bit 6,h
	jr nz,_				; nz if I'm in the upper heap
	ld hl,heap + (heap_size/2)
	jr ++_
_	ld hl,heap
_
	; put the opposite heap into ap as if
	; the heap were full
	ld (ap),hl
	call garbage_collect

	ld hl, void
	ret

;; =================================== ;;
handle_heap_used:
	ld hl,(ap)
	bit 6,h
	jr nz,_				; nz if I'm in the upper heap
	ld de,heap
	jr ++_
_	
	ld de,heap + (heap_size/2)
_
	or a
	sbc hl,de
	add hl,hl
	add hl,hl
	ret
	
; input
;	hl - start of the arg list
;	de - environment
; output
;	hl - first arg evaluated
;	de - second arg evaluated
	
eval_two_args:
	push hl
	push af
	xor a
	call eval_preserve
	pop af

	ex (sp),hl
	call arg_skip

	push af
	xor a
	call evaluate
	pop af

	pop de
	ex de,hl
	ret
	
	
; input
;	hl - pointer to scheme expression
; output
;	a - argument count to operator

#comment
 Must be a correctly formed scheme expression
 hl should point to the first argument
#endcomment
	
argcount:
arg_count:
	push hl
	ld a,1
arg_count_loop:
	push af
	call argskip
	jr z,arg_count_next
	pop af
	pop hl
	ret
arg_count_next:
	pop af
	inc a
	jr arg_count_loop
	

; input
;	hl - pointer to a scheme arg expression
; output
;	z = there was a next arg
;		hl - pointer to next arg
;	nz = there was no next arg	
	
argskip:
arg_skip:
next_arg:
	call next_char
	
	ld b,0
	
	
argskip_loop:
	ld a,(hl)
	or a
	jr nz,_
	inc a				; we should never reach an EOF
	ret	
_
	call initiator?
	jr nz,_
	inc b
_
	call terminator?
	jr nz,_
	dec b
	jp m,argskip_done
_
	call white_space?
	jr z,argskip_end?
	inc hl
	jr argskip_loop
	
argskip_end?:
	inc hl
	inc b\ dec b
	jp nz,argskip_loop

argskip_done:
	bit 7,b
	ret nz
	call next_char
	jr z,argskip_fail
	xor a
	ret
	
argskip_fail:
	xor a
	inc a
	ret
	
	
; input
;	hl - first argument
;	a - n
; output
;	z = got arg
;		hl - nth argument
;	nz = failed to get arg

get_nth_arg:
	ld b,0
get_nth_loop:
	cp b
	ret z
	push af
	push bc
	call argskip
	pop bc
	jr z,get_nth_next
	pop af
	xor a\ inc a
	ret
get_nth_next:
	pop af
	inc b
	jr get_nth_loop