#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


#comment
FILE OVERVIEW:

Use things function exclusively to manipulate environments

Extra bits in the env is used to carry other properties.
This is possible through the assumption that an env is always
going to be a list
#endcomment


empty_env	= NULL

; input
;	hl - object name (symbol)
;	bc - value
;	de - env
; output
;	de - new env

extend_env:
	call store_bc
extend_env_raw:
	assert_type(symbol, hl)
	ld a,e
	and escape_mask
	cp NULL
	ld a,d
	jr z,_
	cpl
_	and %10000000
	push af
	
	push de
	
	
	ld d,b
	ld e,c
	call list_cons
	pop de
	
	call list_cons
	ex de,hl
	
	pop af
	xor d
	ld d,a
	xor a
	ret
	
	
; intput
;	hl - env
;	de - old env
; output
;	de - env attached to the front of env
	
append_env:
	call list_append
	ex de,hl
	ret
	

; input
;	hl - object name (symbol)
;	de - env
; output
;	hl - object value
;	de - env with object at front	; you can't trust this to retain extra info
;	bc - object name (symbol)
;	z object found, nz object not found
apply_env:
	call list_assq
	ret z
	ld h,b
	ld l,c
	ld de,(global_env)


list_assq:
	assert_type(symbol, hl)
	
apply_env_loop:
	ld a,e
	and escape_mask
	cp NULL
	jp z, apply_env_false
	
	
	push hl
	ld b,h
	ld c,l
	
	push de				; save env
	
	ex de,hl
	
	push bc
	set 7,h
	call list_car
	pop de				; de gets target symbol
	
	push hl				; save binding pair
	
	call list_car
	
	call equal?
	jr nz,binding_not_equal
	
binding_equal:
	pop hl				; restore binding pair
	
	call list_cdr			; get the value
	ld a,l
	cp void
	jr z,binding_invalid
	
	cp a				; set z
	pop de				; env
	pop bc				; symbol
	ret
	
binding_not_equal:
	pop hl				; discard binding pair

binding_invalid:
	pop hl				; restore env
	set 7,h
	call list_cdr			; move to next pair
	ex de,hl
	
	pop hl				; restore object name
	jp apply_env_loop
	
apply_env_false:
	ld b,h
	ld c,l
	xor a\ inc a			; reset z
	ld hl,void			; "empty" value
	ret

	
; input
;	hl - expression starting with lambda formals
;	de - environment
; output
;	hl - list of free vars	
find_free_lambda:
	exx
	ld de,null
	exx
	call handle_free_lambda
	exx
	ex de,hl
	ret
	
	
	
; input
;	hl - expression
;	de - environment
; output
;	hl - list of free vars

find_free:
	exx
	ld de,null
	exx
	call eval_free
	exx
	ex de,hl
	ret
	
	
eval_free:
	call next_char			; make sure we're out of whitespace
	ret z

	ld a,(hl)
	call initiator?
	jr z,eval_free_expr

	call IsNumeric?
	ret z
	
eval_free_var:
	ld a,(hl)
	cp $27				;quote char
	ret z

	call workfetch

	keyprim(kwT)
	ret z

	keyprim(kwF)
	ret z


	push de
	call symbol_make
	pop de
	call apply_env
	ret z

var_is_free:
	push bc
	exx
	pop hl
	ex de,hl
	push hl
	call list_memq
	ld a,l
	cp false
	pop hl
	ex de,hl
	jr nz,_
	call list_cons			; add this var to the free vars list
	ex de,hl
_	exx
	ret
	
eval_free_expr:
	inc hl		;(expr arg arg)
	ld a,(hl)
	call initiator?
	jp z,eval_free_nested
			;(op arg arg)
	call work_fetch
	
eval_free_keywords:
	keyprim(kwLambda)
	jp z, handle_free_lambda
	
	keyprim(kwLet)
	jp z, handle_free_let		; (let ([name* var*] ...) body)
	
	keyprim(kwLetrec)
	jp z, handle_free_letrec
	
	push hl
	ld hl,keywords
	call work_in_list?
	pop hl
	jr z, apply_free_closure	; if it's a primitive, go straight to arg list

	
; hl points to the arg list
eval_free_operator:		;(expr arg arg)
	push hl
	ld hl,work			; work will have operator
	call eval_free_preserve
	pop hl
	jr apply_free_closure
	

; hl points to the operator position
eval_free_nested:
	push hl
	call next_arg
	ex (sp),hl			; first things first, save the arg list	

	call eval_free_preserve
	pop hl				; restore arg list
	
	
; at this point you better have
;	de - environment
;	hl - args list
handle_free_begin:
apply_free_closure:
	ld a,(hl)
	call terminator?
	ret z
	
	push hl
	
	call eval_free_preserve
	
	pop hl
	call next_arg
	jp apply_free_closure
	
eval_free_preserve:
	push de
	call eval_free
	pop de
	ret

	
;; =================================== ;;	
;     v	
;(let ((name value) ...) expr)
handle_free_let:
	push af
	ld a,(hl)
	call initiator?
	pop bc
	ld a,b
	jp nz, handle_free_named_let
	
	call handle_free_let_binding_pairs
;                        v	
;(let ((name value) ...) expr)
	jp handle_free_begin
	
handle_free_named_let:
	push hl
	
	call work_fetch
	call symbol_make
	
	ld bc,void
	call extend_env
	
	pop hl
	call next_arg

	
handle_free_let_binding_pairs:
	inc hl
	
handle_free_let_loop:
	ld a,(hl)
	call terminator?
	jr z,done_handle_free_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_free_preserve

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

	pop hl
	
	call next_arg
	jp handle_free_let_loop
	
done_handle_free_let:
	inc hl
	inc hl
	ret


;; =================================== ;;
;        v	
;(letrec ((name value) ...) expr)
handle_free_letrec:
	push hl
	
	inc hl
	call next_char			; move to first (if there is one) binding pair

handle_free_letrec_loop:
	ld a,(hl)
	call terminator?
	jr z,done_handle_free_letrec
	
	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
	jp handle_free_letrec_loop
	
done_handle_free_letrec:
	pop hl
	
	jp handle_free_let


	
;; =================================== ;;
;     v	
;(let ((name value) ...) expr)
handle_free_lambda:
	inc hl
	
handle_free_lambda_loop:
	ld a,(hl)
	call terminator?
	jr z,done_handle_free_lambda	

	push hl
	
	call work_fetch			; get a name (in work)
	call symbol_make		; turn it into a symbol
	
	ld bc,NULL
	call extend_env
	
	pop hl
	call next_arg
	jp handle_free_lambda_loop
	
done_handle_free_lambda:
	inc hl
	call next_char
	jp handle_free_begin
	
;; =================================== ;;
;      v	
;(cond ((test conseq) ... (else altern)))
handle_free_cond:
	call next_char
handle_free_cond_loop:
	ld a,(hl)
	call terminator?
	ret z
	
	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,_
	
	call next_arg
	pop bc
	jp handle_free_begin
	
_
	push hl
	call eval_free_preserve
	pop hl
	call next_arg
	call eval_free_preserve
	
	pop hl
	call next_arg
	jp handle_free_cond_loop